File:  [gforth] / gforth / gray.fs
Revision 1.8: download - view: text, annotated - select for diffs
Sun Mar 9 15:16:49 2003 UTC (16 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-6-1, v0-6-0, HEAD
updated copyright years

    1: \ recursive descent parser generator )
    2: 
    3: \ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc.
    4: \ Copyright 1990, 1991, 1994 Martin Anton Ertl
    5: 
    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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   19: 
   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: 
   31: warnings @ [IF]
   32: .( Loading Gray ... Copyright 1990-1994 Martin Anton Ertl; NO WARRANTY ) cr
   33: [THEN]
   34: 
   35: \ misc )
   36: : noop ;
   37: 
   38: 1 cells constant cell
   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 )
   56: 
   57: : ?not? ( f -- f )
   58:  postpone 0= ; immediate
   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 ;
  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.
  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 )
  285: s" gforth" environment?
  286: [IF]  2drop \ clear gforth's version numbers )
  287:  aligned 2 cells context-var source-location \ for error msgs )
  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 )
  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 ,
  306: \ source location. !! replace the stuff until `;' with your stuff
  307: \ if you use blocks, use:
  308: \  blk @ >in @ 2,
  309: \ the following is just a dummy
  310: [ s" gforth" environment? ]
  311: [IF]  [ 2drop ]
  312:  0 sourceline# 2,
  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]
  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 )
  329: [ s" gforth" environment? ]
  330: [IF]  [ 2drop ]
  331:  source-location 2@ ." line" . drop ." :" ;
  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]
  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 )
  351:  2dup disjoint? ?not? warnings @ and if
  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
  538:  rot 2dup and warnings @ and if
  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 )
  610:  operand compute warnings @ and if
  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 )
  640:  operand compute warnings @ and if
  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>