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