Return to gray.fs CVS log

Up to [gforth] / gforth

local variables
rewrote primitives2c.el in Forth (prims2x.el)
various small changes
Added Files:
 	from-cut-here gforth.el gforth.texi glocals.fs gray.fs
 	locals-test.fs prims2x.fs

    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: .( Loading Gray ... Copyright 1990 Martin Anton Ertl; NO WARRANTY ) cr
   51: 
   52: \ misc )
   53: : noop ;
   54: 
   55: 1 cells constant cell
   56: cell 8 * constant bits/cell \ !! implementation dependent )
   57: 
   58: : ?not? ( f -- f )
   59:  0= ;
   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 ;
  139: 
  140: : add-member \ u set -- )
  141: \ changes set to include u )
  142:  swap normalize-bit-addr
  143:  decode
  144:  over @ or swap ! ;
  145: 
  146: : singleton \ u -- set )
  147: \ makes a set that contains u and nothing else )
  148:  empty copy-set swap over add-member ;
  149: 
  150: : member? \ set u -- f )
  151: \ returns true if u is in set )
  152:  normalize-bit-addr
  153:  decode
  154:  swap @ and
  155:  0= ?not? ;
  156: 
  157: : binary-set-operation \ set1 set2 [w1 w2 -- w3] -- set )
  158: \ creates set from set1 and set2 by applying [w1 w2 -- w3] on members )
  159: \ e.g. ' or binary-set-operation  is the union operation )
  160:  here >r
  161:  cells/set @ 0 do >r
  162:   over @ over @ r@ execute ,
  163:   cell+ swap cell+ swap
  164:  r> loop
  165:  drop 2drop r> ;
  166: 
  167: : union1 \ set1 set2 -- set )
  168:  ['] or binary-set-operation ;
  169: 
  170: : intersection \ set1 set2 -- set )
  171:  ['] and binary-set-operation ;
  172: 
  173: : binary-set-test? \ set1 set2 [w1 w2 -- w3] -- f )
  174: \ returns true, if [w1 w2 -- w3] binary-set-operation returns empty )
  175: \ e.g. set1 set2 ' and binary-set-test?  is true, if set1 and set2
  176: \ are disjoint, i.e. they contain no common members )
  177:  >r true rot rot r>
  178:  cells/set @ 0 do >r
  179:   over @ over @ r@ execute 0= ?not? if
  180:    rot drop false rot rot
  181:   endif
  182:   cell+ swap cell+ swap
  183:  r> loop
  184:  drop 2drop ;
  185: 
  186: : notb&and \ w1 w2 -- w3 )
  187:  -1 xor and ;
  188: 
  189: : subset? \ set1 set2 -- f )
  190: \ returns true if every member of set1 is in set2 )
  191:  ['] notb&and binary-set-test? ;
  192: 
  193: : disjoint? \ set1 set2 -- f )
  194: \ returns true if set1 and set2 heve no common members )
  195:  ['] and binary-set-test? ;
  196: 
  197: : apply-to-members \ set [ u -- ] -- )
  198: \ executes [ u -- ] for every member of set )
  199:  cells/set @ bits/cell * 0 do
  200:   over i member? if
  201:    i over execute
  202:   endif
  203:  loop
  204:  2drop ;
  205: 
  206: : union \ set1 set2 -- set )
  207: \ just a little more space-efficient ) 
  208:  2dup subset? if
  209:   swap drop
  210:  else 2dup swap subset? if
  211:   drop
  212:  else
  213:   union1
  214:  endif endif ;
  215: 
  216: 
  217: \ tests )
  218: variable test-vector ' abort test-vector !
  219: \ here you should store the execution address of a word ( set -- f )
  220: \ that returns true if the token of the current symbol is in set )
  221: 
  222: : compile-test \ set -- )
  223:  postpone literal
  224:  test-vector @ compile, ;
  225: 
  226: 
  227: \ context management )
  228: 500 stack context-stack
  229: \ this stack holds the syntax-exprs currently being treated )
  230: \ enlarge it, if your grammar is large and complex )
  231: context-stack clear
  232: 
  233: : this \ -- syntax-expr )
  234: \ get current syntax-expr )
  235:  context-stack top ;
  236: 
  237: : new-context \ syntax-expr -- )
  238:  context-stack push ;
  239: 
  240: : old-context \ -- )
  241:  context-stack pop ;
  242: 
  243: 
  244: \ structures )
  245: : <builds-field \ n1 n2 -- n3 ) ( defining-word )
  246: \ n1 is the offset of the field, n2 its length, n3 the offset of the
  247: \ next field; creates a word that contains the offset )
  248:  create over , + ;
  249: 
  250: 0 constant struct
  251: \ initial offset
  252: 
  253: : context-var \ use: < offset > size context-var name < offset2 > )
  254: \ name returns the address of the offset field of "this" )
  255:  <builds-field \ n1 n2 -- n3 )
  256:  does> \ -- addr )
  257:   @ this + ;
  258: 
  259: : context-const \ use: < offset > context-const name < offset2 > )
  260: \ name returns the contents of the field of this at offset )
  261:  cell <builds-field \ n1 -- n2 )
  262:  does> \ -- n )
  263:   @ this + @ ;
  264: 
  265: 
  266: \ syntax-exprs )
  267: struct
  268:  aligned context-const methods
  269:         \ table of words applicable to the syntax-expr (a map)
  270:  1 context-var mark-propagate \ used to ensure that "propagate" is
  271:         \ called at least once for each syntax-expr )
  272:  1 context-var mark-pass2
  273:         \ make sure pass2 is called exactly once )
  274:  aligned cell context-var first-set
  275:         \ all tokens a nonempty path may begin with )
  276:         \ if it's equal to 0, the first-set has not been computed yet )
  277:  1 context-var maybe-empty
  278:         \ true if the syntax-expr can derive eps )
  279:  aligned cell context-var follow-set
  280: 	\ the tokens of the terminals that can follow the syntax-expr )
  281:  aligned 2 cells context-var source-location \ for error msgs )
  282: constant syntax-expr   \ length of a syntax-expr )
  283: 
  284: : make-syntax-expr \ map -- syntax-expr )
  285: \ allocate a syntax-expr and initialize it )
  286:  here swap , false c, false c,
  287:  align 0 , false c, align empty ,
  288: \ source location  !! implementation dependent )
  289: \ if you use blocks, use:
  290: \  blk @ >in @ 2,
  291: \ the following is just a dummy
  292:  0 loadline @ 2,
  293:  ;
  294: 
  295: 
  296: \ warnings and errors )
  297: : .in \ -- )
  298: \ !! implementation dependent )
  299: \ prints the info stored in source-location in a usable way )
  300: \ prints where the error happened )
  301:  source-location 2@ ." line" . drop ." :" ;
  302: 
  303:  
  304: : gray-error abort ;
  305: 
  306: : internal-error
  307:  cr .in ." you found a bug" gray-error ;
  308: 
  309: variable print-token ' . print-token !
  310: \ contains execution address of a word < token -- > to print a token )
  311: 
  312: : check-conflict \ set1 set2 -- )
  313: \ print the intersection of set1 and set2 if it isn't empty )
  314:  2dup disjoint? ?not? if
  315:   cr .in ." conflict:"
  316:   intersection print-token @ apply-to-members
  317:  else
  318:   2drop
  319:  endif ;
  320: 
  321: 
  322: \ methods and maps )
  323: : method \ use: < offset > method name < offset2 > )
  324: \ executes the word whose execution address is stored in the field
  325: \ at offset of a table pointed to by the "methods" field of "this" ) 
  326:  cell <builds-field \ n1 -- n2 )
  327:  does>
  328:   @ methods + @ execute ;
  329: 
  330: \ method table for syntax-exprs
  331: struct
  332:  method compute-method
  333:  method propagate-method
  334:  method generate-method
  335:  method pass2-method
  336: constant syntax-expr-methods
  337: 
  338: 
  339: \ general routines )
  340: : compute \ syntax-expr -- first-set maybe-empty )
  341: \ compute the first-set and maybe-empty of a syntax-expr )
  342: \ a bit of memoization is used here )
  343:  new-context
  344:  first-set @ 0= if
  345:   compute-method
  346:   maybe-empty c!
  347:   first-set !
  348:  endif
  349:  first-set @ maybe-empty c@
  350:  old-context ;
  351: 
  352: : get-first \ syntax-expr -- first-set )
  353:  compute drop ;
  354: 
  355: : check-cycle \ syntax-expr -- )
  356: \ just check for left recursion )
  357:  compute 2drop ;
  358: 
  359: : propagate \ follow-set syntax-expr -- )
  360: \ add follow-set to the follow set of syntax-expr and its children ) 
  361:  new-context
  362:  dup follow-set @ subset? ?not?  \ would everything stay the same
  363:  mark-propagate c@ ?not? or if   \ and was propagate here already
  364:   true mark-propagate c!       \ NO, do propagate
  365:   follow-set @ union dup follow-set !
  366:   propagate-method
  367:  else
  368:   drop
  369:  endif
  370:  old-context ;
  371: 
  372: : generate \ syntax-expr -- )
  373: \ this one gets things done )
  374:  new-context generate-method old-context ;
  375: 
  376: : pass2 \ syntax-expr -- )
  377: \ computes all necessary first sets, checks for left recursions
  378: \ and conflicts and generates code for rules )
  379:  new-context
  380:  mark-pass2 c@ ?not? if
  381:   true mark-pass2 c!
  382:   this check-cycle
  383:   pass2-method
  384:  endif
  385:  old-context ;
  386: 
  387: 
  388: \ main routine )
  389: : parser \ syntax-expr -- )
  390: \ use: syntax-expr parser xxx )
  391:  context-stack clear
  392:  empty over propagate
  393:  dup pass2
  394:  \ : should not be immediate
  395:  >r : r> generate postpone ; ;
  396: 
  397: 
  398: \ eps - empty syntax-expr )
  399: create eps-map
  400: ', internal-error
  401: ', drop
  402: ', noop
  403: ', noop
  404: 
  405: 
  406: create eps1
  407: \ the eps syntax-expr proper
  408:  eps-map make-syntax-expr
  409: drop
  410: 
  411: 
  412: : eps \ -- syntax-expr )
  413: \ just adjusts eps1 and returns it
  414:  eps1 new-context
  415:  empty first-set ! ( empty changes due to max-member )
  416:  empty follow-set !
  417:  true maybe-empty c!
  418:  old-context
  419:  eps1 ;
  420: 
  421: 
  422: \ terminals )
  423: \ a terminal is a syntax-expr with an extra field )
  424: syntax-expr
  425:  context-const check&next
  426:         \ contains address of a word < f -- > that checks
  427:         \ if f is true and reads the next terminal symbol )
  428: constant terminal-syntax-expr
  429: 
  430: : generate-terminal \ -- )
  431:  this get-first compile-test
  432:  check&next compile, ;
  433: 
  434: create terminal-map
  435: ', internal-error
  436: ', drop
  437: ', generate-terminal
  438: ', noop
  439: 
  440: : make-terminal \ first-set cfa -- syntax-expr )
  441:  terminal-map make-syntax-expr
  442:  new-context
  443:  ,
  444:  first-set !
  445:  this old-context ;
  446: 
  447: : terminal \ first-set cfa -- )
  448:  create make-terminal drop ;
  449: 
  450: 
  451: \ binary syntax-exprs )
  452: syntax-expr
  453:  context-const operand1
  454:  context-const operand2
  455: constant binary-syntax-expr
  456: 
  457: : make-binary \ syntax-expr1 syntax-expr2 map -- syntax-expr )
  458:  make-syntax-expr rot , swap , ;
  459: 
  460: : pass2-binary
  461:  operand1 pass2
  462:  operand2 pass2 ;
  463: 
  464: 
  465: \ concatenations )
  466: : compute-concatenation \ -- first maybe-empty )
  467:  operand1 compute dup if
  468:   drop
  469:   operand2 compute
  470:   >r union r>
  471:  endif ;
  472: 
  473: : propagate-concatenation \ follow-set -- )
  474:  operand2 compute if
  475:   over union
  476:  endif \ follow follow1 )
  477:  operand1 propagate
  478:  operand2 propagate ;
  479: 
  480: : generate-concatenation \ -- )
  481:  operand1 generate
  482:  operand2 generate ;
  483: 
  484: create concatenation-map
  485: ', compute-concatenation
  486: ', propagate-concatenation
  487: ', generate-concatenation
  488: ', pass2-binary
  489: 
  490: : concat \ syntax-expr1 syntax-expr2 -- syntax-expr )
  491:  concatenation-map make-binary ;
  492: \ this is the actual concatenation operator )
  493: \ but for safety and readability the parenthesised notation )
  494: \ is preferred )
  495: 
  496: 
  497: \ alternatives )
  498: : compute-alternative \ -- first maybe-empty )
  499:  operand1 compute
  500:  operand2 compute
  501:  rot 2dup and if
  502:   cr .in ." warning: two branches may be empty" endif
  503:  or >r union r> ;
  504: 
  505: : propagate-alternative \ follow -- )
  506:  dup operand1 propagate
  507:  operand2 propagate ;
  508: 
  509: : generate-alternative1 \ -- )
  510:  operand1 get-first compile-test
  511:  postpone if
  512:  operand1 generate
  513:  postpone else
  514:  operand2 generate
  515:  postpone endif ;
  516: 
  517: : generate-alternative2 \ -- )
  518:  operand1 get-first compile-test postpone ?not?
  519:  operand2 get-first compile-test postpone and
  520:  postpone if
  521:  operand2 generate
  522:  postpone else
  523:  operand1 generate
  524:  postpone endif ;
  525: 
  526: : generate-alternative \ -- )
  527:  operand1 compute if
  528:   generate-alternative2
  529:  else
  530:   generate-alternative1
  531:  endif
  532:  drop ;
  533: 
  534: : pass2-alternative \ -- )
  535:  this compute if
  536:   follow-set @ check-conflict
  537:  else
  538:   drop
  539:  endif
  540:  operand1 get-first operand2 get-first check-conflict
  541:  pass2-binary ;
  542: 
  543: create alternative-map
  544: ', compute-alternative
  545: ', propagate-alternative
  546: ', generate-alternative
  547: ', pass2-alternative
  548: 
  549: : alt \ syntax-expr1 syntax-expr2 -- syntax-expr )
  550:  alternative-map make-binary ;
  551: \ this is the actual alternative operator )
  552: \ but for safety and readability the parenthesised notation )
  553: \ is preferred )
  554: 
  555: 
  556: \ unary syntax-exprs )
  557: syntax-expr
  558:  context-const operand
  559: constant unary-syntax-expr
  560: 
  561: : make-unary \ syntax-expr1 map -- syntax-expr2 )
  562:  make-syntax-expr swap , ;
  563: 
  564: 
  565: \ options and repetitions )
  566: : pass2-option&repetition \ -- )
  567:  follow-set @ operand get-first check-conflict
  568:  operand pass2 ;
  569: 
  570: 
  571: \ options )
  572: : compute-option \ -- set f )
  573:  operand compute if
  574:   cr .in ." warning: unnessesary option" endif
  575:  true ;
  576: 
  577: : propagate-option \ follow -- )
  578:  operand propagate ;
  579: 
  580: : generate-option \ -- )
  581:  operand get-first compile-test
  582:  postpone if
  583:  operand generate
  584:  postpone endif ;
  585: 
  586: create option-map
  587: ', compute-option
  588: ', propagate-option
  589: ', generate-option
  590: ', pass2-option&repetition
  591: 
  592: : ?? \ syntax-expr1 -- syntax-expr2 )
  593:  option-map make-unary ;
  594: 
  595: 
  596: \ repetitions )
  597: : propagate-repetition \ follow-set -- )
  598:  operand get-first union operand propagate ;
  599: 
  600: 
  601: \ *-repetitions )
  602: : compute-*repetition \ -- set f )
  603:  operand compute if
  604:   cr .in ." warning: *repetition of optional term" endif
  605:  true ;
  606: 
  607: : generate-*repetition \ -- )
  608:  postpone begin
  609:  operand get-first compile-test
  610:  postpone while
  611:  operand generate
  612:  postpone repeat ;
  613: 
  614: create *repetition-map
  615: ', compute-*repetition
  616: ', propagate-repetition
  617: ', generate-*repetition
  618: ', pass2-option&repetition
  619: 
  620: : ** \ syntax-expr1 -- syntax-expr2 )
  621:  *repetition-map make-unary ;
  622: 
  623: 
  624: \ +-repetitions )
  625: : compute-+repetition \ -- set f )
  626:  operand compute ;
  627: 
  628: : generate-+repetition \ -- )
  629:  postpone begin
  630:  operand generate
  631:  operand get-first compile-test
  632:  postpone ?not? postpone until ;
  633: 
  634: create +repetition-map
  635: ', compute-+repetition
  636: ', propagate-repetition
  637: ', generate-+repetition
  638: ', pass2-option&repetition
  639: 
  640: : ++ \ syntax-expr1 -- syntax-expr2 )
  641:  +repetition-map make-unary ;
  642: 
  643: 
  644: \ actions )
  645: syntax-expr
  646:  context-const action
  647: constant action-syntax-expr
  648: 
  649: : generate-action \ syntax-expr -- )
  650:  action compile, ;
  651: 
  652: create action-map
  653: ', internal-error
  654: ', drop
  655: ', generate-action
  656: ', noop
  657: 
  658: : {{ \ -- syntax-expr addr colon-sys )
  659:  action-map make-syntax-expr
  660:  new-context
  661:  empty first-set !
  662:  true maybe-empty c!
  663:  this old-context
  664:  \ ?exec !csp )
  665:  here cell allot
  666:  :noname ;
  667: 
  668: : }} \ syntax-expr addr colon-sys -- syntax-expr )
  669:  \ ?csp )
  670:  postpone ;
  671:  swap !
  672: ; immediate
  673: 
  674: 
  675: \ nonterminals )
  676: syntax-expr
  677:  1 context-var mark-compute
  678:  aligned cell context-var rule-body \ in forth left side of rule )
  679:  cell context-var exec            \ cfa of code for rule )
  680: constant nt-syntax-expr
  681: 
  682: : get-body \ -- syntax-expr )
  683: \ get the body of the rule for the nt in "this" )
  684:   rule-body @ if
  685:    rule-body @
  686:   else
  687:    cr .in ." no rule for nonterminal" gray-error
  688:   endif ;
  689: 
  690: : compute-nt \ -- set f )
  691:  mark-compute c@ if
  692:   cr .in ." left recursion" gray-error
  693:  else
  694:   true mark-compute c!
  695:   get-body compute
  696:  endif ;
  697: 
  698: : propagate-nt \ follow-set -- )
  699:   get-body propagate ;
  700: 
  701: : code-nt \ -- )
  702: \ generates the code for a rule )
  703:  :noname 
  704:  get-body generate
  705:  postpone ;
  706:  exec ! ;
  707: 
  708: : generate-nt \ -- )
  709: \ generates a call to the code for the rule )
  710: \ since the code needs not be generated yet, an indirect call is used )
  711:  exec postpone literal
  712:  postpone @
  713:  postpone execute ;
  714: 
  715: : pass2-nt \ -- )
  716: \ apart from the usual duties, this pass2 also has to code-nt )
  717:  get-body pass2
  718:  code-nt ;
  719: 
  720: create nt-map
  721: ', compute-nt
  722: ', propagate-nt
  723: ', generate-nt
  724: ', pass2-nt
  725: 
  726: : make-nt \ syntax-expr -- nt )
  727:  nt-map make-syntax-expr
  728:  false c, align swap , 0 , ;
  729: 
  730: : <- \ use: syntax-expr <- xxx )
  731:      \ xxx: -- syntax-expr )
  732:  create make-nt drop ;
  733: 
  734: : nonterminal \ use: nonterminal xxx )
  735:  0 <- ;       \ forward declaration )
  736: 
  737: : rule \ syntax-expr nt -- )
  738: \ makes a rule )
  739:  new-context
  740:  rule-body @ if
  741:   .in ." multiple rules for nonterminal" gray-error endif
  742:  rule-body !
  743:  old-context ;
  744: 
  745: 
  746: \ syntactic sugar )
  747: : reduce \ 0 x1 ... [x2 x3 -- x4] -- x )
  748: \ e.g. 0 5 6 7 ' + reduce  =  5 6 7 + +  =  18 )
  749:  >r dup 0= if
  750:   ." no operand" abort
  751:  endif
  752:  begin
  753:   over 0= ?not? while
  754:   r@ execute
  755:  repeat \ 0 x )
  756:  swap drop r> drop ;
  757: 
  758: 7 constant concatenation-id
  759: : (- \ -- n 0 )
  760:  concatenation-id 0 ;
  761: : -) \ n 0 syntax-expr1 syntax-expr2 .. -- syntax-expr )
  762:  ['] concat reduce
  763:  swap concatenation-id ?pairs ;
  764: 
  765: 8 constant alternative-id
  766: : (| \ -- n 0 )
  767:  alternative-id 0 ;
  768: : |) \ n 0 syntax-expr1 syntax-expr2 .. -- syntax-expr )
  769:  ['] alt reduce
  770:  swap alternative-id ?pairs ;
  771: 
  772: : (( (| (- ;
  773: : )) -) |) ;
  774: : || -) (- ;