Annotation of gforth/gray.fs, revision 1.2

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: 
1.2     ! pazsan     50: warnings @ [IF]
1.1       anton      51: .( Loading Gray ... Copyright 1990 Martin Anton Ertl; NO WARRANTY ) cr
1.2     ! pazsan     52: [THEN]
1.1       anton      53: 
                     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 )
1.2     ! pazsan    316:  2dup disjoint? ?not? warnings @ and if
1.1       anton     317:   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
1.2     ! pazsan    503:  rot 2dup and warnings @ and if
1.1       anton     504:   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 )
1.2     ! pazsan    575:  operand compute warnings @ and if
1.1       anton     576:   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 )
1.2     ! pazsan    605:  operand compute warnings @ and if
1.1       anton     606:   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: : || -) (- ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>