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