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

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