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