File:
[gforth] /
gforth /
gray.fs
Revision
1.5:
download - view:
text,
annotated -
select for diffs
Wed Nov 29 20:20:35 1995 UTC (28 years, 4 months ago) by
anton
Branches:
MAIN
CVS tags:
v0-3-0,
v0-2-1,
v0-2-0,
gforth-0_1beta,
HEAD
replced tester.fs and coretest.fs with the new versions from John Hayes
make mostlyclean virtualclean added
Cache-flushing now works on the Alpha (other minor changes there)
configure now uses gcc by default and passes its GCC variable to the Makefile
introduced sourcefilename and sourceline# (and used them in many places).
1: \ recursive descent parser generator )
2:
3: \ Copyright 1990, 1991, 1994 Martin Anton Ertl
4:
5: \ This program is free software; you can redistribute it and/or modify
6: \ it under the terms of the GNU General Public License as published by
7: \ the Free Software Foundation; either version 2 of the License, or
8: \ (at your option) any later version.
9:
10: \ This program is distributed in the hope that it will be useful,
11: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
12: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13: \ GNU General Public License for more details.
14:
15: \ You should have received a copy of the GNU General Public License
16: \ along with this program; if not, write to the Free Software
17: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
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 sourceline# 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>