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