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