Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ Copyright 1990 Martin Anton Ertl |
| 2 : | \ | ||
| 3 : | \ TERMS AND CONDITIONS FOR USE, COPYING, MODIFICATION AND DISTRIBUTION | ||
| 4 : | \ | ||
| 5 : | \ 1. You may use this product provided that | ||
| 6 : | \ a) you DO NOT USE IT FOR MILITARY PURPOSES; and | ||
| 7 : | \ b) cause the terms of parapraph 1 to apply to any products | ||
| 8 : | \ developed using this product and make these terms known to all | ||
| 9 : | \ users of such product; | ||
| 10 : | \ By using this product, you indicate the acceptance of the terms of | ||
| 11 : | \ this paragraph. | ||
| 12 : | \ | ||
| 13 : | \ 2. Except for the restrictions mentioned in paragraph 1, you may use | ||
| 14 : | \ the Program. | ||
| 15 : | \ | ||
| 16 : | \ 3. You may distribute verbatim or modified copies of this program, | ||
| 17 : | \ provided that | ||
| 18 : | \ a) you keep intact all copyright notices, this license, and the notices | ||
| 19 : | \ referring to this license and to the absence of warranty; and | ||
| 20 : | \ b) you cause any work that you distribute or publish that contains the | ||
| 21 : | \ Program or part of it to be licensed to all third parties under the | ||
| 22 : | \ terms of this license. You may not impose any further restriction | ||
| 23 : | \ on the recipients exercise of the rights granted herein. Mere | ||
| 24 : | \ aggregation of another independent work with the Program or its | ||
| 25 : | \ derivative on a volume of storage or distribution medium does not | ||
| 26 : | \ bring the other work under the scope of these terms; and | ||
| 27 : | \ c) you cause the derivative to carry prominent notices saying that | ||
| 28 : | \ you changed the Program. | ||
| 29 : | \ | ||
| 30 : | \ 4. You may distribute the Program or its derivative in intermediate, | ||
| 31 : | \ object or executable code, if you accompany it with the complete | ||
| 32 : | \ machine-readable source code. | ||
| 33 : | \ | ||
| 34 : | \ 5. By using, modifying, copying or distributing the Program you | ||
| 35 : | \ indicate your acceptance of this license and all its terms and | ||
| 36 : | \ conditions. | ||
| 37 : | \ | ||
| 38 : | \ 6. This Program is provided WITHOUT WARRANTY of any kind, either | ||
| 39 : | \ express or implied, including, but not limited to, the implied | ||
| 40 : | \ warranties of merchantability and fitness for a particular purpose. In | ||
| 41 : | \ no event, unless required by applicable law or agreed to in writing, | ||
| 42 : | \ will any copyright holder, or any other party who may modify and or | ||
| 43 : | \ redistribute the Program, be liable to you for any damages, even if | ||
| 44 : | \ such holder or other party has been advised of the possibility of such | ||
| 45 : | \ damages. | ||
| 46 : | \ END OF TERMS AND CONDITIONS ) | ||
| 47 : | |||
| 48 : | \ recursive descent parser generator ) | ||
| 49 : | |||
| 50 : | .( Loading Gray ... Copyright 1990 Martin Anton Ertl; NO WARRANTY ) cr | ||
| 51 : | |||
| 52 : | \ misc ) | ||
| 53 : | : noop ; | ||
| 54 : | |||
| 55 : | 1 cells constant cell | ||
| 56 : | cell 8 * constant bits/cell \ !! implementation dependent ) | ||
| 57 : | |||
| 58 : | : ?not? ( f -- f ) | ||
| 59 : | 0= ; | ||
| 60 : | |||
| 61 : | : 2, ( w1 w2 -- ) | ||
| 62 : | here 2 cells allot 2! ; | ||
| 63 : | |||
| 64 : | : endif postpone then ; immediate | ||
| 65 : | |||
| 66 : | : ?pairs ( n1 n2 -- ) | ||
| 67 : | ( aborts, if the numbers are not equal ) | ||
| 68 : | = ?not? abort" mismatched parenthesis" ; | ||
| 69 : | |||
| 70 : | : ', \ -- ) ( use: ', name ) | ||
| 71 : | ' , ; | ||
| 72 : | |||
| 73 : | 1 0= constant false | ||
| 74 : | 0 0= constant true | ||
| 75 : | |||
| 76 : | \ stack administration ) | ||
| 77 : | \ this implementation is completely unsafe ) | ||
| 78 : | |||
| 79 : | : stack \ n -- ) | ||
| 80 : | \ use: n stack word ) | ||
| 81 : | \ creates a stack called word with n cells ) | ||
| 82 : | \ the first cell is the stackpointer ) | ||
| 83 : | create here , cells allot ; | ||
| 84 : | |||
| 85 : | : push \ n stack -- ) | ||
| 86 : | cell over +! @ ! ; | ||
| 87 : | |||
| 88 : | : top \ stack -- n ) | ||
| 89 : | @ @ ; | ||
| 90 : | |||
| 91 : | : pop \ stack -- ) | ||
| 92 : | [ -1 cells ] literal swap +! ; | ||
| 93 : | |||
| 94 : | : clear? \ stack -- f ) | ||
| 95 : | dup @ = ; | ||
| 96 : | |||
| 97 : | : clear \ stack -- ) | ||
| 98 : | dup ! ; | ||
| 99 : | |||
| 100 : | |||
| 101 : | \ sets - represented as bit arrays ) | ||
| 102 : | \ bits that represent no elements, must be 0 ) | ||
| 103 : | \ all operations assume valid parameters ) | ||
| 104 : | \ elements must be unsigned numbers ) | ||
| 105 : | \ the max. element size must be declared with max-member ) | ||
| 106 : | \ no checking is performed ) | ||
| 107 : | \ set operations allot memory ) | ||
| 108 : | |||
| 109 : | : decode \ u -- w ) | ||
| 110 : | \ returns a cell with bit# u set and everyting else clear ) | ||
| 111 : | 1 swap lshift ; | ||
| 112 : | |||
| 113 : | variable cells/set 0 cells/set ! | ||
| 114 : | variable empty-ptr 0 empty-ptr ! \ updatd by max-member ) | ||
| 115 : | : empty \ -- set ) | ||
| 116 : | empty-ptr @ ; | ||
| 117 : | |||
| 118 : | : max-member \ u -- ) | ||
| 119 : | \ declares u to be the maximum member of sets generated afterwards ) | ||
| 120 : | \ must be called before using any set word except member?, add-member ) | ||
| 121 : | bits/cell / 1+ | ||
| 122 : | dup cells/set ! | ||
| 123 : | here empty-ptr ! \ make empty set ) | ||
| 124 : | 0 do 0 , loop ; | ||
| 125 : | |||
| 126 : | : copy-set \ set1 -- set2 ) | ||
| 127 : | \ makes a copy of set1 ) | ||
| 128 : | here swap | ||
| 129 : | cells/set @ 0 do | ||
| 130 : | dup @ , | ||
| 131 : | cell+ loop | ||
| 132 : | drop ; | ||
| 133 : | |||
| 134 : | : normalize-bit-addr \ addr1 u1 -- addr2 u2 ) | ||
| 135 : | \ addr1*bits/cell+u1=addr2*bits/cell+u2, u2<bits/cell ) | ||
| 136 : | bits/cell /mod | ||
| 137 : | cells rot + | ||
| 138 : | swap ; | ||
| 139 : | |||
| 140 : | : add-member \ u set -- ) | ||
| 141 : | \ changes set to include u ) | ||
| 142 : | swap normalize-bit-addr | ||
| 143 : | decode | ||
| 144 : | over @ or swap ! ; | ||
| 145 : | |||
| 146 : | : singleton \ u -- set ) | ||
| 147 : | \ makes a set that contains u and nothing else ) | ||
| 148 : | empty copy-set swap over add-member ; | ||
| 149 : | |||
| 150 : | : member? \ set u -- f ) | ||
| 151 : | \ returns true if u is in set ) | ||
| 152 : | normalize-bit-addr | ||
| 153 : | decode | ||
| 154 : | swap @ and | ||
| 155 : | 0= ?not? ; | ||
| 156 : | |||
| 157 : | : binary-set-operation \ set1 set2 [w1 w2 -- w3] -- set ) | ||
| 158 : | \ creates set from set1 and set2 by applying [w1 w2 -- w3] on members ) | ||
| 159 : | \ e.g. ' or binary-set-operation is the union operation ) | ||
| 160 : | here >r | ||
| 161 : | cells/set @ 0 do >r | ||
| 162 : | over @ over @ r@ execute , | ||
| 163 : | cell+ swap cell+ swap | ||
| 164 : | r> loop | ||
| 165 : | drop 2drop r> ; | ||
| 166 : | |||
| 167 : | : union1 \ set1 set2 -- set ) | ||
| 168 : | ['] or binary-set-operation ; | ||
| 169 : | |||
| 170 : | : intersection \ set1 set2 -- set ) | ||
| 171 : | ['] and binary-set-operation ; | ||
| 172 : | |||
| 173 : | : binary-set-test? \ set1 set2 [w1 w2 -- w3] -- f ) | ||
| 174 : | \ returns true, if [w1 w2 -- w3] binary-set-operation returns empty ) | ||
| 175 : | \ e.g. set1 set2 ' and binary-set-test? is true, if set1 and set2 | ||
| 176 : | \ are disjoint, i.e. they contain no common members ) | ||
| 177 : | >r true rot rot r> | ||
| 178 : | cells/set @ 0 do >r | ||
| 179 : | over @ over @ r@ execute 0= ?not? if | ||
| 180 : | rot drop false rot rot | ||
| 181 : | endif | ||
| 182 : | cell+ swap cell+ swap | ||
| 183 : | r> loop | ||
| 184 : | drop 2drop ; | ||
| 185 : | |||
| 186 : | : notb&and \ w1 w2 -- w3 ) | ||
| 187 : | -1 xor and ; | ||
| 188 : | |||
| 189 : | : subset? \ set1 set2 -- f ) | ||
| 190 : | \ returns true if every member of set1 is in set2 ) | ||
| 191 : | ['] notb&and binary-set-test? ; | ||
| 192 : | |||
| 193 : | : disjoint? \ set1 set2 -- f ) | ||
| 194 : | \ returns true if set1 and set2 heve no common members ) | ||
| 195 : | ['] and binary-set-test? ; | ||
| 196 : | |||
| 197 : | : apply-to-members \ set [ u -- ] -- ) | ||
| 198 : | \ executes [ u -- ] for every member of set ) | ||
| 199 : | cells/set @ bits/cell * 0 do | ||
| 200 : | over i member? if | ||
| 201 : | i over execute | ||
| 202 : | endif | ||
| 203 : | loop | ||
| 204 : | 2drop ; | ||
| 205 : | |||
| 206 : | : union \ set1 set2 -- set ) | ||
| 207 : | \ just a little more space-efficient ) | ||
| 208 : | 2dup subset? if | ||
| 209 : | swap drop | ||
| 210 : | else 2dup swap subset? if | ||
| 211 : | drop | ||
| 212 : | else | ||
| 213 : | union1 | ||
| 214 : | endif endif ; | ||
| 215 : | |||
| 216 : | |||
| 217 : | \ tests ) | ||
| 218 : | variable test-vector ' abort test-vector ! | ||
| 219 : | \ here you should store the execution address of a word ( set -- f ) | ||
| 220 : | \ that returns true if the token of the current symbol is in set ) | ||
| 221 : | |||
| 222 : | : compile-test \ set -- ) | ||
| 223 : | postpone literal | ||
| 224 : | test-vector @ compile, ; | ||
| 225 : | |||
| 226 : | |||
| 227 : | \ context management ) | ||
| 228 : | 500 stack context-stack | ||
| 229 : | \ this stack holds the syntax-exprs currently being treated ) | ||
| 230 : | \ enlarge it, if your grammar is large and complex ) | ||
| 231 : | context-stack clear | ||
| 232 : | |||
| 233 : | : this \ -- syntax-expr ) | ||
| 234 : | \ get current syntax-expr ) | ||
| 235 : | context-stack top ; | ||
| 236 : | |||
| 237 : | : new-context \ syntax-expr -- ) | ||
| 238 : | context-stack push ; | ||
| 239 : | |||
| 240 : | : old-context \ -- ) | ||
| 241 : | context-stack pop ; | ||
| 242 : | |||
| 243 : | |||
| 244 : | \ structures ) | ||
| 245 : | : <builds-field \ n1 n2 -- n3 ) ( defining-word ) | ||
| 246 : | \ n1 is the offset of the field, n2 its length, n3 the offset of the | ||
| 247 : | \ next field; creates a word that contains the offset ) | ||
| 248 : | create over , + ; | ||
| 249 : | |||
| 250 : | 0 constant struct | ||
| 251 : | \ initial offset | ||
| 252 : | |||
| 253 : | : context-var \ use: < offset > size context-var name < offset2 > ) | ||
| 254 : | \ name returns the address of the offset field of "this" ) | ||
| 255 : | <builds-field \ n1 n2 -- n3 ) | ||
| 256 : | does> \ -- addr ) | ||
| 257 : | @ this + ; | ||
| 258 : | |||
| 259 : | : context-const \ use: < offset > context-const name < offset2 > ) | ||
| 260 : | \ name returns the contents of the field of this at offset ) | ||
| 261 : | cell <builds-field \ n1 -- n2 ) | ||
| 262 : | does> \ -- n ) | ||
| 263 : | @ this + @ ; | ||
| 264 : | |||
| 265 : | |||
| 266 : | \ syntax-exprs ) | ||
| 267 : | struct | ||
| 268 : | aligned context-const methods | ||
| 269 : | \ table of words applicable to the syntax-expr (a map) | ||
| 270 : | 1 context-var mark-propagate \ used to ensure that "propagate" is | ||
| 271 : | \ called at least once for each syntax-expr ) | ||
| 272 : | 1 context-var mark-pass2 | ||
| 273 : | \ make sure pass2 is called exactly once ) | ||
| 274 : | aligned cell context-var first-set | ||
| 275 : | \ all tokens a nonempty path may begin with ) | ||
| 276 : | \ if it's equal to 0, the first-set has not been computed yet ) | ||
| 277 : | 1 context-var maybe-empty | ||
| 278 : | \ true if the syntax-expr can derive eps ) | ||
| 279 : | aligned cell context-var follow-set | ||
| 280 : | \ the tokens of the terminals that can follow the syntax-expr ) | ||
| 281 : | aligned 2 cells context-var source-location \ for error msgs ) | ||
| 282 : | constant syntax-expr \ length of a syntax-expr ) | ||
| 283 : | |||
| 284 : | : make-syntax-expr \ map -- syntax-expr ) | ||
| 285 : | \ allocate a syntax-expr and initialize it ) | ||
| 286 : | here swap , false c, false c, | ||
| 287 : | align 0 , false c, align empty , | ||
| 288 : | \ source location !! implementation dependent ) | ||
| 289 : | \ if you use blocks, use: | ||
| 290 : | \ blk @ >in @ 2, | ||
| 291 : | \ the following is just a dummy | ||
| 292 : | 0 loadline @ 2, | ||
| 293 : | ; | ||
| 294 : | |||
| 295 : | |||
| 296 : | \ warnings and errors ) | ||
| 297 : | : .in \ -- ) | ||
| 298 : | \ !! implementation dependent ) | ||
| 299 : | \ prints the info stored in source-location in a usable way ) | ||
| 300 : | \ prints where the error happened ) | ||
| 301 : | source-location 2@ ." line" . drop ." :" ; | ||
| 302 : | |||
| 303 : | |||
| 304 : | : gray-error abort ; | ||
| 305 : | |||
| 306 : | : internal-error | ||
| 307 : | cr .in ." you found a bug" gray-error ; | ||
| 308 : | |||
| 309 : | variable print-token ' . print-token ! | ||
| 310 : | \ contains execution address of a word < token -- > to print a token ) | ||
| 311 : | |||
| 312 : | : check-conflict \ set1 set2 -- ) | ||
| 313 : | \ print the intersection of set1 and set2 if it isn't empty ) | ||
| 314 : | 2dup disjoint? ?not? if | ||
| 315 : | cr .in ." conflict:" | ||
| 316 : | intersection print-token @ apply-to-members | ||
| 317 : | else | ||
| 318 : | 2drop | ||
| 319 : | endif ; | ||
| 320 : | |||
| 321 : | |||
| 322 : | \ methods and maps ) | ||
| 323 : | : method \ use: < offset > method name < offset2 > ) | ||
| 324 : | \ executes the word whose execution address is stored in the field | ||
| 325 : | \ at offset of a table pointed to by the "methods" field of "this" ) | ||
| 326 : | cell <builds-field \ n1 -- n2 ) | ||
| 327 : | does> | ||
| 328 : | @ methods + @ execute ; | ||
| 329 : | |||
| 330 : | \ method table for syntax-exprs | ||
| 331 : | struct | ||
| 332 : | method compute-method | ||
| 333 : | method propagate-method | ||
| 334 : | method generate-method | ||
| 335 : | method pass2-method | ||
| 336 : | constant syntax-expr-methods | ||
| 337 : | |||
| 338 : | |||
| 339 : | \ general routines ) | ||
| 340 : | : compute \ syntax-expr -- first-set maybe-empty ) | ||
| 341 : | \ compute the first-set and maybe-empty of a syntax-expr ) | ||
| 342 : | \ a bit of memoization is used here ) | ||
| 343 : | new-context | ||
| 344 : | first-set @ 0= if | ||
| 345 : | compute-method | ||
| 346 : | maybe-empty c! | ||
| 347 : | first-set ! | ||
| 348 : | endif | ||
| 349 : | first-set @ maybe-empty c@ | ||
| 350 : | old-context ; | ||
| 351 : | |||
| 352 : | : get-first \ syntax-expr -- first-set ) | ||
| 353 : | compute drop ; | ||
| 354 : | |||
| 355 : | : check-cycle \ syntax-expr -- ) | ||
| 356 : | \ just check for left recursion ) | ||
| 357 : | compute 2drop ; | ||
| 358 : | |||
| 359 : | : propagate \ follow-set syntax-expr -- ) | ||
| 360 : | \ add follow-set to the follow set of syntax-expr and its children ) | ||
| 361 : | new-context | ||
| 362 : | dup follow-set @ subset? ?not? \ would everything stay the same | ||
| 363 : | mark-propagate c@ ?not? or if \ and was propagate here already | ||
| 364 : | true mark-propagate c! \ NO, do propagate | ||
| 365 : | follow-set @ union dup follow-set ! | ||
| 366 : | propagate-method | ||
| 367 : | else | ||
| 368 : | drop | ||
| 369 : | endif | ||
| 370 : | old-context ; | ||
| 371 : | |||
| 372 : | : generate \ syntax-expr -- ) | ||
| 373 : | \ this one gets things done ) | ||
| 374 : | new-context generate-method old-context ; | ||
| 375 : | |||
| 376 : | : pass2 \ syntax-expr -- ) | ||
| 377 : | \ computes all necessary first sets, checks for left recursions | ||
| 378 : | \ and conflicts and generates code for rules ) | ||
| 379 : | new-context | ||
| 380 : | mark-pass2 c@ ?not? if | ||
| 381 : | true mark-pass2 c! | ||
| 382 : | this check-cycle | ||
| 383 : | pass2-method | ||
| 384 : | endif | ||
| 385 : | old-context ; | ||
| 386 : | |||
| 387 : | |||
| 388 : | \ main routine ) | ||
| 389 : | : parser \ syntax-expr -- ) | ||
| 390 : | \ use: syntax-expr parser xxx ) | ||
| 391 : | context-stack clear | ||
| 392 : | empty over propagate | ||
| 393 : | dup pass2 | ||
| 394 : | \ : should not be immediate | ||
| 395 : | >r : r> generate postpone ; ; | ||
| 396 : | |||
| 397 : | |||
| 398 : | \ eps - empty syntax-expr ) | ||
| 399 : | create eps-map | ||
| 400 : | ', internal-error | ||
| 401 : | ', drop | ||
| 402 : | ', noop | ||
| 403 : | ', noop | ||
| 404 : | |||
| 405 : | |||
| 406 : | create eps1 | ||
| 407 : | \ the eps syntax-expr proper | ||
| 408 : | eps-map make-syntax-expr | ||
| 409 : | drop | ||
| 410 : | |||
| 411 : | |||
| 412 : | : eps \ -- syntax-expr ) | ||
| 413 : | \ just adjusts eps1 and returns it | ||
| 414 : | eps1 new-context | ||
| 415 : | empty first-set ! ( empty changes due to max-member ) | ||
| 416 : | empty follow-set ! | ||
| 417 : | true maybe-empty c! | ||
| 418 : | old-context | ||
| 419 : | eps1 ; | ||
| 420 : | |||
| 421 : | |||
| 422 : | \ terminals ) | ||
| 423 : | \ a terminal is a syntax-expr with an extra field ) | ||
| 424 : | syntax-expr | ||
| 425 : | context-const check&next | ||
| 426 : | \ contains address of a word < f -- > that checks | ||
| 427 : | \ if f is true and reads the next terminal symbol ) | ||
| 428 : | constant terminal-syntax-expr | ||
| 429 : | |||
| 430 : | : generate-terminal \ -- ) | ||
| 431 : | this get-first compile-test | ||
| 432 : | check&next compile, ; | ||
| 433 : | |||
| 434 : | create terminal-map | ||
| 435 : | ', internal-error | ||
| 436 : | ', drop | ||
| 437 : | ', generate-terminal | ||
| 438 : | ', noop | ||
| 439 : | |||
| 440 : | : make-terminal \ first-set cfa -- syntax-expr ) | ||
| 441 : | terminal-map make-syntax-expr | ||
| 442 : | new-context | ||
| 443 : | , | ||
| 444 : | first-set ! | ||
| 445 : | this old-context ; | ||
| 446 : | |||
| 447 : | : terminal \ first-set cfa -- ) | ||
| 448 : | create make-terminal drop ; | ||
| 449 : | |||
| 450 : | |||
| 451 : | \ binary syntax-exprs ) | ||
| 452 : | syntax-expr | ||
| 453 : | context-const operand1 | ||
| 454 : | context-const operand2 | ||
| 455 : | constant binary-syntax-expr | ||
| 456 : | |||
| 457 : | : make-binary \ syntax-expr1 syntax-expr2 map -- syntax-expr ) | ||
| 458 : | make-syntax-expr rot , swap , ; | ||
| 459 : | |||
| 460 : | : pass2-binary | ||
| 461 : | operand1 pass2 | ||
| 462 : | operand2 pass2 ; | ||
| 463 : | |||
| 464 : | |||
| 465 : | \ concatenations ) | ||
| 466 : | : compute-concatenation \ -- first maybe-empty ) | ||
| 467 : | operand1 compute dup if | ||
| 468 : | drop | ||
| 469 : | operand2 compute | ||
| 470 : | >r union r> | ||
| 471 : | endif ; | ||
| 472 : | |||
| 473 : | : propagate-concatenation \ follow-set -- ) | ||
| 474 : | operand2 compute if | ||
| 475 : | over union | ||
| 476 : | endif \ follow follow1 ) | ||
| 477 : | operand1 propagate | ||
| 478 : | operand2 propagate ; | ||
| 479 : | |||
| 480 : | : generate-concatenation \ -- ) | ||
| 481 : | operand1 generate | ||
| 482 : | operand2 generate ; | ||
| 483 : | |||
| 484 : | create concatenation-map | ||
| 485 : | ', compute-concatenation | ||
| 486 : | ', propagate-concatenation | ||
| 487 : | ', generate-concatenation | ||
| 488 : | ', pass2-binary | ||
| 489 : | |||
| 490 : | : concat \ syntax-expr1 syntax-expr2 -- syntax-expr ) | ||
| 491 : | concatenation-map make-binary ; | ||
| 492 : | \ this is the actual concatenation operator ) | ||
| 493 : | \ but for safety and readability the parenthesised notation ) | ||
| 494 : | \ is preferred ) | ||
| 495 : | |||
| 496 : | |||
| 497 : | \ alternatives ) | ||
| 498 : | : compute-alternative \ -- first maybe-empty ) | ||
| 499 : | operand1 compute | ||
| 500 : | operand2 compute | ||
| 501 : | rot 2dup and if | ||
| 502 : | cr .in ." warning: two branches may be empty" endif | ||
| 503 : | or >r union r> ; | ||
| 504 : | |||
| 505 : | : propagate-alternative \ follow -- ) | ||
| 506 : | dup operand1 propagate | ||
| 507 : | operand2 propagate ; | ||
| 508 : | |||
| 509 : | : generate-alternative1 \ -- ) | ||
| 510 : | operand1 get-first compile-test | ||
| 511 : | postpone if | ||
| 512 : | operand1 generate | ||
| 513 : | postpone else | ||
| 514 : | operand2 generate | ||
| 515 : | postpone endif ; | ||
| 516 : | |||
| 517 : | : generate-alternative2 \ -- ) | ||
| 518 : | operand1 get-first compile-test postpone ?not? | ||
| 519 : | operand2 get-first compile-test postpone and | ||
| 520 : | postpone if | ||
| 521 : | operand2 generate | ||
| 522 : | postpone else | ||
| 523 : | operand1 generate | ||
| 524 : | postpone endif ; | ||
| 525 : | |||
| 526 : | : generate-alternative \ -- ) | ||
| 527 : | operand1 compute if | ||
| 528 : | generate-alternative2 | ||
| 529 : | else | ||
| 530 : | generate-alternative1 | ||
| 531 : | endif | ||
| 532 : | drop ; | ||
| 533 : | |||
| 534 : | : pass2-alternative \ -- ) | ||
| 535 : | this compute if | ||
| 536 : | follow-set @ check-conflict | ||
| 537 : | else | ||
| 538 : | drop | ||
| 539 : | endif | ||
| 540 : | operand1 get-first operand2 get-first check-conflict | ||
| 541 : | pass2-binary ; | ||
| 542 : | |||
| 543 : | create alternative-map | ||
| 544 : | ', compute-alternative | ||
| 545 : | ', propagate-alternative | ||
| 546 : | ', generate-alternative | ||
| 547 : | ', pass2-alternative | ||
| 548 : | |||
| 549 : | : alt \ syntax-expr1 syntax-expr2 -- syntax-expr ) | ||
| 550 : | alternative-map make-binary ; | ||
| 551 : | \ this is the actual alternative operator ) | ||
| 552 : | \ but for safety and readability the parenthesised notation ) | ||
| 553 : | \ is preferred ) | ||
| 554 : | |||
| 555 : | |||
| 556 : | \ unary syntax-exprs ) | ||
| 557 : | syntax-expr | ||
| 558 : | context-const operand | ||
| 559 : | constant unary-syntax-expr | ||
| 560 : | |||
| 561 : | : make-unary \ syntax-expr1 map -- syntax-expr2 ) | ||
| 562 : | make-syntax-expr swap , ; | ||
| 563 : | |||
| 564 : | |||
| 565 : | \ options and repetitions ) | ||
| 566 : | : pass2-option&repetition \ -- ) | ||
| 567 : | follow-set @ operand get-first check-conflict | ||
| 568 : | operand pass2 ; | ||
| 569 : | |||
| 570 : | |||
| 571 : | \ options ) | ||
| 572 : | : compute-option \ -- set f ) | ||
| 573 : | operand compute if | ||
| 574 : | cr .in ." warning: unnessesary option" endif | ||
| 575 : | true ; | ||
| 576 : | |||
| 577 : | : propagate-option \ follow -- ) | ||
| 578 : | operand propagate ; | ||
| 579 : | |||
| 580 : | : generate-option \ -- ) | ||
| 581 : | operand get-first compile-test | ||
| 582 : | postpone if | ||
| 583 : | operand generate | ||
| 584 : | postpone endif ; | ||
| 585 : | |||
| 586 : | create option-map | ||
| 587 : | ', compute-option | ||
| 588 : | ', propagate-option | ||
| 589 : | ', generate-option | ||
| 590 : | ', pass2-option&repetition | ||
| 591 : | |||
| 592 : | : ?? \ syntax-expr1 -- syntax-expr2 ) | ||
| 593 : | option-map make-unary ; | ||
| 594 : | |||
| 595 : | |||
| 596 : | \ repetitions ) | ||
| 597 : | : propagate-repetition \ follow-set -- ) | ||
| 598 : | operand get-first union operand propagate ; | ||
| 599 : | |||
| 600 : | |||
| 601 : | \ *-repetitions ) | ||
| 602 : | : compute-*repetition \ -- set f ) | ||
| 603 : | operand compute if | ||
| 604 : | cr .in ." warning: *repetition of optional term" endif | ||
| 605 : | true ; | ||
| 606 : | |||
| 607 : | : generate-*repetition \ -- ) | ||
| 608 : | postpone begin | ||
| 609 : | operand get-first compile-test | ||
| 610 : | postpone while | ||
| 611 : | operand generate | ||
| 612 : | postpone repeat ; | ||
| 613 : | |||
| 614 : | create *repetition-map | ||
| 615 : | ', compute-*repetition | ||
| 616 : | ', propagate-repetition | ||
| 617 : | ', generate-*repetition | ||
| 618 : | ', pass2-option&repetition | ||
| 619 : | |||
| 620 : | : ** \ syntax-expr1 -- syntax-expr2 ) | ||
| 621 : | *repetition-map make-unary ; | ||
| 622 : | |||
| 623 : | |||
| 624 : | \ +-repetitions ) | ||
| 625 : | : compute-+repetition \ -- set f ) | ||
| 626 : | operand compute ; | ||
| 627 : | |||
| 628 : | : generate-+repetition \ -- ) | ||
| 629 : | postpone begin | ||
| 630 : | operand generate | ||
| 631 : | operand get-first compile-test | ||
| 632 : | postpone ?not? postpone until ; | ||
| 633 : | |||
| 634 : | create +repetition-map | ||
| 635 : | ', compute-+repetition | ||
| 636 : | ', propagate-repetition | ||
| 637 : | ', generate-+repetition | ||
| 638 : | ', pass2-option&repetition | ||
| 639 : | |||
| 640 : | : ++ \ syntax-expr1 -- syntax-expr2 ) | ||
| 641 : | +repetition-map make-unary ; | ||
| 642 : | |||
| 643 : | |||
| 644 : | \ actions ) | ||
| 645 : | syntax-expr | ||
| 646 : | context-const action | ||
| 647 : | constant action-syntax-expr | ||
| 648 : | |||
| 649 : | : generate-action \ syntax-expr -- ) | ||
| 650 : | action compile, ; | ||
| 651 : | |||
| 652 : | create action-map | ||
| 653 : | ', internal-error | ||
| 654 : | ', drop | ||
| 655 : | ', generate-action | ||
| 656 : | ', noop | ||
| 657 : | |||
| 658 : | : {{ \ -- syntax-expr addr colon-sys ) | ||
| 659 : | action-map make-syntax-expr | ||
| 660 : | new-context | ||
| 661 : | empty first-set ! | ||
| 662 : | true maybe-empty c! | ||
| 663 : | this old-context | ||
| 664 : | \ ?exec !csp ) | ||
| 665 : | here cell allot | ||
| 666 : | :noname ; | ||
| 667 : | |||
| 668 : | : }} \ syntax-expr addr colon-sys -- syntax-expr ) | ||
| 669 : | \ ?csp ) | ||
| 670 : | postpone ; | ||
| 671 : | swap ! | ||
| 672 : | ; immediate | ||
| 673 : | |||
| 674 : | |||
| 675 : | \ nonterminals ) | ||
| 676 : | syntax-expr | ||
| 677 : | 1 context-var mark-compute | ||
| 678 : | aligned cell context-var rule-body \ in forth left side of rule ) | ||
| 679 : | cell context-var exec \ cfa of code for rule ) | ||
| 680 : | constant nt-syntax-expr | ||
| 681 : | |||
| 682 : | : get-body \ -- syntax-expr ) | ||
| 683 : | \ get the body of the rule for the nt in "this" ) | ||
| 684 : | rule-body @ if | ||
| 685 : | rule-body @ | ||
| 686 : | else | ||
| 687 : | cr .in ." no rule for nonterminal" gray-error | ||
| 688 : | endif ; | ||
| 689 : | |||
| 690 : | : compute-nt \ -- set f ) | ||
| 691 : | mark-compute c@ if | ||
| 692 : | cr .in ." left recursion" gray-error | ||
| 693 : | else | ||
| 694 : | true mark-compute c! | ||
| 695 : | get-body compute | ||
| 696 : | endif ; | ||
| 697 : | |||
| 698 : | : propagate-nt \ follow-set -- ) | ||
| 699 : | get-body propagate ; | ||
| 700 : | |||
| 701 : | : code-nt \ -- ) | ||
| 702 : | \ generates the code for a rule ) | ||
| 703 : | :noname | ||
| 704 : | get-body generate | ||
| 705 : | postpone ; | ||
| 706 : | exec ! ; | ||
| 707 : | |||
| 708 : | : generate-nt \ -- ) | ||
| 709 : | \ generates a call to the code for the rule ) | ||
| 710 : | \ since the code needs not be generated yet, an indirect call is used ) | ||
| 711 : | exec postpone literal | ||
| 712 : | postpone @ | ||
| 713 : | postpone execute ; | ||
| 714 : | |||
| 715 : | : pass2-nt \ -- ) | ||
| 716 : | \ apart from the usual duties, this pass2 also has to code-nt ) | ||
| 717 : | get-body pass2 | ||
| 718 : | code-nt ; | ||
| 719 : | |||
| 720 : | create nt-map | ||
| 721 : | ', compute-nt | ||
| 722 : | ', propagate-nt | ||
| 723 : | ', generate-nt | ||
| 724 : | ', pass2-nt | ||
| 725 : | |||
| 726 : | : make-nt \ syntax-expr -- nt ) | ||
| 727 : | nt-map make-syntax-expr | ||
| 728 : | false c, align swap , 0 , ; | ||
| 729 : | |||
| 730 : | : <- \ use: syntax-expr <- xxx ) | ||
| 731 : | \ xxx: -- syntax-expr ) | ||
| 732 : | create make-nt drop ; | ||
| 733 : | |||
| 734 : | : nonterminal \ use: nonterminal xxx ) | ||
| 735 : | 0 <- ; \ forward declaration ) | ||
| 736 : | |||
| 737 : | : rule \ syntax-expr nt -- ) | ||
| 738 : | \ makes a rule ) | ||
| 739 : | new-context | ||
| 740 : | rule-body @ if | ||
| 741 : | .in ." multiple rules for nonterminal" gray-error endif | ||
| 742 : | rule-body ! | ||
| 743 : | old-context ; | ||
| 744 : | |||
| 745 : | |||
| 746 : | \ syntactic sugar ) | ||
| 747 : | : reduce \ 0 x1 ... [x2 x3 -- x4] -- x ) | ||
| 748 : | \ e.g. 0 5 6 7 ' + reduce = 5 6 7 + + = 18 ) | ||
| 749 : | >r dup 0= if | ||
| 750 : | ." no operand" abort | ||
| 751 : | endif | ||
| 752 : | begin | ||
| 753 : | over 0= ?not? while | ||
| 754 : | r@ execute | ||
| 755 : | repeat \ 0 x ) | ||
| 756 : | swap drop r> drop ; | ||
| 757 : | |||
| 758 : | 7 constant concatenation-id | ||
| 759 : | : (- \ -- n 0 ) | ||
| 760 : | concatenation-id 0 ; | ||
| 761 : | : -) \ n 0 syntax-expr1 syntax-expr2 .. -- syntax-expr ) | ||
| 762 : | ['] concat reduce | ||
| 763 : | swap concatenation-id ?pairs ; | ||
| 764 : | |||
| 765 : | 8 constant alternative-id | ||
| 766 : | : (| \ -- n 0 ) | ||
| 767 : | alternative-id 0 ; | ||
| 768 : | : |) \ n 0 syntax-expr1 syntax-expr2 .. -- syntax-expr ) | ||
| 769 : | ['] alt reduce | ||
| 770 : | swap alternative-id ?pairs ; | ||
| 771 : | |||
| 772 : | : (( (| (- ; | ||
| 773 : | : )) -) |) ; | ||
| 774 : | : || -) (- ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |