File:  [gforth] / gforth / gray.fs
Revision 1.2: download - view: text, annotated - select for diffs
Thu Jul 7 14:59:22 1994 UTC (28 years ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Made gray warnings-off-compatible
Added (type) as primitive

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

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