git.gag.com Git - debian/pforth/blob - fth/savedicd.fth

   1 \ @(#) savedicd.fth 98/01/26 1.2
   2 \ Save dictionary as data table.
   3 \
   4 \ Author: Phil Burk
   5 \ Copyright 1987 Phil Burk
   6 \ All Rights Reserved.
   7 \
   8 \ 970311 PLB Fixed problem with calling SDAD when in HEX mode.
   9 \ 20010606 PLB Fixed AUTO.INIT , started with ';' !!
  10
  11 decimal
  12 ANEW TASK-SAVE_DIC_AS_DATA
  13
  14 \ !!! set to 4 for minimally sized dictionary to prevent DIAB
  15 \ compiler from crashing!  Allocate more space in pForth.
  16 4 constant SDAD_NAMES_EXTRA   \ space for additional names
  17 4 constant SDAD_CODE_EXTRA    \ space for additional names
  18
  19 \ buffer the file I/O for better performance
  20 256 constant SDAD_BUFFER_SIZE
  21 create SDAD-BUFFER SDAD_BUFFER_SIZE allot
  22 variable SDAD-BUFFER-INDEX
  23 variable SDAD-BUFFER-FID
  24         0 SDAD-BUFFER-FID !
  25
  26 : SDAD.FLUSH  ( -- ior )
  27     sdad-buffer sdad-buffer-index @  \ data
  28 \ 2dup type
  29     sdad-buffer-fid @  write-file
  30     0 sdad-buffer-index !
  31 ;
  32
  33 : SDAD.EMIT  ( char -- )
  34     sdad-buffer-index @  sdad_buffer_size >=
  35     IF
  36         sdad.flush abort" SDAD.FLUSH failed!"
  37     THEN
  38 \
  39     sdad-buffer sdad-buffer-index @ + c!
  40     1 sdad-buffer-index +!
  41 ;
  42
  43 : SDAD.TYPE  ( c-addr cnt -- )
  44     0 DO
  45         dup c@ sdad.emit    \ char to buffer
  46         1+   \ advance char pointer
  47     LOOP
  48     drop
  49 ;
  50
  51 : $SDAD.LINE  ( $addr -- )
  52     count sdad.type
  53     EOL sdad.emit
  54 ;
  55
  56 : (U8.)  ( u -- a l , unsigned conversion, at least 8 digits )
  57     0 <#  # # # #  # # # #S #>
  58 ;
  59 : (U2.)  ( u -- a l , unsigned conversion, at least 2 digits )
  60     0 <#  # #S #>
  61 ;
  62
  63 : SDAD.CLOSE ( -- )
  64     SDAD-BUFFER-FID @ ?dup
  65     IF
  66         sdad.flush abort" SDAD.FLUSH failed!"
  67         close-file drop
  68         0 SDAD-BUFFER-FID !
  69     THEN
  70 ;
  71
  72 : SDAD.OPEN  ( -- ior, open file )
  73     sdad.close
  74     s" pfdicdat.h" r/w create-file dup >r
  75     IF
  76         drop ." Could not create file pfdicdat.h" cr
  77     ELSE
  78         SDAD-BUFFER-FID !
  79     THEN
  80     r>
  81 ;
  82
  83 : SDAD.DUMP.HEX  { val -- }
  84     base @ >r hex
  85     s" 0x" sdad.type
  86     val (u8.) sdad.type
  87     r> base !
  88 ;
  89 : SDAD.DUMP.HEX,
  90     s"    " sdad.type
  91     sdad.dump.hex
  92     ascii , sdad.emit
  93 ;
  94
  95 : SDAD.DUMP.HEX.BYTE  { val -- }
  96     base @ >r hex
  97     s" 0x" sdad.type
  98     val (u2.) sdad.type
  99     r> base !
 100 ;
 101 : SDAD.DUMP.HEX.BYTE,
 102     sdad.dump.hex.byte
 103     ascii , sdad.emit
 104 ;
 105
 106 : SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- }
 107     end-address start-address - -> num-bytes
 108     num-bytes 0
 109     ?DO
 110         i $ 7FF and 0= IF ." 0x" i .hex cr THEN   \ progress report
 111         i 15 and 0=
 112         IF
 113
 114              EOL sdad.emit
 115              s" /* " sdad.type
 116              i sdad.dump.hex
 117              s" : */ " sdad.type
 118         THEN   \ 16 bytes per line, print offset
 119         start-address   i + c@
 120         sdad.dump.hex.byte,
 121     LOOP
 122 \
 123     num-zeros 0
 124     ?DO
 125         i $ 7FF and 0= IF i . cr THEN   \ progress report
 126         i 15 and 0= IF EOL sdad.emit THEN   \ 15 numbers per line
 127         0 sdad.dump.hex.byte,
 128     LOOP
 129 ;
 130
 131 : SDAD.DEFINE  { $name val -- }
 132     s" #define " sdad.type
 133     $name  count sdad.type
 134     s"   (" sdad.type
 135     val sdad.dump.hex
 136     c" )" $sdad.line
 137 ;
 138
 139 : IS.LITTLE.ENDIAN?  ( -- flag , is Forth in Little Endian mode? )
 140     1 pad !
 141     pad c@
 142 ;
 143
 144 : SDAD   { | fid -- }
 145     sdad.open abort" sdad.open failed!"
 146 \ Write headers.
 147     c" /* This file generated by the Forth command SDAD */" $sdad.line
 148
 149     c" HEADERPTR" headers-ptr @ namebase - sdad.define
 150     c" RELCONTEXT" context @ namebase - sdad.define
 151     c" CODEPTR" here codebase - sdad.define
 152     c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define
 153
 154 ." Saving Names" cr
 155     s" static const uint8_t MinDicNames[] = {" sdad.type
 156     namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data
 157     EOL sdad.emit
 158     c" };" $sdad.line
 159
 160 ." Saving Code" cr
 161     s" static const uint8_t MinDicCode[] = {" sdad.type
 162     codebase here SDAD_CODE_EXTRA sdad.dump.data
 163     EOL sdad.emit
 164     c" };" $sdad.line
 165
 166     sdad.close
 167 ;
 168
 169 if.forgotten sdad.close
 170
 171 : AUTO.INIT ( -- , init at launch )
 172     auto.init \ daisy chain initialization
 173     0 SDAD-BUFFER-FID !
 174     0 SDAD-BUFFER-INDEX !
 175 ;
 176
 177 ." Enter: SDAD" cr