src/vm/jit/intrp/gray.fs

   1 \ recursive descent parser generator )
   2
   3 \ Copyright (C) 1995,1996,1997,2000,2003 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 : || -) (- ;