Annotation of gforth/gray.fs, revision 1.10

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

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