File:  [gforth] / gforth / gray.fs
Revision 1.3: download - view: text, annotated - select for diffs
Thu Nov 17 15:53:12 1994 UTC (29 years, 4 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
*Added:
* configure.bat configures on MS-DOS machines
* io-dos.h provides IO for MS-DOS
* makefile.dos is a GNU make Makefile for MS-DOS
*Changed:
* Merged gray/gforth and gray/gray4, added conditional compilation for
  gray ports (gforth and bigFORTH first)
* added gforth recognising string in environment
* added interpreter support for images (starts now with magic)
* changed make rule for ds2texi, so that it can run with Messy-DOS
* added SAVESYSTEM in dumpimage.fs
* fixed bug in Makefile for big endian systems (->configure)

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

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