Annotation of gforth/gray.fs, revision 1.6

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

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