Annotation of gforth/gray.fs, revision 1.1
1.1 ! anton 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: : || -) (- ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to gray.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth