fth/savedicd.fth

\ @(#) savedicd.fth 98/01/26 1.2
\ Save dictionary as data table.
\
\ Author: Phil Burk
\ Copyright 1987 Phil Burk
\ All Rights Reserved.
\
\ 970311 PLB Fixed problem with calling SDAD when in HEX mode.
\ 20010606 PLB Fixed AUTO.INIT , started with ';' !!

decimal
ANEW TASK-SAVE_DIC_AS_DATA

\ !!! set to 4 for minimally sized dictionary to prevent DIAB
\ compiler from crashing!  Allocate more space in pForth.
4 constant SDAD_NAMES_EXTRA   \ space for additional names
4 constant SDAD_CODE_EXTRA    \ space for additional names

\ buffer the file I/O for better performance
256 constant SDAD_BUFFER_SIZE
create SDAD-BUFFER SDAD_BUFFER_SIZE allot
variable SDAD-BUFFER-INDEX
variable SDAD-BUFFER-FID
        0 SDAD-BUFFER-FID !

: SDAD.FLUSH  ( -- ior )
    sdad-buffer sdad-buffer-index @  \ data
\ 2dup type
    sdad-buffer-fid @  write-file
    0 sdad-buffer-index !
;

: SDAD.EMIT  ( char -- )
    sdad-buffer-index @  sdad_buffer_size >=
    IF
        sdad.flush abort" SDAD.FLUSH failed!"
    THEN
\
    sdad-buffer sdad-buffer-index @ + c!
    1 sdad-buffer-index +!
;

: SDAD.TYPE  ( c-addr cnt -- )
    0 DO
        dup c@ sdad.emit    \ char to buffer
        1+   \ advance char pointer
    LOOP
    drop
;

: $SDAD.LINE  ( $addr -- )
    count sdad.type
    EOL sdad.emit
;

: (U8.)  ( u -- a l , unsigned conversion, at least 8 digits )
    0 <#  # # # #  # # # #S #>
;
: (U2.)  ( u -- a l , unsigned conversion, at least 2 digits )
    0 <#  # #S #>
;

: SDAD.CLOSE ( -- )
    SDAD-BUFFER-FID @ ?dup
    IF
        sdad.flush abort" SDAD.FLUSH failed!"
        close-file drop
        0 SDAD-BUFFER-FID !
    THEN
;

: SDAD.OPEN  ( -- ior, open file )
    sdad.close
    s" pfdicdat.h" r/w create-file dup >r
    IF
        drop ." Could not create file pfdicdat.h" cr
    ELSE
        SDAD-BUFFER-FID !
    THEN
    r>
;

: SDAD.DUMP.HEX  { val -- }
    base @ >r hex
    s" 0x" sdad.type
    val (u8.) sdad.type
    r> base !
;
: SDAD.DUMP.HEX,
    s"    " sdad.type
    sdad.dump.hex
    ascii , sdad.emit
;

: SDAD.DUMP.HEX.BYTE  { val -- }
    base @ >r hex
    s" 0x" sdad.type
    val (u2.) sdad.type
    r> base !
;
: SDAD.DUMP.HEX.BYTE,
    sdad.dump.hex.byte
    ascii , sdad.emit
;

: SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- }
    end-address start-address - -> num-bytes
    num-bytes 0
    ?DO
        i $ 7FF and 0= IF ." 0x" i .hex cr THEN   \ progress report
        i 15 and 0=
        IF

             EOL sdad.emit
             s" /* " sdad.type
             i sdad.dump.hex
             s" : */ " sdad.type
        THEN   \ 16 bytes per line, print offset
        start-address   i + c@
        sdad.dump.hex.byte,
    LOOP
\
    num-zeros 0
    ?DO
        i $ 7FF and 0= IF i . cr THEN   \ progress report
        i 15 and 0= IF EOL sdad.emit THEN   \ 15 numbers per line
        0 sdad.dump.hex.byte,
    LOOP
;

: SDAD.DEFINE  { $name val -- }
    s" #define " sdad.type
    $name  count sdad.type
    s"   (" sdad.type
    val sdad.dump.hex
    c" )" $sdad.line
;

: IS.LITTLE.ENDIAN?  ( -- flag , is Forth in Little Endian mode? )
    1 pad !
    pad c@
;

: SDAD   { | fid -- }
    sdad.open abort" sdad.open failed!"
\ Write headers.
    c" /* This file generated by the Forth command SDAD */" $sdad.line

    c" HEADERPTR" headers-ptr @ namebase - sdad.define
    c" RELCONTEXT" context @ namebase - sdad.define
    c" CODEPTR" here codebase - sdad.define
    c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define

." Saving Names" cr
    s" static const uint8_t MinDicNames[] = {" sdad.type
    namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data
    EOL sdad.emit
    c" };" $sdad.line

." Saving Code" cr
    s" static const uint8_t MinDicCode[] = {" sdad.type
    codebase here SDAD_CODE_EXTRA sdad.dump.data
    EOL sdad.emit
    c" };" $sdad.line

    sdad.close
;

if.forgotten sdad.close

: AUTO.INIT ( -- , init at launch )
    auto.init \ daisy chain initialization
    0 SDAD-BUFFER-FID !
    0 SDAD-BUFFER-INDEX !
;

." Enter: SDAD" cr