File:  [gforth] / gforth / gray.fs
Revision 1.13: download - view: text, annotated - select for diffs
Tue Jul 15 16:11:49 2008 UTC (11 years, 6 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright years
updated copyright-blacklist (added libltdl)
updated distributed files (don't distribute files without distribution terms)
added copyright to preforth.in and build-ec.in

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

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