Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.16 | \ converts primitives to, e.g., C code |
| 2 : | |||
| 3 : | anton | 1.47 | \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. |
| 4 : | anton | 1.16 | |
| 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 : | anton | 1.48 | \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
| 20 : | anton | 1.16 | |
| 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 : | jwilke | 1.39 | [IFUNDEF] vocabulary \ we are executed just with kernel image |
| 46 : | \ load the rest that is needed | ||
| 47 : | \ (require fails because this file is needed from a | ||
| 48 : | \ different directory with the wordlibraries) | ||
| 49 : | include ./search.fs | ||
| 50 : | include ./extend.fs | ||
| 51 : | anton | 1.40 | [THEN] |
| 52 : | |||
| 53 : | [IFUNDEF] environment? | ||
| 54 : | jwilke | 1.39 | include ./environ.fs |
| 55 : | [THEN] | ||
| 56 : | pazsan | 1.25 | |
| 57 : | anton | 1.49 | : struct% struct ; \ struct is redefined in gray |
| 58 : | |||
| 59 : | jwilke | 1.39 | include ./gray.fs |
| 60 : | anton | 1.1 | |
| 61 : | 100 constant max-effect \ number of things on one side of a stack effect | ||
| 62 : | 255 constant maxchar | ||
| 63 : | maxchar 1+ constant eof-char | ||
| 64 : | anton | 1.17 | #tab constant tab-char |
| 65 : | #lf constant nl-char | ||
| 66 : | anton | 1.1 | |
| 67 : | anton | 1.18 | variable rawinput \ pointer to next character to be scanned |
| 68 : | variable endrawinput \ pointer to the end of the input (the char after the last) | ||
| 69 : | variable cookedinput \ pointer to the next char to be parsed | ||
| 70 : | anton | 1.17 | variable line \ line number of char pointed to by input |
| 71 : | anton | 1.65 | variable line-start \ pointer to start of current line (for error messages) |
| 72 : | 0 line ! | ||
| 73 : | anton | 1.17 | 2variable filename \ filename of original input file |
| 74 : | 0 0 filename 2! | ||
| 75 : | pazsan | 1.25 | 2variable f-comment |
| 76 : | 0 0 f-comment 2! | ||
| 77 : | anton | 1.17 | variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
| 78 : | skipsynclines on | ||
| 79 : | anton | 1.1 | |
| 80 : | : start ( -- addr ) | ||
| 81 : | anton | 1.18 | cookedinput @ ; |
| 82 : | anton | 1.1 | |
| 83 : | : end ( addr -- addr u ) | ||
| 84 : | anton | 1.18 | cookedinput @ over - ; |
| 85 : | anton | 1.1 | |
| 86 : | anton | 1.63 | : quote ( -- ) |
| 87 : | [char] " emit ; | ||
| 88 : | |||
| 89 : | anton | 1.1 | variable output \ xt ( -- ) of output word |
| 90 : | |||
| 91 : | : printprim ( -- ) | ||
| 92 : | output @ execute ; | ||
| 93 : | |||
| 94 : | anton | 1.49 | struct% |
| 95 : | cell% 2* field stack-pointer \ stackpointer name | ||
| 96 : | cell% 2* field stack-cast \ cast string for assignments to stack elements | ||
| 97 : | anton | 1.53 | cell% field stack-in-index-xt \ ( in-size item -- in-index ) |
| 98 : | anton | 1.49 | cell% field stack-in \ number of stack items in effect in |
| 99 : | cell% field stack-out \ number of stack items in effect out | ||
| 100 : | end-struct stack% | ||
| 101 : | |||
| 102 : | anton | 1.53 | struct% |
| 103 : | cell% 2* field item-name \ name, excluding stack prefixes | ||
| 104 : | cell% field item-stack \ descriptor for the stack used, 0 is default | ||
| 105 : | cell% field item-type \ descriptor for the item type | ||
| 106 : | cell% field item-offset \ offset in stack items, 0 for the deepest element | ||
| 107 : | anton | 1.66 | cell% field item-first \ true if this is the first occurence of the item |
| 108 : | anton | 1.53 | end-struct item% |
| 109 : | |||
| 110 : | struct% | ||
| 111 : | cell% 2* field type-c-name | ||
| 112 : | cell% field type-stack \ default stack | ||
| 113 : | cell% field type-size \ size of type in stack items | ||
| 114 : | cell% field type-fetch \ xt of fetch code generator ( item -- ) | ||
| 115 : | cell% field type-store \ xt of store code generator ( item -- ) | ||
| 116 : | end-struct type% | ||
| 117 : | |||
| 118 : | : stack-in-index ( in-size item -- in-index ) | ||
| 119 : | item-offset @ - 1- ; | ||
| 120 : | |||
| 121 : | : inst-in-index ( in-size item -- in-index ) | ||
| 122 : | nip dup item-offset @ swap item-type @ type-size @ + 1- ; | ||
| 123 : | |||
| 124 : | anton | 1.49 | : make-stack ( addr-ptr u1 addr-cast u2 "stack-name" -- ) |
| 125 : | create stack% %allot >r | ||
| 126 : | save-mem r@ stack-cast 2! | ||
| 127 : | anton | 1.53 | save-mem r@ stack-pointer 2! |
| 128 : | ['] stack-in-index r> stack-in-index-xt ! ; | ||
| 129 : | anton | 1.49 | |
| 130 : | s" sp" save-mem s" (Cell)" make-stack data-stack | ||
| 131 : | s" fp" save-mem s" " make-stack fp-stack | ||
| 132 : | anton | 1.51 | s" rp" save-mem s" (Cell)" make-stack return-stack |
| 133 : | anton | 1.62 | s" IP" save-mem s" error don't use # on results" make-stack inst-stream |
| 134 : | anton | 1.53 | ' inst-in-index inst-stream stack-in-index-xt ! |
| 135 : | anton | 1.49 | \ !! initialize stack-in and stack-out |
| 136 : | |||
| 137 : | \ stack items | ||
| 138 : | |||
| 139 : | : init-item ( addr u addr1 -- ) | ||
| 140 : | \ initialize item at addr1 with name addr u | ||
| 141 : | \ !! remove stack prefix | ||
| 142 : | dup item% %size erase | ||
| 143 : | item-name 2! ; | ||
| 144 : | |||
| 145 : | anton | 1.64 | : map-items { addr end xt -- } |
| 146 : | \ perform xt for all items in array addr...end | ||
| 147 : | end addr ?do | ||
| 148 : | i xt execute | ||
| 149 : | item% %size +loop ; | ||
| 150 : | |||
| 151 : | anton | 1.49 | \ various variables for storing stuff of one primitive |
| 152 : | anton | 1.1 | |
| 153 : | 2variable forth-name | ||
| 154 : | 2variable wordset | ||
| 155 : | 2variable c-name | ||
| 156 : | 2variable doc | ||
| 157 : | 2variable c-code | ||
| 158 : | 2variable forth-code | ||
| 159 : | 2variable stack-string | ||
| 160 : | anton | 1.49 | create effect-in max-effect item% %size * allot |
| 161 : | create effect-out max-effect item% %size * allot | ||
| 162 : | anton | 1.1 | variable effect-in-end ( pointer ) |
| 163 : | variable effect-out-end ( pointer ) | ||
| 164 : | anton | 1.17 | variable c-line |
| 165 : | 2variable c-filename | ||
| 166 : | variable name-line | ||
| 167 : | 2variable name-filename | ||
| 168 : | 2variable last-name-filename | ||
| 169 : | anton | 1.1 | |
| 170 : | pazsan | 1.30 | Variable function-number 0 function-number ! |
| 171 : | anton | 1.1 | |
| 172 : | \ for several reasons stack items of a word are stored in a wordlist | ||
| 173 : | \ since neither forget nor marker are implemented yet, we make a new | ||
| 174 : | \ wordlist for every word and store it in the variable items | ||
| 175 : | variable items | ||
| 176 : | |||
| 177 : | \ a few more set ops | ||
| 178 : | |||
| 179 : | : bit-equivalent ( w1 w2 -- w3 ) | ||
| 180 : | xor invert ; | ||
| 181 : | |||
| 182 : | : complement ( set1 -- set2 ) | ||
| 183 : | empty ['] bit-equivalent binary-set-operation ; | ||
| 184 : | |||
| 185 : | \ types | ||
| 186 : | |||
| 187 : | anton | 1.49 | : stack-access ( n stack -- ) |
| 188 : | \ print a stack access at index n of stack | ||
| 189 : | stack-pointer 2@ type | ||
| 190 : | dup | ||
| 191 : | if | ||
| 192 : | ." [" 0 .r ." ]" | ||
| 193 : | else | ||
| 194 : | drop ." TOS" | ||
| 195 : | endif ; | ||
| 196 : | anton | 1.1 | |
| 197 : | anton | 1.53 | : item-in-index { item -- n } |
| 198 : | anton | 1.49 | \ n is the index of item (in the in-effect) |
| 199 : | anton | 1.53 | item item-stack @ dup >r stack-in @ ( in-size r:stack ) |
| 200 : | item r> stack-in-index-xt @ execute ; | ||
| 201 : | anton | 1.1 | |
| 202 : | : fetch-single ( item -- ) | ||
| 203 : | anton | 1.49 | \ fetch a single stack item from its stack |
| 204 : | anton | 1.1 | >r |
| 205 : | pazsan | 1.8 | r@ item-name 2@ type |
| 206 : | ." = (" | ||
| 207 : | anton | 1.1 | r@ item-type @ type-c-name 2@ type ." ) " |
| 208 : | anton | 1.49 | r@ item-in-index r@ item-stack @ stack-access |
| 209 : | ." ;" cr | ||
| 210 : | anton | 1.1 | rdrop ; |
| 211 : | |||
| 212 : | : fetch-double ( item -- ) | ||
| 213 : | anton | 1.49 | \ fetch a double stack item from its stack |
| 214 : | anton | 1.1 | >r |
| 215 : | anton | 1.20 | ." FETCH_DCELL(" |
| 216 : | r@ item-name 2@ type ." , " | ||
| 217 : | anton | 1.61 | r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access |
| 218 : | ." , " -1 under+ ." (Cell)" stack-access | ||
| 219 : | anton | 1.20 | ." );" cr |
| 220 : | anton | 1.1 | rdrop ; |
| 221 : | |||
| 222 : | anton | 1.49 | : same-as-in? ( item -- f ) |
| 223 : | \ f is true iff the offset and stack of item is the same as on input | ||
| 224 : | anton | 1.1 | >r |
| 225 : | r@ item-name 2@ items @ search-wordlist 0= | ||
| 226 : | pazsan | 1.8 | abort" bug" |
| 227 : | anton | 1.1 | execute @ |
| 228 : | dup r@ = | ||
| 229 : | if \ item first appeared in output | ||
| 230 : | drop false | ||
| 231 : | else | ||
| 232 : | anton | 1.49 | dup item-stack @ r@ item-stack @ = |
| 233 : | swap item-offset @ r@ item-offset @ = and | ||
| 234 : | anton | 1.1 | endif |
| 235 : | rdrop ; | ||
| 236 : | |||
| 237 : | anton | 1.49 | : item-out-index ( item -- n ) |
| 238 : | \ n is the index of item (in the in-effect) | ||
| 239 : | >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ; | ||
| 240 : | pazsan | 1.31 | |
| 241 : | anton | 1.1 | : really-store-single ( item -- ) |
| 242 : | >r | ||
| 243 : | anton | 1.49 | r@ item-out-index r@ item-stack @ stack-access ." = " |
| 244 : | r@ item-stack @ stack-cast 2@ type | ||
| 245 : | anton | 1.1 | r@ item-name 2@ type ." ;" |
| 246 : | rdrop ; | ||
| 247 : | |||
| 248 : | : store-single ( item -- ) | ||
| 249 : | >r | ||
| 250 : | anton | 1.49 | r@ same-as-in? |
| 251 : | anton | 1.1 | if |
| 252 : | anton | 1.49 | r@ item-in-index 0= r@ item-out-index 0= xor |
| 253 : | anton | 1.1 | if |
| 254 : | anton | 1.49 | ." IF_" r@ item-stack @ stack-pointer 2@ type |
| 255 : | ." TOS(" r@ really-store-single ." );" cr | ||
| 256 : | anton | 1.1 | endif |
| 257 : | else | ||
| 258 : | r@ really-store-single cr | ||
| 259 : | endif | ||
| 260 : | rdrop ; | ||
| 261 : | |||
| 262 : | : store-double ( item -- ) | ||
| 263 : | \ !! store optimization is not performed, because it is not yet needed | ||
| 264 : | >r | ||
| 265 : | anton | 1.20 | ." STORE_DCELL(" r@ item-name 2@ type ." , " |
| 266 : | anton | 1.49 | r@ item-out-index r@ item-stack @ 2dup stack-access |
| 267 : | ." , " -1 under+ stack-access | ||
| 268 : | anton | 1.20 | ." );" cr |
| 269 : | anton | 1.1 | rdrop ; |
| 270 : | |||
| 271 : | anton | 1.54 | : single ( -- xt1 xt2 n ) |
| 272 : | ['] fetch-single ['] store-single 1 ; | ||
| 273 : | anton | 1.1 | |
| 274 : | anton | 1.54 | : double ( -- xt1 xt2 n ) |
| 275 : | ['] fetch-double ['] store-double 2 ; | ||
| 276 : | anton | 1.1 | |
| 277 : | : s, ( addr u -- ) | ||
| 278 : | \ allocate a string | ||
| 279 : | here swap dup allot move ; | ||
| 280 : | |||
| 281 : | anton | 1.50 | wordlist constant prefixes |
| 282 : | |||
| 283 : | : declare ( addr "name" -- ) | ||
| 284 : | \ remember that there is a stack item at addr called name | ||
| 285 : | create , ; | ||
| 286 : | |||
| 287 : | : !default ( w addr -- ) | ||
| 288 : | dup @ if | ||
| 289 : | 2drop \ leave nonzero alone | ||
| 290 : | else | ||
| 291 : | ! | ||
| 292 : | endif ; | ||
| 293 : | |||
| 294 : | : create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- ) | ||
| 295 : | anton | 1.49 | \ describes a type |
| 296 : | \ addr u specifies the C type name | ||
| 297 : | \ stack effect entries of the type start with prefix | ||
| 298 : | create type% %allot >r | ||
| 299 : | addr u save-mem r@ type-c-name 2! | ||
| 300 : | xt1 r@ type-fetch ! | ||
| 301 : | xt2 r@ type-store ! | ||
| 302 : | n r@ type-size ! | ||
| 303 : | stack r@ type-stack ! | ||
| 304 : | rdrop ; | ||
| 305 : | anton | 1.1 | |
| 306 : | anton | 1.54 | : type-prefix ( xt1 xt2 n stack "prefix" -- ) |
| 307 : | anton | 1.50 | create-type |
| 308 : | does> ( item -- ) | ||
| 309 : | \ initialize item | ||
| 310 : | { item typ } | ||
| 311 : | typ item item-type ! | ||
| 312 : | typ type-stack @ item item-stack !default | ||
| 313 : | item item-name 2@ items @ search-wordlist 0= if \ new name | ||
| 314 : | anton | 1.66 | item item-name 2@ nextname item declare |
| 315 : | item item-first on | ||
| 316 : | \ typ type-c-name 2@ type space type ." ;" cr | ||
| 317 : | anton | 1.50 | else |
| 318 : | drop | ||
| 319 : | anton | 1.66 | item item-first off |
| 320 : | anton | 1.50 | endif ; |
| 321 : | |||
| 322 : | : execute-prefix ( item addr1 u1 -- ) | ||
| 323 : | \ execute the word ( item -- ) associated with the longest prefix | ||
| 324 : | \ of addr1 u1 | ||
| 325 : | 0 swap ?do | ||
| 326 : | dup i prefixes search-wordlist | ||
| 327 : | if \ ok, we have the type ( item addr1 xt ) | ||
| 328 : | nip execute | ||
| 329 : | UNLOOP EXIT | ||
| 330 : | endif | ||
| 331 : | -1 s+loop | ||
| 332 : | \ we did not find a type, abort | ||
| 333 : | true abort" unknown prefix" ; | ||
| 334 : | anton | 1.1 | |
| 335 : | : declaration ( item -- ) | ||
| 336 : | anton | 1.50 | dup item-name 2@ execute-prefix ; |
| 337 : | anton | 1.1 | |
| 338 : | anton | 1.64 | : declaration-list ( addr1 addr2 -- ) |
| 339 : | ['] declaration map-items ; | ||
| 340 : | |||
| 341 : | : declarations ( -- ) | ||
| 342 : | wordlist dup items ! set-current | ||
| 343 : | effect-in effect-in-end @ declaration-list | ||
| 344 : | effect-out effect-out-end @ declaration-list ; | ||
| 345 : | |||
| 346 : | anton | 1.66 | : print-declaration { item -- } |
| 347 : | item item-first @ if | ||
| 348 : | item item-type @ type-c-name 2@ type space | ||
| 349 : | item item-name 2@ type ." ;" cr | ||
| 350 : | endif ; | ||
| 351 : | |||
| 352 : | : print-declarations ( -- ) | ||
| 353 : | effect-in effect-in-end @ ['] print-declaration map-items | ||
| 354 : | effect-out effect-out-end @ ['] print-declaration map-items ; | ||
| 355 : | |||
| 356 : | anton | 1.51 | : stack-prefix ( stack "prefix" -- ) |
| 357 : | name tuck nextname create ( stack length ) 2, | ||
| 358 : | does> ( item -- ) | ||
| 359 : | 2@ { item stack prefix-length } | ||
| 360 : | item item-name 2@ prefix-length /string item item-name 2! | ||
| 361 : | stack item item-stack ! | ||
| 362 : | item declaration ; | ||
| 363 : | anton | 1.1 | |
| 364 : | \ offset computation | ||
| 365 : | \ the leftmost (i.e. deepest) item has offset 0 | ||
| 366 : | \ the rightmost item has the highest offset | ||
| 367 : | |||
| 368 : | anton | 1.49 | : compute-offset { item xt -- } |
| 369 : | \ xt specifies in/out; update stack-in/out and set item-offset | ||
| 370 : | item item-type @ type-size @ | ||
| 371 : | item item-stack @ xt execute dup @ >r +! | ||
| 372 : | r> item item-offset ! ; | ||
| 373 : | |||
| 374 : | anton | 1.64 | : compute-offset-in ( addr1 addr2 -- ) |
| 375 : | ['] stack-in compute-offset ; | ||
| 376 : | |||
| 377 : | : compute-offset-out ( addr1 addr2 -- ) | ||
| 378 : | ['] stack-out compute-offset ; | ||
| 379 : | anton | 1.49 | |
| 380 : | : clear-stack { -- } | ||
| 381 : | dup stack-in off stack-out off ; | ||
| 382 : | anton | 1.1 | |
| 383 : | : compute-offsets ( -- ) | ||
| 384 : | anton | 1.51 | data-stack clear-stack fp-stack clear-stack return-stack clear-stack |
| 385 : | anton | 1.53 | inst-stream clear-stack |
| 386 : | anton | 1.64 | effect-in effect-in-end @ ['] compute-offset-in map-items |
| 387 : | effect-out effect-out-end @ ['] compute-offset-out map-items | ||
| 388 : | anton | 1.53 | inst-stream stack-out @ 0<> abort" # can only be on the input side" ; |
| 389 : | anton | 1.49 | |
| 390 : | : flush-a-tos { stack -- } | ||
| 391 : | stack stack-out @ 0<> stack stack-in @ 0= and | ||
| 392 : | if | ||
| 393 : | ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" | ||
| 394 : | 2dup type ." [0] = " type ." TOS);" cr | ||
| 395 : | endif ; | ||
| 396 : | anton | 1.1 | |
| 397 : | : flush-tos ( -- ) | ||
| 398 : | anton | 1.51 | data-stack flush-a-tos |
| 399 : | fp-stack flush-a-tos | ||
| 400 : | return-stack flush-a-tos ; | ||
| 401 : | anton | 1.49 | |
| 402 : | : fill-a-tos { stack -- } | ||
| 403 : | stack stack-out @ 0= stack stack-in @ 0<> and | ||
| 404 : | if | ||
| 405 : | ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" | ||
| 406 : | 2dup type ." TOS = " type ." [0]);" cr | ||
| 407 : | endif ; | ||
| 408 : | anton | 1.1 | |
| 409 : | : fill-tos ( -- ) | ||
| 410 : | anton | 1.53 | \ !! inst-stream for prefetching? |
| 411 : | anton | 1.51 | fp-stack fill-a-tos |
| 412 : | data-stack fill-a-tos | ||
| 413 : | return-stack fill-a-tos ; | ||
| 414 : | anton | 1.49 | |
| 415 : | : fetch ( addr -- ) | ||
| 416 : | dup item-type @ type-fetch @ execute ; | ||
| 417 : | anton | 1.1 | |
| 418 : | : fetches ( -- ) | ||
| 419 : | anton | 1.64 | effect-in effect-in-end @ ['] fetch map-items ; |
| 420 : | anton | 1.49 | |
| 421 : | : stack-pointer-update { stack -- } | ||
| 422 : | \ stack grow downwards | ||
| 423 : | stack stack-in @ stack stack-out @ - | ||
| 424 : | ?dup-if \ this check is not necessary, gcc would do this for us | ||
| 425 : | stack stack-pointer 2@ type ." += " 0 .r ." ;" cr | ||
| 426 : | endif ; | ||
| 427 : | anton | 1.1 | |
| 428 : | anton | 1.55 | : inst-pointer-update ( -- ) |
| 429 : | inst-stream stack-in @ ?dup-if | ||
| 430 : | ." INC_IP(" 0 .r ." );" cr | ||
| 431 : | endif ; | ||
| 432 : | |||
| 433 : | anton | 1.1 | : stack-pointer-updates ( -- ) |
| 434 : | anton | 1.55 | inst-pointer-update |
| 435 : | anton | 1.51 | data-stack stack-pointer-update |
| 436 : | fp-stack stack-pointer-update | ||
| 437 : | return-stack stack-pointer-update ; | ||
| 438 : | anton | 1.1 | |
| 439 : | : store ( item -- ) | ||
| 440 : | \ f is true if the item should be stored | ||
| 441 : | \ f is false if the store is probably not necessary | ||
| 442 : | anton | 1.49 | dup item-type @ type-store @ execute ; |
| 443 : | anton | 1.1 | |
| 444 : | : stores ( -- ) | ||
| 445 : | anton | 1.64 | effect-out effect-out-end @ ['] store map-items ; |
| 446 : | pazsan | 1.8 | |
| 447 : | anton | 1.52 | : output-c-tail ( -- ) |
| 448 : | \ the final part of the generated C code | ||
| 449 : | ." NEXT_P1;" cr | ||
| 450 : | stores | ||
| 451 : | fill-tos | ||
| 452 : | ." NEXT_P2;" cr ; | ||
| 453 : | |||
| 454 : | : type-c ( c-addr u -- ) | ||
| 455 : | \ like TYPE, but replaces "TAIL;" with tail code | ||
| 456 : | begin ( c-addr1 u1 ) | ||
| 457 : | 2dup s" TAIL;" search | ||
| 458 : | while ( c-addr1 u1 c-addr3 u3 ) | ||
| 459 : | 2dup 2>r drop nip over - type | ||
| 460 : | output-c-tail | ||
| 461 : | 2r> 5 /string | ||
| 462 : | \ !! resync #line missing | ||
| 463 : | repeat | ||
| 464 : | 2drop type ; | ||
| 465 : | |||
| 466 : | anton | 1.63 | : print-type-prefix ( type -- ) |
| 467 : | body> >head .name ; | ||
| 468 : | |||
| 469 : | : print-debug-arg { item -- } | ||
| 470 : | ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); " | ||
| 471 : | ." printarg_" item item-type @ print-type-prefix | ||
| 472 : | ." (" item item-name 2@ type ." );" cr ; | ||
| 473 : | |||
| 474 : | : print-debug-args ( -- ) | ||
| 475 : | ." #ifdef VM_DEBUG" cr | ||
| 476 : | ." if (vm_debug) {" cr | ||
| 477 : | anton | 1.64 | effect-in effect-in-end @ ['] print-debug-arg map-items |
| 478 : | anton | 1.63 | ." fputc('\n', vm_out);" cr |
| 479 : | ." }" cr | ||
| 480 : | ." #endif" cr ; | ||
| 481 : | |||
| 482 : | jwilke | 1.43 | : output-c ( -- ) |
| 483 : | anton | 1.45 | ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr |
| 484 : | anton | 1.1 | ." /* " doc 2@ type ." */" cr |
| 485 : | anton | 1.63 | ." NAME(" quote forth-name 2@ type quote ." )" cr \ debugging |
| 486 : | anton | 1.1 | ." {" cr |
| 487 : | ." DEF_CA" cr | ||
| 488 : | anton | 1.66 | print-declarations |
| 489 : | anton | 1.13 | ." NEXT_P0;" cr |
| 490 : | flush-tos | ||
| 491 : | anton | 1.1 | fetches |
| 492 : | anton | 1.63 | print-debug-args |
| 493 : | anton | 1.13 | stack-pointer-updates |
| 494 : | anton | 1.1 | ." {" cr |
| 495 : | anton | 1.63 | ." #line " c-line @ . quote c-filename 2@ type quote cr |
| 496 : | anton | 1.52 | c-code 2@ type-c |
| 497 : | anton | 1.1 | ." }" cr |
| 498 : | anton | 1.52 | output-c-tail |
| 499 : | anton | 1.1 | ." }" cr |
| 500 : | cr | ||
| 501 : | ; | ||
| 502 : | |||
| 503 : | anton | 1.56 | : disasm-arg { item -- } |
| 504 : | item item-stack @ inst-stream = if | ||
| 505 : | anton | 1.63 | ." fputc(' ', vm_out); " |
| 506 : | ." printarg_" item item-type @ print-type-prefix | ||
| 507 : | ." ((" item item-type @ type-c-name 2@ type ." )" | ||
| 508 : | ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr | ||
| 509 : | anton | 1.56 | endif ; |
| 510 : | |||
| 511 : | : disasm-args ( -- ) | ||
| 512 : | anton | 1.64 | effect-in effect-in-end @ ['] disasm-arg map-items ; |
| 513 : | anton | 1.56 | |
| 514 : | : output-disasm ( -- ) | ||
| 515 : | \ generate code for disassembling VM instructions | ||
| 516 : | ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr | ||
| 517 : | anton | 1.63 | ." fputs(" quote forth-name 2@ type quote ." , vm_out);" cr |
| 518 : | anton | 1.56 | disasm-args |
| 519 : | ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr | ||
| 520 : | anton | 1.68 | ." } else " ; |
| 521 : | anton | 1.56 | |
| 522 : | anton | 1.60 | : gen-arg-parm { item -- } |
| 523 : | item item-stack @ inst-stream = if | ||
| 524 : | ." , " item item-type @ type-c-name 2@ type space | ||
| 525 : | item item-name 2@ type | ||
| 526 : | endif ; | ||
| 527 : | |||
| 528 : | : gen-args-parm ( -- ) | ||
| 529 : | anton | 1.64 | effect-in effect-in-end @ ['] gen-arg-parm map-items ; |
| 530 : | anton | 1.60 | |
| 531 : | : gen-arg-gen { item -- } | ||
| 532 : | item item-stack @ inst-stream = if | ||
| 533 : | ." genarg_" item item-type @ print-type-prefix | ||
| 534 : | ." (ctp, " item item-name 2@ type ." );" cr | ||
| 535 : | endif ; | ||
| 536 : | |||
| 537 : | : gen-args-gen ( -- ) | ||
| 538 : | anton | 1.64 | effect-in effect-in-end @ ['] gen-arg-gen map-items ; |
| 539 : | anton | 1.60 | |
| 540 : | : output-gen ( -- ) | ||
| 541 : | \ generate C code for generating VM instructions | ||
| 542 : | ." void gen_" c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr | ||
| 543 : | ." {" cr | ||
| 544 : | ." gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr | ||
| 545 : | gen-args-gen | ||
| 546 : | anton | 1.68 | ." }" cr ; |
| 547 : | anton | 1.60 | |
| 548 : | anton | 1.49 | : stack-used? { stack -- f } |
| 549 : | stack stack-in @ stack stack-out @ or 0<> ; | ||
| 550 : | jwilke | 1.44 | |
| 551 : | pazsan | 1.30 | : output-funclabel ( -- ) |
| 552 : | ." &I_" c-name 2@ type ." ," cr ; | ||
| 553 : | |||
| 554 : | : output-forthname ( -- ) | ||
| 555 : | '" emit forth-name 2@ type '" emit ." ," cr ; | ||
| 556 : | |||
| 557 : | : output-c-func ( -- ) | ||
| 558 : | jwilke | 1.44 | \ used for word libraries |
| 559 : | ." Cell * I_" c-name 2@ type ." (Cell *SP, Cell **FP) /* " forth-name 2@ type | ||
| 560 : | pazsan | 1.30 | ." ( " stack-string 2@ type ." ) */" cr |
| 561 : | ." /* " doc 2@ type ." */" cr | ||
| 562 : | anton | 1.63 | ." NAME(" quote forth-name 2@ type quote ." )" cr |
| 563 : | pazsan | 1.30 | \ debugging |
| 564 : | ." {" cr | ||
| 565 : | anton | 1.66 | print-declarations |
| 566 : | anton | 1.53 | inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN |
| 567 : | anton | 1.51 | data-stack stack-used? IF ." Cell *sp=SP;" cr THEN |
| 568 : | fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN | ||
| 569 : | return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN | ||
| 570 : | pazsan | 1.30 | flush-tos |
| 571 : | fetches | ||
| 572 : | stack-pointer-updates | ||
| 573 : | anton | 1.49 | fp-stack stack-used? IF ." *FP=fp;" cr THEN |
| 574 : | pazsan | 1.30 | ." {" cr |
| 575 : | anton | 1.63 | ." #line " c-line @ . quote c-filename 2@ type quote cr |
| 576 : | pazsan | 1.30 | c-code 2@ type |
| 577 : | ." }" cr | ||
| 578 : | stores | ||
| 579 : | fill-tos | ||
| 580 : | jwilke | 1.44 | ." return (sp);" cr |
| 581 : | pazsan | 1.30 | ." }" cr |
| 582 : | cr ; | ||
| 583 : | |||
| 584 : | jwilke | 1.43 | : output-label ( -- ) |
| 585 : | anton | 1.68 | ." (Label)&&I_" c-name 2@ type ." ," cr ; |
| 586 : | anton | 1.1 | |
| 587 : | jwilke | 1.43 | : output-alias ( -- ) |
| 588 : | anton | 1.68 | ( primitive-number @ . ." alias " ) ." Primitive " forth-name 2@ type cr ; |
| 589 : | anton | 1.1 | |
| 590 : | jwilke | 1.43 | : output-forth ( -- ) |
| 591 : | pazsan | 1.30 | forth-code @ 0= |
| 592 : | IF \ output-alias | ||
| 593 : | jwilke | 1.28 | \ this is bad for ec: an alias is compiled if tho word does not exist! |
| 594 : | \ JAW | ||
| 595 : | pazsan | 1.30 | ELSE ." : " forth-name 2@ type ." ( " |
| 596 : | anton | 1.49 | stack-string 2@ type ." )" cr |
| 597 : | pazsan | 1.30 | forth-code 2@ type cr |
| 598 : | THEN ; | ||
| 599 : | anton | 1.10 | |
| 600 : | anton | 1.17 | : output-tag-file ( -- ) |
| 601 : | name-filename 2@ last-name-filename 2@ compare if | ||
| 602 : | name-filename 2@ last-name-filename 2! | ||
| 603 : | #ff emit cr | ||
| 604 : | name-filename 2@ type | ||
| 605 : | ." ,0" cr | ||
| 606 : | endif ; | ||
| 607 : | |||
| 608 : | : output-tag ( -- ) | ||
| 609 : | output-tag-file | ||
| 610 : | forth-name 2@ 1+ type | ||
| 611 : | 127 emit | ||
| 612 : | space forth-name 2@ type space | ||
| 613 : | 1 emit | ||
| 614 : | name-line @ 0 .r | ||
| 615 : | ." ,0" cr ; | ||
| 616 : | |||
| 617 : | anton | 1.10 | [IFDEF] documentation |
| 618 : | : register-doc ( -- ) | ||
| 619 : | get-current documentation set-current | ||
| 620 : | forth-name 2@ nextname create | ||
| 621 : | forth-name 2@ 2, | ||
| 622 : | anton | 1.15 | stack-string 2@ condition-stack-effect 2, |
| 623 : | anton | 1.10 | wordset 2@ 2, |
| 624 : | anton | 1.15 | c-name 2@ condition-pronounciation 2, |
| 625 : | anton | 1.10 | doc 2@ 2, |
| 626 : | set-current ; | ||
| 627 : | [THEN] | ||
| 628 : | anton | 1.67 | |
| 629 : | |||
| 630 : | \ the parser | ||
| 631 : | |||
| 632 : | eof-char max-member \ the whole character set + EOF | ||
| 633 : | |||
| 634 : | : getinput ( -- n ) | ||
| 635 : | rawinput @ endrawinput @ = | ||
| 636 : | if | ||
| 637 : | eof-char | ||
| 638 : | else | ||
| 639 : | cookedinput @ c@ | ||
| 640 : | endif ; | ||
| 641 : | |||
| 642 : | :noname ( n -- ) | ||
| 643 : | dup bl > if | ||
| 644 : | emit space | ||
| 645 : | else | ||
| 646 : | . | ||
| 647 : | endif ; | ||
| 648 : | print-token ! | ||
| 649 : | |||
| 650 : | : testchar? ( set -- f ) | ||
| 651 : | getinput member? ; | ||
| 652 : | ' testchar? test-vector ! | ||
| 653 : | |||
| 654 : | : checksyncline ( -- ) | ||
| 655 : | \ when input points to a newline, check if the next line is a | ||
| 656 : | \ sync line. If it is, perform the appropriate actions. | ||
| 657 : | rawinput @ >r | ||
| 658 : | s" #line " r@ over compare 0<> if | ||
| 659 : | rdrop 1 line +! EXIT | ||
| 660 : | endif | ||
| 661 : | 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) | ||
| 662 : | dup c@ bl = if | ||
| 663 : | char+ dup c@ [char] " <> abort" sync line syntax" | ||
| 664 : | char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! | ||
| 665 : | char+ | ||
| 666 : | endif | ||
| 667 : | dup c@ nl-char <> abort" sync line syntax" | ||
| 668 : | skipsynclines @ if | ||
| 669 : | dup char+ rawinput ! | ||
| 670 : | rawinput @ c@ cookedinput @ c! | ||
| 671 : | endif | ||
| 672 : | drop ; | ||
| 673 : | |||
| 674 : | : print-error-line ( -- ) | ||
| 675 : | \ print the current line and position | ||
| 676 : | line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end ) | ||
| 677 : | over - type cr | ||
| 678 : | line-start @ rawinput @ over - typewhite ." ^" cr ; | ||
| 679 : | |||
| 680 : | : ?nextchar ( f -- ) | ||
| 681 : | ?not? if | ||
| 682 : | outfile-id >r try | ||
| 683 : | stderr to outfile-id | ||
| 684 : | filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:" | ||
| 685 : | getinput . cr | ||
| 686 : | print-error-line | ||
| 687 : | 0 | ||
| 688 : | recover endtry | ||
| 689 : | r> to outfile-id throw | ||
| 690 : | abort | ||
| 691 : | endif | ||
| 692 : | rawinput @ endrawinput @ <> if | ||
| 693 : | rawinput @ c@ | ||
| 694 : | 1 chars rawinput +! | ||
| 695 : | 1 chars cookedinput +! | ||
| 696 : | nl-char = if | ||
| 697 : | checksyncline | ||
| 698 : | rawinput @ line-start ! | ||
| 699 : | endif | ||
| 700 : | rawinput @ c@ cookedinput @ c! | ||
| 701 : | endif ; | ||
| 702 : | |||
| 703 : | : charclass ( set "name" -- ) | ||
| 704 : | ['] ?nextchar terminal ; | ||
| 705 : | |||
| 706 : | : .. ( c1 c2 -- set ) | ||
| 707 : | ( creates a set that includes the characters c, c1<=c<=c2 ) | ||
| 708 : | empty copy-set | ||
| 709 : | swap 1+ rot do | ||
| 710 : | i over add-member | ||
| 711 : | loop ; | ||
| 712 : | |||
| 713 : | : ` ( -- terminal ) ( use: ` c ) | ||
| 714 : | ( creates anonymous terminal for the character c ) | ||
| 715 : | char singleton ['] ?nextchar make-terminal ; | ||
| 716 : | |||
| 717 : | char a char z .. char A char Z .. union char _ singleton union charclass letter | ||
| 718 : | char 0 char 9 .. charclass digit | ||
| 719 : | bl singleton tab-char over add-member charclass white | ||
| 720 : | nl-char singleton eof-char over add-member complement charclass nonl | ||
| 721 : | nl-char singleton eof-char over add-member | ||
| 722 : | char : over add-member complement charclass nocolonnl | ||
| 723 : | bl 1+ maxchar .. char \ singleton complement intersection | ||
| 724 : | charclass nowhitebq | ||
| 725 : | bl 1+ maxchar .. charclass nowhite | ||
| 726 : | char " singleton eof-char over add-member complement charclass noquote | ||
| 727 : | nl-char singleton charclass nl | ||
| 728 : | eof-char singleton charclass eof | ||
| 729 : | |||
| 730 : | |||
| 731 : | (( letter (( letter || digit )) ** | ||
| 732 : | )) <- c-ident ( -- ) | ||
| 733 : | |||
| 734 : | (( ` # ?? (( letter || digit || ` : )) ** | ||
| 735 : | )) <- stack-ident ( -- ) | ||
| 736 : | |||
| 737 : | (( nowhitebq nowhite ** )) | ||
| 738 : | <- forth-ident ( -- ) | ||
| 739 : | |||
| 740 : | Variable forth-flag | ||
| 741 : | Variable c-flag | ||
| 742 : | |||
| 743 : | (( (( ` e || ` E )) {{ start }} nonl ** | ||
| 744 : | {{ end evaluate }} | ||
| 745 : | )) <- eval-comment ( ... -- ... ) | ||
| 746 : | |||
| 747 : | (( (( ` f || ` F )) {{ start }} nonl ** | ||
| 748 : | {{ end forth-flag @ IF type cr ELSE 2drop THEN }} | ||
| 749 : | )) <- forth-comment ( -- ) | ||
| 750 : | |||
| 751 : | (( (( ` c || ` C )) {{ start }} nonl ** | ||
| 752 : | {{ end c-flag @ IF type cr ELSE 2drop THEN }} | ||
| 753 : | )) <- c-comment ( -- ) | ||
| 754 : | |||
| 755 : | (( ` - nonl ** {{ | ||
| 756 : | forth-flag @ IF ." [ELSE]" cr THEN | ||
| 757 : | c-flag @ IF ." #else" cr THEN }} | ||
| 758 : | )) <- else-comment | ||
| 759 : | |||
| 760 : | (( ` + {{ start }} nonl ** {{ end | ||
| 761 : | dup | ||
| 762 : | IF c-flag @ | ||
| 763 : | IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP cr | ||
| 764 : | THEN | ||
| 765 : | forth-flag @ | ||
| 766 : | IF ." has? " type ." [IF]" cr THEN | ||
| 767 : | ELSE 2drop | ||
| 768 : | c-flag @ IF ." #endif" cr THEN | ||
| 769 : | forth-flag @ IF ." [THEN]" cr THEN | ||
| 770 : | THEN }} | ||
| 771 : | )) <- if-comment | ||
| 772 : | |||
| 773 : | (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body | ||
| 774 : | |||
| 775 : | (( ` \ comment-body nl )) <- comment ( -- ) | ||
| 776 : | |||
| 777 : | (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) ** | ||
| 778 : | <- stack-items | ||
| 779 : | |||
| 780 : | (( {{ effect-in }} stack-items {{ effect-in-end ! }} | ||
| 781 : | ` - ` - white ** | ||
| 782 : | {{ effect-out }} stack-items {{ effect-out-end ! }} | ||
| 783 : | )) <- stack-effect ( -- ) | ||
| 784 : | |||
| 785 : | (( {{ s" " doc 2! s" " forth-code 2! s" " wordset 2! }} | ||
| 786 : | (( {{ line @ name-line ! filename 2@ name-filename 2! }} | ||
| 787 : | {{ start }} forth-ident {{ end 2dup forth-name 2! c-name 2! }} white ++ | ||
| 788 : | ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white ** | ||
| 789 : | (( {{ start }} forth-ident {{ end wordset 2! }} white ** | ||
| 790 : | (( {{ start }} c-ident {{ end c-name 2! }} )) ?? | ||
| 791 : | )) ?? nl | ||
| 792 : | )) | ||
| 793 : | (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " white ** nl )) ?? | ||
| 794 : | {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl white ** )) ** {{ end c-code 2! skipsynclines on }} | ||
| 795 : | (( ` : white ** nl | ||
| 796 : | {{ start }} (( nonl ++ nl white ** )) ++ {{ end forth-code 2! }} | ||
| 797 : | anton | 1.68 | )) ?? {{ declarations compute-offsets printprim 1 function-number +! }} |
| 798 : | anton | 1.67 | (( nl || eof )) |
| 799 : | )) <- primitive ( -- ) | ||
| 800 : | |||
| 801 : | (( (( comment || primitive || nl white ** )) ** eof )) | ||
| 802 : | parser primitives2something | ||
| 803 : | warnings @ [IF] | ||
| 804 : | .( parser generated ok ) cr | ||
| 805 : | [THEN] | ||
| 806 : | |||
| 807 : | : primfilter ( file-id xt -- ) | ||
| 808 : | \ fileid is for the input file, xt ( -- ) is for the output word | ||
| 809 : | output ! | ||
| 810 : | here dup rawinput ! dup line-start ! cookedinput ! | ||
| 811 : | here unused rot read-file throw | ||
| 812 : | dup here + endrawinput ! | ||
| 813 : | allot | ||
| 814 : | align | ||
| 815 : | checksyncline | ||
| 816 : | \ begin | ||
| 817 : | \ getinput dup eof-char = ?EXIT emit true ?nextchar | ||
| 818 : | \ again ; | ||
| 819 : | primitives2something ; | ||
| 820 : | pazsan | 1.8 | |
| 821 : | anton | 1.1 | : process-file ( addr u xt -- ) |
| 822 : | anton | 1.17 | >r |
| 823 : | anton | 1.61 | save-mem 2dup filename 2! |
| 824 : | pazsan | 1.30 | 0 function-number ! |
| 825 : | anton | 1.17 | r/o open-file abort" cannot open file" |
| 826 : | warnings @ if | ||
| 827 : | ." ------------ CUT HERE -------------" cr endif | ||
| 828 : | r> primfilter ; | ||
| 829 : | pazsan | 1.30 | |
| 830 : | : process ( xt -- ) | ||
| 831 : | bl word count rot | ||
| 832 : | process-file ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |