Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.16 | \ converts primitives to, e.g., C code |
| 2 : | |||
| 3 : | \ Copyright (C) 1995 Free Software Foundation, Inc. | ||
| 4 : | |||
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | \ as published by the Free Software Foundation; either version 2 | ||
| 10 : | \ of the License, or (at your option) any later version. | ||
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | \ along with this program; if not, write to the Free Software | ||
| 19 : | \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 20 : | |||
| 21 : | |||
| 22 : | anton | 1.1 | \ This is not very nice (hard limits, no checking, assumes 1 chars = 1) |
| 23 : | |||
| 24 : | \ Optimizations: | ||
| 25 : | \ superfluous stores are removed. GCC removes the superfluous loads by itself | ||
| 26 : | \ TOS and FTOS can be kept in register( variable)s. | ||
| 27 : | \ | ||
| 28 : | \ Problems: | ||
| 29 : | \ The TOS optimization is somewhat hairy. The problems by example: | ||
| 30 : | \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w; | ||
| 31 : | \ The store is not superfluous although the earlier opt. would think so | ||
| 32 : | \ Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w; | ||
| 33 : | \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */ | ||
| 34 : | \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */ | ||
| 35 : | \ 4) ( -- ): /* but here they are unnecessary */ | ||
| 36 : | \ 5) Words that call NEXT themselves have to be done very carefully. | ||
| 37 : | \ | ||
| 38 : | \ To do: | ||
| 39 : | pazsan | 1.8 | \ add the store optimization for doubles |
| 40 : | anton | 1.1 | \ regarding problem 1 above: It would be better (for over) to implement |
| 41 : | \ the alternative | ||
| 42 : | |||
| 43 : | pazsan | 1.3 | warnings off |
| 44 : | |||
| 45 : | pazsan | 1.11 | [IFUNDEF] vocabulary include search-order.fs [THEN] |
| 46 : | [IFUNDEF] environment? include environ.fs [THEN] | ||
| 47 : | anton | 1.1 | include gray.fs |
| 48 : | |||
| 49 : | 100 constant max-effect \ number of things on one side of a stack effect | ||
| 50 : | 4096 constant batch-size \ no meaning, just make sure it's >0 | ||
| 51 : | 255 constant maxchar | ||
| 52 : | maxchar 1+ constant eof-char | ||
| 53 : | anton | 1.17 | #tab constant tab-char |
| 54 : | #lf constant nl-char | ||
| 55 : | anton | 1.1 | |
| 56 : | : read-whole-file ( c-addr1 file-id -- c-addr2 ) | ||
| 57 : | \ reads the contents of the file file-id puts it into memory at c-addr1 | ||
| 58 : | \ c-addr2 is the first address after the file block | ||
| 59 : | begin ( c-addr file-id ) | ||
| 60 : | 2dup batch-size swap read-file | ||
| 61 : | if | ||
| 62 : | pazsan | 1.8 | true abort" I/O error" |
| 63 : | anton | 1.1 | endif |
| 64 : | ( c-addr file-id actual-size ) rot over + -rot | ||
| 65 : | batch-size <> | ||
| 66 : | until | ||
| 67 : | drop ; | ||
| 68 : | |||
| 69 : | variable input \ pointer to next character to be parsed | ||
| 70 : | variable endinput \ pointer to the end of the input (the char after the last) | ||
| 71 : | anton | 1.17 | variable line \ line number of char pointed to by input |
| 72 : | 1 line ! | ||
| 73 : | 2variable filename \ filename of original input file | ||
| 74 : | 0 0 filename 2! | ||
| 75 : | variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? | ||
| 76 : | skipsynclines on | ||
| 77 : | \ !! unfortunately, this does not mean that they do not appear in the | ||
| 78 : | \ output. This could be changed by copying the input (skipping | ||
| 79 : | \ synclines) in ?nextchar | ||
| 80 : | anton | 1.1 | |
| 81 : | : start ( -- addr ) | ||
| 82 : | input @ ; | ||
| 83 : | |||
| 84 : | : end ( addr -- addr u ) | ||
| 85 : | input @ over - ; | ||
| 86 : | |||
| 87 : | variable output \ xt ( -- ) of output word | ||
| 88 : | |||
| 89 : | : printprim ( -- ) | ||
| 90 : | output @ execute ; | ||
| 91 : | |||
| 92 : | : field | ||
| 93 : | <builds-field ( n1 n2 -- n3 ) | ||
| 94 : | does> ( addr1 -- addr2 ) | ||
| 95 : | @ + ; | ||
| 96 : | |||
| 97 : | : const-field | ||
| 98 : | <builds-field ( n1 n2 -- n3 ) | ||
| 99 : | does> ( addr -- w ) | ||
| 100 : | @ + @ ; | ||
| 101 : | |||
| 102 : | struct | ||
| 103 : | 2 cells field item-name | ||
| 104 : | cell field item-d-offset | ||
| 105 : | cell field item-f-offset | ||
| 106 : | cell field item-type | ||
| 107 : | constant item-descr | ||
| 108 : | |||
| 109 : | 2variable forth-name | ||
| 110 : | 2variable wordset | ||
| 111 : | 2variable c-name | ||
| 112 : | 2variable doc | ||
| 113 : | 2variable c-code | ||
| 114 : | 2variable forth-code | ||
| 115 : | 2variable stack-string | ||
| 116 : | create effect-in max-effect item-descr * allot | ||
| 117 : | create effect-out max-effect item-descr * allot | ||
| 118 : | variable effect-in-end ( pointer ) | ||
| 119 : | variable effect-out-end ( pointer ) | ||
| 120 : | 2variable effect-in-size | ||
| 121 : | 2variable effect-out-size | ||
| 122 : | anton | 1.17 | variable c-line |
| 123 : | 2variable c-filename | ||
| 124 : | variable name-line | ||
| 125 : | 2variable name-filename | ||
| 126 : | 2variable last-name-filename | ||
| 127 : | anton | 1.1 | |
| 128 : | pazsan | 1.14 | variable primitive-number -10 primitive-number ! |
| 129 : | anton | 1.1 | |
| 130 : | \ for several reasons stack items of a word are stored in a wordlist | ||
| 131 : | \ since neither forget nor marker are implemented yet, we make a new | ||
| 132 : | \ wordlist for every word and store it in the variable items | ||
| 133 : | variable items | ||
| 134 : | |||
| 135 : | \ a few more set ops | ||
| 136 : | |||
| 137 : | : bit-equivalent ( w1 w2 -- w3 ) | ||
| 138 : | xor invert ; | ||
| 139 : | |||
| 140 : | : complement ( set1 -- set2 ) | ||
| 141 : | empty ['] bit-equivalent binary-set-operation ; | ||
| 142 : | |||
| 143 : | \ the parser | ||
| 144 : | |||
| 145 : | eof-char max-member \ the whole character set + EOF | ||
| 146 : | |||
| 147 : | : getinput ( -- n ) | ||
| 148 : | input @ | ||
| 149 : | dup endinput @ = | ||
| 150 : | if | ||
| 151 : | drop eof-char | ||
| 152 : | else | ||
| 153 : | c@ | ||
| 154 : | endif ; | ||
| 155 : | |||
| 156 : | :noname ( n -- ) | ||
| 157 : | dup bl > if | ||
| 158 : | emit space | ||
| 159 : | else | ||
| 160 : | . | ||
| 161 : | endif ; | ||
| 162 : | print-token ! | ||
| 163 : | |||
| 164 : | : testchar? ( set -- f ) | ||
| 165 : | getinput member? ; | ||
| 166 : | ' testchar? test-vector ! | ||
| 167 : | |||
| 168 : | anton | 1.17 | : checksyncline ( -- ) |
| 169 : | \ when input points to a newline, check if the next line is a | ||
| 170 : | \ sync line. If it is, perform the appropriate actions. | ||
| 171 : | input @ >r | ||
| 172 : | s" #line " r@ over compare 0<> if | ||
| 173 : | rdrop 1 line +! EXIT | ||
| 174 : | endif | ||
| 175 : | 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) | ||
| 176 : | dup c@ bl = if | ||
| 177 : | char+ dup c@ [char] " <> abort" sync line syntax" | ||
| 178 : | char+ dup 100 [char] " scan drop swap 2dup - filename 2! | ||
| 179 : | char+ | ||
| 180 : | endif | ||
| 181 : | dup c@ nl-char <> abort" sync line syntax" | ||
| 182 : | skipsynclines @ if | ||
| 183 : | dup char+ input ! | ||
| 184 : | endif | ||
| 185 : | drop ; | ||
| 186 : | |||
| 187 : | anton | 1.1 | : ?nextchar ( f -- ) |
| 188 : | anton | 1.17 | ?not? if |
| 189 : | ." syntax error" cr | ||
| 190 : | getinput . cr | ||
| 191 : | input @ endinput @ over - 100 min type cr | ||
| 192 : | abort | ||
| 193 : | endif | ||
| 194 : | input @ endinput @ <> if | ||
| 195 : | input @ c@ | ||
| 196 : | 1 input +! | ||
| 197 : | nl-char = if | ||
| 198 : | checksyncline | ||
| 199 : | endif | ||
| 200 : | endif ; | ||
| 201 : | anton | 1.1 | |
| 202 : | : charclass ( set "name" -- ) | ||
| 203 : | ['] ?nextchar terminal ; | ||
| 204 : | |||
| 205 : | : .. ( c1 c2 -- set ) | ||
| 206 : | ( creates a set that includes the characters c, c1<=c<=c2 ) | ||
| 207 : | empty copy-set | ||
| 208 : | swap 1+ rot do | ||
| 209 : | i over add-member | ||
| 210 : | loop ; | ||
| 211 : | |||
| 212 : | : ` ( -- terminal ) ( use: ` c ) | ||
| 213 : | ( creates anonymous terminal for the character c ) | ||
| 214 : | [compile] ascii singleton ['] ?nextchar make-terminal ; | ||
| 215 : | |||
| 216 : | char a char z .. char A char Z .. union char _ singleton union charclass letter | ||
| 217 : | char 0 char 9 .. charclass digit | ||
| 218 : | bl singleton charclass blank | ||
| 219 : | tab-char singleton charclass tab | ||
| 220 : | nl-char singleton eof-char over add-member complement charclass nonl | ||
| 221 : | nl-char singleton eof-char over add-member char : over add-member complement charclass nocolonnl | ||
| 222 : | bl 1+ maxchar .. charclass nowhite | ||
| 223 : | char " singleton eof-char over add-member complement charclass noquote | ||
| 224 : | nl-char singleton charclass nl | ||
| 225 : | eof-char singleton charclass eof | ||
| 226 : | |||
| 227 : | |||
| 228 : | (( letter (( letter || digit )) ** | ||
| 229 : | )) <- c-name ( -- ) | ||
| 230 : | |||
| 231 : | nowhite ++ | ||
| 232 : | <- name ( -- ) | ||
| 233 : | |||
| 234 : | (( ` \ nonl ** nl | ||
| 235 : | )) <- comment ( -- ) | ||
| 236 : | |||
| 237 : | anton | 1.17 | \ (( ` # ` l ` i ` n ` e blank |
| 238 : | \ {{ 0. start }} digit ++ {{ end >number abort" line number?" drop drop 1- line ! }} blank | ||
| 239 : | \ (( ` " {{ start }} noquote ++ {{ end filename 2! }} `" )) ?? | ||
| 240 : | \ nl | ||
| 241 : | \ )) <- syncline ( -- ) | ||
| 242 : | |||
| 243 : | \ (( nl syncline ?? )) <- nlsync | ||
| 244 : | |||
| 245 : | anton | 1.1 | (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }} |
| 246 : | ` - ` - blank ** | ||
| 247 : | {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }} | ||
| 248 : | )) <- stack-effect ( -- ) | ||
| 249 : | |||
| 250 : | (( {{ s" " doc 2! s" " forth-code 2! }} | ||
| 251 : | (( comment || nl )) ** | ||
| 252 : | anton | 1.17 | (( {{ line @ name-line ! filename 2@ name-filename 2! }} |
| 253 : | {{ start }} name {{ end 2dup forth-name 2! c-name 2! }} tab ++ | ||
| 254 : | anton | 1.1 | {{ start }} stack-effect {{ end stack-string 2! }} tab ++ |
| 255 : | {{ start }} name {{ end wordset 2! }} tab ** | ||
| 256 : | (( {{ start }} c-name {{ end c-name 2! }} )) ?? nl | ||
| 257 : | )) | ||
| 258 : | (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ?? | ||
| 259 : | anton | 1.17 | {{ line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl )) ** {{ end c-code 2! }} |
| 260 : | anton | 1.1 | (( ` : nl |
| 261 : | {{ start }} (( nonl ++ nl )) ++ {{ end forth-code 2! }} | ||
| 262 : | )) ?? | ||
| 263 : | (( nl || eof )) | ||
| 264 : | )) <- primitive ( -- ) | ||
| 265 : | |||
| 266 : | (( (( primitive {{ printprim }} )) ** eof )) | ||
| 267 : | parser primitives2something | ||
| 268 : | pazsan | 1.3 | warnings @ [IF] |
| 269 : | anton | 1.1 | .( parser generated ok ) cr |
| 270 : | pazsan | 1.3 | [THEN] |
| 271 : | anton | 1.1 | |
| 272 : | : primfilter ( file-id xt -- ) | ||
| 273 : | \ fileid is for the input file, xt ( -- ) is for the output word | ||
| 274 : | output ! | ||
| 275 : | here input ! | ||
| 276 : | here swap read-whole-file | ||
| 277 : | dup endinput ! | ||
| 278 : | here - allot | ||
| 279 : | pazsan | 1.2 | align |
| 280 : | anton | 1.17 | checksyncline |
| 281 : | anton | 1.1 | primitives2something ; |
| 282 : | |||
| 283 : | \ types | ||
| 284 : | |||
| 285 : | struct | ||
| 286 : | 2 cells field type-c-name | ||
| 287 : | cell const-field type-d-size | ||
| 288 : | cell const-field type-f-size | ||
| 289 : | cell const-field type-fetch-handler | ||
| 290 : | cell const-field type-store-handler | ||
| 291 : | constant type-description | ||
| 292 : | |||
| 293 : | : data-stack-access ( n1 n2 n3 -- ) | ||
| 294 : | \ n1 is the offset of the accessed item, n2, n3 are effect-*-size | ||
| 295 : | drop swap - 1- dup | ||
| 296 : | if | ||
| 297 : | pazsan | 1.2 | ." sp[" 0 .r ." ]" |
| 298 : | anton | 1.1 | else |
| 299 : | drop ." TOS" | ||
| 300 : | endif ; | ||
| 301 : | |||
| 302 : | : fp-stack-access ( n1 n2 n3 -- ) | ||
| 303 : | \ n1 is the offset of the accessed item, n2, n3 are effect-*-size | ||
| 304 : | nip swap - 1- dup | ||
| 305 : | if | ||
| 306 : | pazsan | 1.2 | ." fp[" 0 .r ." ]" |
| 307 : | anton | 1.1 | else |
| 308 : | drop ." FTOS" | ||
| 309 : | endif ; | ||
| 310 : | |||
| 311 : | : fetch-single ( item -- ) | ||
| 312 : | >r | ||
| 313 : | pazsan | 1.8 | r@ item-name 2@ type |
| 314 : | ." = (" | ||
| 315 : | anton | 1.1 | r@ item-type @ type-c-name 2@ type ." ) " |
| 316 : | r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr | ||
| 317 : | rdrop ; | ||
| 318 : | |||
| 319 : | : fetch-double ( item -- ) | ||
| 320 : | >r | ||
| 321 : | pazsan | 1.8 | r@ item-name 2@ type |
| 322 : | ." = ({Double_Store _d; _d.cells.low = " | ||
| 323 : | anton | 1.1 | r@ item-d-offset @ dup effect-in-size 2@ data-stack-access |
| 324 : | pazsan | 1.8 | ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access |
| 325 : | ." ; _d.dcell;});" cr | ||
| 326 : | anton | 1.1 | rdrop ; |
| 327 : | |||
| 328 : | : fetch-float ( item -- ) | ||
| 329 : | >r | ||
| 330 : | pazsan | 1.8 | r@ item-name 2@ type |
| 331 : | ." = " | ||
| 332 : | anton | 1.1 | \ ." (" r@ item-type @ type-c-name 2@ type ." ) " |
| 333 : | r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr | ||
| 334 : | rdrop ; | ||
| 335 : | |||
| 336 : | : d-same-as-in? ( item -- f ) | ||
| 337 : | \ f is true iff the offset of item is the same as on input | ||
| 338 : | >r | ||
| 339 : | r@ item-name 2@ items @ search-wordlist 0= | ||
| 340 : | pazsan | 1.8 | abort" bug" |
| 341 : | anton | 1.1 | execute @ |
| 342 : | dup r@ = | ||
| 343 : | if \ item first appeared in output | ||
| 344 : | drop false | ||
| 345 : | else | ||
| 346 : | item-d-offset @ r@ item-d-offset @ = | ||
| 347 : | endif | ||
| 348 : | rdrop ; | ||
| 349 : | |||
| 350 : | : is-in-tos? ( item -- f ) | ||
| 351 : | \ true if item has the same offset as the input TOS | ||
| 352 : | item-d-offset @ 1+ effect-in-size 2@ drop = ; | ||
| 353 : | |||
| 354 : | : really-store-single ( item -- ) | ||
| 355 : | >r | ||
| 356 : | r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)" | ||
| 357 : | r@ item-name 2@ type ." ;" | ||
| 358 : | rdrop ; | ||
| 359 : | |||
| 360 : | : store-single ( item -- ) | ||
| 361 : | >r | ||
| 362 : | r@ d-same-as-in? | ||
| 363 : | if | ||
| 364 : | r@ is-in-tos? | ||
| 365 : | if | ||
| 366 : | ." IF_TOS(" r@ really-store-single ." );" cr | ||
| 367 : | endif | ||
| 368 : | else | ||
| 369 : | r@ really-store-single cr | ||
| 370 : | endif | ||
| 371 : | rdrop ; | ||
| 372 : | |||
| 373 : | : store-double ( item -- ) | ||
| 374 : | \ !! store optimization is not performed, because it is not yet needed | ||
| 375 : | >r | ||
| 376 : | ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; " | ||
| 377 : | r@ item-d-offset @ dup effect-out-size 2@ data-stack-access | ||
| 378 : | pazsan | 1.2 | ." = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access |
| 379 : | ." = _d.cells.high;}" cr | ||
| 380 : | anton | 1.1 | rdrop ; |
| 381 : | |||
| 382 : | : f-same-as-in? ( item -- f ) | ||
| 383 : | \ f is true iff the offset of item is the same as on input | ||
| 384 : | >r | ||
| 385 : | r@ item-name 2@ items @ search-wordlist 0= | ||
| 386 : | pazsan | 1.8 | abort" bug" |
| 387 : | anton | 1.1 | execute @ |
| 388 : | dup r@ = | ||
| 389 : | if \ item first appeared in output | ||
| 390 : | drop false | ||
| 391 : | else | ||
| 392 : | item-f-offset @ r@ item-f-offset @ = | ||
| 393 : | endif | ||
| 394 : | rdrop ; | ||
| 395 : | |||
| 396 : | : is-in-ftos? ( item -- f ) | ||
| 397 : | \ true if item has the same offset as the input TOS | ||
| 398 : | item-f-offset @ 1+ effect-in-size 2@ nip = ; | ||
| 399 : | |||
| 400 : | : really-store-float ( item -- ) | ||
| 401 : | >r | ||
| 402 : | r@ item-f-offset @ effect-out-size 2@ fp-stack-access ." = " | ||
| 403 : | r@ item-name 2@ type ." ;" | ||
| 404 : | rdrop ; | ||
| 405 : | |||
| 406 : | : store-float ( item -- ) | ||
| 407 : | >r | ||
| 408 : | r@ f-same-as-in? | ||
| 409 : | if | ||
| 410 : | r@ is-in-ftos? | ||
| 411 : | if | ||
| 412 : | ." IF_FTOS(" r@ really-store-float ." );" cr | ||
| 413 : | endif | ||
| 414 : | else | ||
| 415 : | r@ really-store-float cr | ||
| 416 : | endif | ||
| 417 : | rdrop ; | ||
| 418 : | |||
| 419 : | anton | 1.10 | : single-type ( -- xt1 xt2 n1 n2 ) |
| 420 : | anton | 1.1 | ['] fetch-single ['] store-single 1 0 ; |
| 421 : | |||
| 422 : | anton | 1.10 | : double-type ( -- xt1 xt2 n1 n2 ) |
| 423 : | anton | 1.1 | ['] fetch-double ['] store-double 2 0 ; |
| 424 : | |||
| 425 : | anton | 1.10 | : float-type ( -- xt1 xt2 n1 n2 ) |
| 426 : | anton | 1.1 | ['] fetch-float ['] store-float 0 1 ; |
| 427 : | |||
| 428 : | : s, ( addr u -- ) | ||
| 429 : | \ allocate a string | ||
| 430 : | here swap dup allot move ; | ||
| 431 : | |||
| 432 : | : starts-with ( addr u xt1 xt2 n1 n2 "prefix" -- ) | ||
| 433 : | \ describes a type | ||
| 434 : | \ addr u specifies the C type name | ||
| 435 : | \ n1 is the size of the type on the data stack | ||
| 436 : | \ n2 is the size of the type on the FP stack | ||
| 437 : | \ stack effect entries of the type start with prefix | ||
| 438 : | >r >r >r >r | ||
| 439 : | dup >r here >r s, | ||
| 440 : | create | ||
| 441 : | r> r> 2, | ||
| 442 : | r> r> r> , r> , swap , , ; | ||
| 443 : | |||
| 444 : | wordlist constant types | ||
| 445 : | get-current | ||
| 446 : | types set-current | ||
| 447 : | |||
| 448 : | s" Bool" single-type starts-with f | ||
| 449 : | s" Char" single-type starts-with c | ||
| 450 : | s" Cell" single-type starts-with n | ||
| 451 : | s" Cell" single-type starts-with w | ||
| 452 : | s" UCell" single-type starts-with u | ||
| 453 : | s" DCell" double-type starts-with d | ||
| 454 : | s" UDCell" double-type starts-with ud | ||
| 455 : | s" Float" float-type starts-with r | ||
| 456 : | s" Cell *" single-type starts-with a_ | ||
| 457 : | s" Char *" single-type starts-with c_ | ||
| 458 : | s" Float *" single-type starts-with f_ | ||
| 459 : | s" DFloat *" single-type starts-with df_ | ||
| 460 : | s" SFloat *" single-type starts-with sf_ | ||
| 461 : | s" Xt" single-type starts-with xt | ||
| 462 : | s" WID" single-type starts-with wid | ||
| 463 : | s" F83Name *" single-type starts-with f83name | ||
| 464 : | |||
| 465 : | set-current | ||
| 466 : | |||
| 467 : | : get-type ( addr1 u1 -- type-descr ) | ||
| 468 : | \ get the type of the name in addr1 u1 | ||
| 469 : | \ type-descr is a pointer to a type-descriptor | ||
| 470 : | 0 swap ?do | ||
| 471 : | dup i types search-wordlist | ||
| 472 : | if \ ok, we have the type ( addr1 xt ) | ||
| 473 : | execute nip | ||
| 474 : | UNLOOP EXIT | ||
| 475 : | endif | ||
| 476 : | anton | 1.9 | -1 s+loop |
| 477 : | anton | 1.1 | \ we did not find a type, abort |
| 478 : | pazsan | 1.8 | true abort" unknown type prefix" ; |
| 479 : | anton | 1.1 | |
| 480 : | : declare ( addr "name" -- ) | ||
| 481 : | \ remember that there is a stack item at addr called name | ||
| 482 : | create , ; | ||
| 483 : | |||
| 484 : | : declaration ( item -- ) | ||
| 485 : | dup item-name 2@ items @ search-wordlist | ||
| 486 : | if \ already declared ( item xt ) | ||
| 487 : | execute @ item-type @ swap item-type ! | ||
| 488 : | else ( addr ) | ||
| 489 : | dup item-name 2@ nextname dup declare ( addr ) | ||
| 490 : | dup >r item-name 2@ 2dup get-type ( addr1 u type-descr ) | ||
| 491 : | dup r> item-type ! ( addr1 u type-descr ) | ||
| 492 : | type-c-name 2@ type space type ." ;" cr | ||
| 493 : | endif ; | ||
| 494 : | |||
| 495 : | : declaration-list ( addr1 addr2 -- ) | ||
| 496 : | swap ?do | ||
| 497 : | i declaration | ||
| 498 : | item-descr +loop ; | ||
| 499 : | |||
| 500 : | pazsan | 1.8 | : fetch ( addr -- ) |
| 501 : | dup item-type @ type-fetch-handler execute ; | ||
| 502 : | |||
| 503 : | anton | 1.1 | : declarations ( -- ) |
| 504 : | wordlist dup items ! set-current | ||
| 505 : | effect-in effect-in-end @ declaration-list | ||
| 506 : | effect-out effect-out-end @ declaration-list ; | ||
| 507 : | |||
| 508 : | \ offset computation | ||
| 509 : | \ the leftmost (i.e. deepest) item has offset 0 | ||
| 510 : | \ the rightmost item has the highest offset | ||
| 511 : | |||
| 512 : | : compute-offset ( n1 n2 item -- n3 n4 ) | ||
| 513 : | \ n1, n3 are data-stack-offsets | ||
| 514 : | \ n2, n4 are the fp-stack-offsets | ||
| 515 : | >r | ||
| 516 : | swap dup r@ item-d-offset ! | ||
| 517 : | r@ item-type @ type-d-size + | ||
| 518 : | swap dup r@ item-f-offset ! | ||
| 519 : | r@ item-type @ type-f-size + | ||
| 520 : | rdrop ; | ||
| 521 : | |||
| 522 : | : compute-list ( addr1 addr2 -- n1 n2 ) | ||
| 523 : | \ n1, n2 are the final offsets | ||
| 524 : | 0 0 2swap swap ?do | ||
| 525 : | i compute-offset | ||
| 526 : | item-descr +loop ; | ||
| 527 : | |||
| 528 : | : compute-offsets ( -- ) | ||
| 529 : | effect-in effect-in-end @ compute-list effect-in-size 2! | ||
| 530 : | effect-out effect-out-end @ compute-list effect-out-size 2! ; | ||
| 531 : | |||
| 532 : | : flush-tos ( -- ) | ||
| 533 : | effect-in-size 2@ effect-out-size 2@ | ||
| 534 : | 0<> rot 0= and | ||
| 535 : | if | ||
| 536 : | anton | 1.13 | ." IF_FTOS(fp[0] = FTOS);" cr |
| 537 : | endif | ||
| 538 : | anton | 1.1 | 0<> swap 0= and |
| 539 : | if | ||
| 540 : | anton | 1.13 | ." IF_TOS(sp[0] = TOS);" cr |
| 541 : | endif ; | ||
| 542 : | anton | 1.1 | |
| 543 : | : fill-tos ( -- ) | ||
| 544 : | effect-in-size 2@ effect-out-size 2@ | ||
| 545 : | 0= rot 0<> and | ||
| 546 : | if | ||
| 547 : | ." IF_FTOS(FTOS = fp[0]);" cr | ||
| 548 : | endif | ||
| 549 : | 0= swap 0<> and | ||
| 550 : | if | ||
| 551 : | ." IF_TOS(TOS = sp[0]);" cr | ||
| 552 : | endif ; | ||
| 553 : | |||
| 554 : | : fetches ( -- ) | ||
| 555 : | effect-in-end @ effect-in ?do | ||
| 556 : | i fetch | ||
| 557 : | item-descr +loop ; | ||
| 558 : | |||
| 559 : | : stack-pointer-updates ( -- ) | ||
| 560 : | pazsan | 1.8 | \ we need not check if an update is a noop; gcc does this for us |
| 561 : | anton | 1.1 | effect-in-size 2@ |
| 562 : | effect-out-size 2@ | ||
| 563 : | rot swap - ( d-in d-out f-diff ) | ||
| 564 : | rot rot - ( f-diff d-diff ) | ||
| 565 : | pazsan | 1.2 | ?dup IF ." sp += " 0 .r ." ;" cr THEN |
| 566 : | ?dup IF ." fp += " 0 .r ." ;" cr THEN ; | ||
| 567 : | anton | 1.1 | |
| 568 : | : store ( item -- ) | ||
| 569 : | \ f is true if the item should be stored | ||
| 570 : | \ f is false if the store is probably not necessary | ||
| 571 : | dup item-type @ type-store-handler execute ; | ||
| 572 : | |||
| 573 : | : stores ( -- ) | ||
| 574 : | effect-out-end @ effect-out ?do | ||
| 575 : | i store | ||
| 576 : | item-descr +loop ; | ||
| 577 : | |||
| 578 : | pazsan | 1.8 | : .stack-list ( start end -- ) |
| 579 : | swap ?do | ||
| 580 : | i item-name 2@ type space | ||
| 581 : | item-descr +loop ; | ||
| 582 : | |||
| 583 : | anton | 1.1 | : output-c ( -- ) |
| 584 : | pazsan | 1.2 | ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr |
| 585 : | anton | 1.1 | ." /* " doc 2@ type ." */" cr |
| 586 : | anton | 1.13 | ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging |
| 587 : | anton | 1.1 | ." {" cr |
| 588 : | ." DEF_CA" cr | ||
| 589 : | declarations | ||
| 590 : | compute-offsets \ for everything else | ||
| 591 : | anton | 1.13 | ." NEXT_P0;" cr |
| 592 : | flush-tos | ||
| 593 : | anton | 1.1 | fetches |
| 594 : | anton | 1.13 | stack-pointer-updates |
| 595 : | anton | 1.1 | ." {" cr |
| 596 : | anton | 1.17 | ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr |
| 597 : | anton | 1.1 | c-code 2@ type |
| 598 : | ." }" cr | ||
| 599 : | ." NEXT_P1;" cr | ||
| 600 : | stores | ||
| 601 : | fill-tos | ||
| 602 : | anton | 1.9 | ." NEXT_P2;" cr |
| 603 : | anton | 1.1 | ." }" cr |
| 604 : | cr | ||
| 605 : | ; | ||
| 606 : | |||
| 607 : | : output-label ( -- ) | ||
| 608 : | ." &&I_" c-name 2@ type ." ," cr ; | ||
| 609 : | |||
| 610 : | : output-alias ( -- ) | ||
| 611 : | primitive-number @ . ." alias " forth-name 2@ type cr | ||
| 612 : | -1 primitive-number +! ; | ||
| 613 : | |||
| 614 : | pazsan | 1.8 | : output-forth ( -- ) |
| 615 : | forth-code @ 0= | ||
| 616 : | IF output-alias | ||
| 617 : | ELSE ." : " forth-name 2@ type ." ( " | ||
| 618 : | effect-in effect-in-end @ .stack-list ." -- " | ||
| 619 : | effect-out effect-out-end @ .stack-list ." )" cr | ||
| 620 : | forth-code 2@ type cr | ||
| 621 : | -1 primitive-number +! | ||
| 622 : | anton | 1.10 | THEN ; |
| 623 : | |||
| 624 : | anton | 1.17 | : output-tag-file ( -- ) |
| 625 : | name-filename 2@ last-name-filename 2@ compare if | ||
| 626 : | name-filename 2@ last-name-filename 2! | ||
| 627 : | #ff emit cr | ||
| 628 : | name-filename 2@ type | ||
| 629 : | ." ,0" cr | ||
| 630 : | endif ; | ||
| 631 : | |||
| 632 : | : output-tag ( -- ) | ||
| 633 : | output-tag-file | ||
| 634 : | forth-name 2@ 1+ type | ||
| 635 : | 127 emit | ||
| 636 : | space forth-name 2@ type space | ||
| 637 : | 1 emit | ||
| 638 : | name-line @ 0 .r | ||
| 639 : | ." ,0" cr ; | ||
| 640 : | |||
| 641 : | anton | 1.10 | [IFDEF] documentation |
| 642 : | : register-doc ( -- ) | ||
| 643 : | get-current documentation set-current | ||
| 644 : | forth-name 2@ nextname create | ||
| 645 : | forth-name 2@ 2, | ||
| 646 : | anton | 1.15 | stack-string 2@ condition-stack-effect 2, |
| 647 : | anton | 1.10 | wordset 2@ 2, |
| 648 : | anton | 1.15 | c-name 2@ condition-pronounciation 2, |
| 649 : | anton | 1.10 | doc 2@ 2, |
| 650 : | set-current ; | ||
| 651 : | [THEN] | ||
| 652 : | pazsan | 1.8 | |
| 653 : | anton | 1.1 | : process-file ( addr u xt -- ) |
| 654 : | anton | 1.17 | >r |
| 655 : | 2dup filename 2! | ||
| 656 : | r/o open-file abort" cannot open file" | ||
| 657 : | warnings @ if | ||
| 658 : | ." ------------ CUT HERE -------------" cr endif | ||
| 659 : | r> primfilter ; | ||
| 660 : | pazsan | 1.5 |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |