Annotation of gforth/gray.fs, revision 1.5

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

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