/fth/savedicd.fth
https://github.com/philburk/pforth · Forth · 177 lines · 153 code · 24 blank · 0 comment · 4 complexity · c078fba4829119d26c53dbd3fe299a20 MD5 · raw file
- \ @(#) 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