1#|------------------------------------------------------------------------------
2|
3| NAME
4|
5| LR(1)AndLALR(1)ParserGenerator.lsp
6|
7|
8| DESCRIPTION
9|
10| LR parser generator which produces goto graphs and action and goto tables
11| for both LR(1) and LALR(1) grammars.
12|
13| It gives the same parsing tables (and conflicts) as UNIX's yacc
14| compiler-compiler, except that some states may be numbered in a different
15| order.
16|
17|
18| CALLING SEQUENCE
19|
20| Once you are in a Common Lisp interpreter, load this file using
21| your path:
22|
23| (load "LR(1)AndLALR(1)ParserGenerator.lsp")
24|
25| For an LR(1) grammar, type
26|
27| (parser-generator "grammar.dat" "parser.dat" :parser-type 'LR1)
28|
29| For an LALR(1) grammar, type
30|
31| (parser-generator "grammar.dat" "parser.dat")
32| or
33| (parser-generator "grammar.dat" "parser.dat" :parser-type 'LALR1)
34|
35| Parser-generator prints the warning message "Conflicts were detected" to
36| the console if any shift-reduce or reduce-reduce conflicts occur.
37|
38| For testing, you can also call
39|
40| (test-parser-generator)
41|
42| but you need to modify this function to your taste by setting the
43| file paths.
44|
45| Online documentation when you're in the lisp interpreter is given by the
46| standard documentation functions; for example,
47|
48| (apropos 'getHead)
49| => GETHEAD
50| GETHEADOFLISTUPTO (fbound)
51| (describe 'getHeadOfListUpTo)
52| COMMON-LISP-USER::GETHEADOFLISTUPTO
53| [symbol]
54|
55| GETHEADOFLISTUPTO names a compiled function:
56| Lambda-list: (ITEM LIST)
57| Derived type: (FUNCTION (T T) (VALUES LIST &OPTIONAL))
58| Documentation:
59| -------------------------------------------------------------------------------
60| |
61| | DESCRIPTION
62| |
63| | Return the list from the beginning up to but not including a given item,
64| | or the whole list if the item wasn't found.
65| ...
66| |-------------------------------------------------------------------------------
67| Source file: /Users/seanoconnor/ParserGeneratorAndParser/SourceCode/ParserGenerator/LR(1)AndLALR(1)ParserGenerator.lsp
68|
69| (describe '*productions*)
70| COMMON-LISP-USER::*PRODUCTIONS*
71| [symbol]
72|
73| *PRODUCTIONS* names a special variable:
74| Value: (((1) (S -> POLY MOD)) ((2) (MOD -> COMMA INTEGER))
75| ((3) (MOD -> EPSILON)) ((4) (POLY -> POLY + TERM))
76| ((5) (POLY -> TERM)) ((6) (TERM -> MULTIPLIER POWER))
77| ((7) (MULTIPLIER -> INTEGER)) ((8) (MULTIPLIER -> EPSILON))
78| ((9) (POWER -> X)) ((10) (POWER -> X ^ INTEGER))
79| ((11) (POWER -> EPSILON)))
80| Documentation:
81| List of productions of the unaugmented grammar.
82|
83|
84| INPUT FILES:
85|
86| grammar.dat A list of the productions of the grammar followed by
87| a list of terminal symbols. The file grammar.dat
88| shows an example. Epsilon productions are allowed.
89|
90| We assume the start symbol is the one which begins the first production
91| listed in grammar.dat.
92|
93| Don't include $ (the right endmarker) in the list of terminals. It is
94| added automatically by the program.
95|
96|
97|
98| OUTPUT FILES:
99|
100| parser.dat A numbered list of productions, followed by the LR(1)
101| or LALR(1) goto graph (i.e. set of items) of the
102| grammar and the action and goto tables. See the files
103| parser.dat and lalrparser.dat for examples.
104|
105| The LALR(1) tables are the same as the ones in the y.output file
106| generated by UNIX's yacc compiler-compiler running with the -v
107| option. The only difference is that some states may be numbered in
108| a different order.
109|
110| Shift-reduce or reduce-reduce conflicts are inserted into the action
111| and goto tables at the end of the line for the state in which they
112| occur.
113|
114| You can feed the action and goto tables to my Common Lisp LR parser
115| program "parser.lisp". The goto graph indicates the state of the
116| parse, just as in yacc's output, and can help to define the parsing
117| error messages.
118|
119|
120| AUTHOR
121|
122| Sean E. O'Connor 01 Jun 1989 Version 1.0
123| 11 Mar 2008 Version 5.6 released.
124|
125| LEGAL
126|
127| LR(1)AndLALR(1)ParserGenerator Version 5.6
128| An LR(1) and LALR(1) Parser Generator written in Common Lisp.
129|
130| Copyright (C) 1989-2024 by Sean Erik O'Connor. All Rights Reserved.
131|
132| This program is free software: you can redistribute it and/or modify
133| it under the terms of the GNU General Public License as published by
134| the Free Software Foundation, either version 3 of the License, or
135| (at your option) any later version.
136|
137| This program is distributed in the hope that it will be useful,
138| but WITHOUT ANY WARRANTY; without even the implied warranty of
139| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
140| GNU General Public License for more details.
141|
142| You should have received a copy of the GNU General Public License
143| along with this program. If not, see <http://www.gnu.org/licenses/>.
144|
145| The author's address is seanerikoconnor!AT!gmail!DOT!com
146| with the !DOT! replaced by . and the !AT! replaced by @
147|
148|
149| METHOD
150|
151| This is a Common Lisp implementation and will run under CLISP.
152| The software design is layered, the simpler list manipulation
153| utilities coming first, building up gradually to the specialized
154| and higher level parser functions. I've put lots of examples to
155| ease the pain.
156|
157| To construct the LR(1) goto graph (i.e. set of items) we use Algorithm
158| 4.9 of [Aho 86, pg. 231-232]. To create the cannonical LR(1) parsing
159| action and goto tables, algorithm 4.10 [Aho 86, pg. 234] is used.
160|
161| To construct the LALR(1) parsing tables, we use the much simpler
162| algorithm of [Aho 74, pg. 115] instead of algorithm 4.11 in [Aho 86,
163| pgs. 238-239].
164|
165| For computing FIRST (first derived terminals) we use algorithm 5.5 of
166| [Aho 72, pgs. 357-359].
167|
168| The function EFF (epsilon-free first derived terminals) is described
169| in [Aho 72, pg. 381]. We base the algorithm used in the function
170| first-terminals-of-symbol on exercise 5.2.19 [Aho 72, pg. 398]. The
171| modifications to algorithm 5.5 to make it compute EFF are my own and
172| are described in my notes.
173|
174| In the first version of this program, we used the algorithm for FIRST
175| of [Aho 86, pgs. 188-189]. But this algorithm does not always
176| terminate! In particular, it fails for the grammar,
177|
178| S -> A S | b
179| A -> S A | a
180|
181| of example 4.33 [Aho 86, pg. 272] by getting into the following
182| infinite loop: FIRST( S ) = FIRST( A ) = FIRST( S ) ... The algorithm
183| we use always terminates.
184|
185|
186| REFERENCES
187|
188| See http://www.seanerikoconnor.freeservers.com for a review of the
189| parsing theory behind this program.
190|
191|
192| [Aho 86] COMPILERS: PRINCIPLES, TECHNIQUES, AND TOOLS,
193| Alfred V. Aho, Ravi Sethi, and Jeffrey D. Ullman,
194| Addison-Wesley, 1986.
195|
196| [Aho 74] "LR Parsing", Alfred V. Aho and Stephen C. Johnson,
197| Computing Surveys, Vol. 6, No. 2, June 1974, pg. 99-124.
198|
199| [Aho 72] THE THEORY OF PARSING, TRANSLATION AND COMPILING, VOLUME 1:
200| PARSING, Alfred V. Aho and Jeffrey D. Ullman, Prentice-Hall,
201| 1972.
202|
203| BUGS
204|
205| Have the output look like the file y.output generated by yacc -v, or
206| eyacc -v.
207|
208| NOTES
209|
210| In Common Lisp, functions and variables don't share the same namespace.
211| So you need to tell LISP that the variable func is actually a function by using funcall.
212|
213| (defun apply-func (func arg1 arg2) (funcall func arg1 arg2))
214|
215| So you can't do the simpler expression (func arg1 arg2).
216|
217| It goes the other way too. You can't say (apply-func + 1 2) because + denotes a variable.
218| You have to tell LISP it's a function,
219|
220| (apply-func #'+ 1 2)
221|
222| which is a shorthand for
223|
224| (apply-func (function +) 1 2)
225|
226| first and car are synonyms as are rest and cdr
227| (null '()) => T
228| (null nil) => T
229| (null 'a) => NIL
230|
231| Optional arguments using keywords example:
232|
233| (defun doggie-looks( dog &key (nose-color 'red) (hair-color 'white))
234| (list 'my dog 'has 'a nose-color 'nose 'and hair-color 'hair))
235|
236| * (doggie-looks 'husky) => (MY HUSKY HAS A RED NOSE AND WHITE HAIR)
237| * (doggie-looks 'husky :nose-color 'black) => (MY HUSKY HAS A BLACK NOSE AND WHITE HAIR)
238|
239+-------------------------------------------------------------------------------|#
240
241
242; ==============================================================================
243; | Constants |
244; ==============================================================================
245
246; Use the naming convention +variable-name+ to denote constants.
247
248(defconstant +initial-hash-table-size+ 100
249"-------------------------------------------------------------------------------
250| Initial hash table length. Don't worry, lisp hash tables are extensible
251| at run time.
252--------------------------------------------------------------------------------"
253)
254
255
256
257(defconstant +hash-value-upper-limit+ 65536
258"-------------------------------------------------------------------------------
259| Upper limit on hash value on core of items.
260|-------------------------------------------------------------------------------"
261)
262
263
264
265; ==============================================================================
266; | Dynamically Bound (i.e. Global) Variables |
267; ==============================================================================
268
269; Use the naming convention *variable-name* to denote them as global.
270
271(defvar *productions* nil
272"-------------------------------------------------------------------------------
273| List of productions of the unaugmented grammar (without S' -> S).
274| e.g. ( (S -> S |a| S |b| / EPSILON) )
275| which represents S -> S a S b, S -> EPSILON
276|-------------------------------------------------------------------------------"
277)
278
279
280
281(defvar *has-epsilon-productions* nil
282"-------------------------------------------------------------------------------
283| T if we have any epsilon productions of the form A -> EPSILON, but NIL otherwise.
284--------------------------------------------------------------------------------"
285)
286
287
288
289(defvar *terminals* nil
290"-------------------------------------------------------------------------------
291| List of terminal symbols for the grammar. e.g. ( |a| |b| )
292|-------------------------------------------------------------------------------"
293)
294
295
296
297(defvar *first-derived-terminals* nil
298"-------------------------------------------------------------------------------
299| Hash table containing the first derived terminals for each grammar symbol.
300|-------------------------------------------------------------------------------"
301)
302
303
304
305(defvar *epsilon-free-first-derived-terminals* nil
306"-------------------------------------------------------------------------------
307| Hash table containing the epsilon-free first derived terminals for each grammar symbol.
308|-------------------------------------------------------------------------------"
309)
310
311
312
313(defvar *goto-graph* nil
314"---------------------------------------------------------------------------------------------------------------
315| Goto graph of the LR(1) or LALR(1) grammar of the form
316|
317| (
318| ( ------+
319| (6 |a| 4) <-- Transition in Goto graph from |
320| state 6 to state 4 on symbol a. +------ List of graph edges and transitions.
321| (1 |a| 2) <-- Transition from state 1 to state 2 |
322| on a. |
323| ) ------+
324|
325| ) --------+
326| ( 0 <-- State number 0. |
327| 3668 <-- Hash value of core of items. |
328| ( |
329| (SP -> DOT S |,| $) ----+ |
330| ( S -> DOT S |a| S |b| |,| $) | |
331| ( S -> DOT EPSILON |,| $) +---- Set of items for state 0. |
332| ( S -> DOT S |a| S |b| |,| |a|) | |
333| ( S -> DOT EPSILON |,| |a|) | |
334| ) ----+ |
335| ) +-- List of sets of items.
336| |
337| ( 2 <-- State number 2. |
338| 5168 <-- Hash values of core of items. |
339| ( |
340| (S -> S |a| DOT S |b| |,| $) ----+ |
341| (S -> S |a| DOT S |b| |,| |a|) | |
342| (S -> DOT S |a| S |b| |,| |b|) | |
343| (S -> DOT EPSILON |,| |b|) +-- Set of items for state 2. |
344| (S -> DOT S |a| S |b| |,| |a|) | |
345| (S -> DOT EPSILON |,| |a|) ----+ |
346| ) |
347| ) |
348| ) --------+
349| )
350|--------------------------------------------------------------------------------------------------------------"
351)
352
353
354
355(defvar *action-table* nil
356"-------------------------------------------------------------------------------
357| Action table of the form,
358|
359| (
360| ( (0) <-- state number
361| (
362| ($ (R 2)) <-- reduce action on end of input $
363| (|a| (R 2)) <-- reduce action on symbol a.
364| (DEFAULT (ERROR)) <-- otherwise must be error
365| )
366| )
367|
368| ( (1) <-- next line of action table.
369| (
370| ($ (ACC NIL)) <-- accept action on end of input $
371| (|a| (S 2)) <-- shift action on symbol a.
372| (DEFAULT (ERROR))
373| )
374| )
375| )
376|-------------------------------------------------------------------------------"
377)
378
379
380
381(defvar *goto-table* nil
382"-------------------------------------------------------------------------------
383| Goto table of the form,
384|
385| (
386| ( (0) <-- state number
387| (
388| (S 1) <-- transition to state 1 on symbol S
389| (DEFAULT (ERROR)) <-- otherwise error
390| )
391| )
392|
393| ( (2)
394| (
395| (S 3)
396| (DEFAULT (ERROR))
397| )
398| )
399| )
400|-------------------------------------------------------------------------------"
401)
402
403
404
405(defvar *conflicts* nil
406"-------------------------------------------------------------------------------
407| Set to true if we have any shift-reduce or reduce-reduce conflicts.
408|-------------------------------------------------------------------------------"
409)
410
411
412
413; ==============================================================================
414; | General Purpose List Processing Primitives |
415; ==============================================================================
416
417(defun getHeadOfListUpTo( item list )
418
419"-------------------------------------------------------------------------------
420|
421| DESCRIPTION
422|
423| Return the list from the beginning up to but not including a given item,
424| or the whole list if the item wasn't found.
425|
426| CALLING SEQUENCE
427|
428| (getHeadOfListUpTo item list)
429| => New list of all symbols before the item.
430|
431| EXAMPLE
432|
433| (getHeadOfListUpTo 'rat '(you are a rat fink)) => (YOU ARE A)
434| (getHeadOfListUpTo 'cat '(you are a rat fink)) => (YOU ARE A RAT FINK)
435| (getHeadOfListUpTo 'rat '(rat) ) => nil
436| (getHeadOfListUpTo 'rat nil ) => nil
437|
438|-------------------------------------------------------------------------------"
439
440 (cond ( (null list) nil) ; Empty list.
441 ( (equal (first list) item) nil) ; List = (item). Return ().
442
443 ; Recurse.
444 ( (cons (first list)
445 (getHeadOfListUpTo item (rest list)))))
446)
447
448
449
450
451(defun removeItemFromList( item list &key (equalityTest #'equal) )
452
453"-------------------------------------------------------------------------------
454|
455| DESCRIPTION
456|
457| Remove all occurences of a given item from a list. Test item equality
458| with a function.
459|
460| CALLING SEQUENCE
461|
462| (removeItemFromList item list :equalityTest testFunction)
463| => New list with all occurrences of symbol taken out.
464|
465| testFunction The name of the function which tests if two symbols are
466| equal. It should be a function of two arguments which
467| returns T if the symbols are equal and NIL otherwise.
468| It defaults to #'equal.
469|
470| EXAMPLE
471|
472| (removeItemFromList '(rat bad) '( (cat good) (rat good)))
473| => ( (CAT GOOD) (RAT GOOD) )
474|
475| (defun sameAnimal( s1 s2 ) (equal (first s1) (first s2)))
476| (funcall #'sameAnimal '(rat good) '(rat bad)) => T
477|
478| (removeItemFromList '(rat bad) '( (cat good) (rat good))
479| :equalityTest #'sameAnimal)
480| => ( (CAT GOOD) )
481|
482+-------------------------------------------------------------------------------"
483
484 (cond ( (null list) nil) ; Nothing in the list.
485
486 ( (funcall equalityTest ; First item matches.
487 item (first list)) ; according to equality
488 ; test.
489
490 (removeItemFromList item (rest list) ; Discard it and remove
491 ; all other
492 :equalityTest equalityTest)) ; items too.
493
494 ( t (cons (first list) ; First item does not match.
495
496 (removeItemFromList item ; Add it back and remove the
497 (rest list) ; remaining items.
498 :equalityTest equalityTest))))
499)
500
501
502
503(defun itemInList( element list &key (test #'equal) )
504
505"-------------------------------------------------------------------------------
506|
507| DESCRIPTION
508|
509| Find out if an atom or a list is a member of a given list. Test for
510| equality with a function.
511|
512| CALLING SEQUENCE
513|
514| (itemInList item list :equalityTest testFunc)
515| => T if item is in list; NIL if not.
516|
517| testFunc The name of the function which tests if two symbols are
518| equal. It should be a function of two arguments which
519| returns T if the symbols are equal and NIL otherwise.
520| test defaults #'equal.
521|
522| EXAMPLE
523|
524| (itemInList '(hot dog) '((cool cat) (cool dog)) ) => NIL
525|
526| (defun sameAnimal( s1 s2 ) (equal (first s1) (first s2)))
527|
528| (itemInList '(hot dog) '((cool cat) (cool dog))
529| :equalityTest #'sameAnimal) => T
530|
531+---------------------------------------------------------------------------------"
532
533(cond ( (null list) nil) ; Not in the list.
534
535 ( (funcall test element (first list)) ; First item matches.
536
537 t)
538
539 ( t (itemInList element (rest list) ; Try again on rest of list.
540 :test test)))
541)
542
543
544
545(defun positionInList( item list )
546
547"-------------------------------------------------------------------------------
548|
549| DESCRIPTION
550|
551| Find the position of an item in a list.
552|
553| CALLING SEQUENCE
554|
555| (positionInList item list)
556|
557| item Atom or list to be found.
558|
559| list Any list.
560|
561| Returns: The position of item in the list or NIL if it is not there.
562| The first position is zero.
563|
564| EXAMPLE
565|
566| (positionInList '(winter mute) '(I am (winter mute))) => 2
567| (positionInList 'ratfinn '(Who you ? ratfink ?)) => NIL
568|
569+---------------------------------------------------------------------------------"
570
571 (cond ( (null list) nil ) ; Nothing in the list.
572
573 ( (equal item (first list)) 0) ; list = (item ...), return
574 ; position = 0.
575
576 ; If the item is in the rest of the list, find its position in the
577 ; rest of the list, then add 1 to fix up the count.
578
579 ( (itemInList item (rest list))
580 (1+ (positionInList item (rest list))))
581
582 ( t nil )) ; Item was not found ---
583 ; return NIL.
584)
585
586
587
588(defun insertItemIntoList( item L &key (test #'equal) (precedence nil) )
589
590"------------------------------------------------------------------------------
591|
592| DESCRIPTION
593|
594| If an object isn't already in the list, add it to the end. If it is,
595| overwrite it (see below).
596|
597| CALLING SEQUENCE
598|
599| (insertItemIntoList item L :test test :precedence precedence)
600|
601| item An atom or list.
602|
603| test The test to perform to see if an item is is in the list.
604| It is the name of a function with two arguments which should
605| return T if its arguments are equal and NIL if they aren't.
606| The test function defaults to #'equal if omitted.
607|
608| precedence The test function to perform to say which object has the
609| higher precedence when both are equal. The one of higher
610| precedence is kept. An item of higher precedence overwrites
611| its lower precedence brother in the list. The function should
612| be of the form (precedence x y), returning the object of
613| higher precedence. Defaults to NIL (Don't care).
614|
615| L List of non-duplicated elements (according to equality test
616| specified above).
617|
618| Returns: Unchanged list if item is already in it. Otherwise, returns
619| the list L with the item in the last position.
620|
621| EXAMPLE
622|
623| (insertItemIntoList '(rat good) '( (rat bad) (bat good) ) )
624| => ((RAT BAD) (BAT GOOD) (RAT GOOD))
625| We compared for exact equality, so the new item gets inserted.
626|
627|
628| (defun sameAnimal( s1 s2 ) (equal (first s1) (first s2)))
629|
630| (insertItemIntoList '(rat good)
631| '((rat bad) (bat good))
632| :test #'sameAnimal)
633| => ((RAT BAD) (BAT GOOD))
634| Rats are already in the list, so don't add the item.
635|
636| (defun good-always-wins( x y ) (cond ((equal (second x) 'good) x) (t y)))
637|
638| (insertItemIntoList '(rat good) '( (rat bad) (bat good) )
639| :test #'sameAnimal
640| :precedence 'good-always-wins) =>
641| => ((RAT GOOD) (BAT GOOD))
642| Rats are already in the list, but we now compare equal items further
643| to see which have higher precedence.
644|
645|------------------------------------------------------------------------------"
646
647(cond ( (null L) (list item)) ; Nothing there. Add the item.
648
649 ( (funcall test item (first L)) ; Item is already in the list.
650
651 ; Of the two equal objects --- item and the first element in the list ---
652 ; keep the one of higher precedence.
653
654 (if (not (null precedence))
655
656 (cons (funcall precedence item (first L)) (rest L))
657
658 L)) ; Don't care about precedence, so
659 ; keep the original list.
660
661 ( t (cons (first L)
662 (insertItemIntoList item
663 (rest L)
664 :test test
665 :precedence precedence))))
666)
667
668
669
670(defun combine( list1 list2 &key (test #'equal) (precedence nil) )
671
672"------------------------------------------------------------------------------
673|
674| DESCRIPTION
675|
676| Take the union of two lists. We can do a generalized test for
677| equality of elements. Also, if two elements are equal, we can
678| keep the one of higher precedence.
679|
680| CALLING SEQUENCE
681|
682| (combine list1 list2 :test test :precedence precedence)
683|
684| list1 Arbitrary lists.
685|
686| list2
687|
688| item An atom or list.
689|
690| test The test to perform to see if an item is is in the list.
691| It is the name of a function with two arguments which should
692| return T if its arguments are equal and NIL if they aren't.
693| The test function defaults to #'equal if omitted.
694|
695| precedence The test function to perform to say which object has the
696| higher precedence when both are equal. The one of higher
697| precedence is kept. An item of higher precedence overwrites
698| its lower precedence brother in the list. The function should
699| be of the form (precedence x y), returning the object of higher
700| precedence. precedence defaults to NIL (Don't care).
701|
702| Returns: The set theoretic union of the two lists, except that we
703| always keep the element of highest precedence when two
704| elements are the same.
705|
706| EXAMPLE
707|
708| (combine '((rat good) (rat awful)) '((rat bad) (bat good)))
709| => ((RAT AWFUL) (RAT GOOD) (RAT BAD) (BAT GOOD))
710|
711| (defun sameAnimal( s1 s2 ) (equal (first s1) (first s2)))
712|
713| (combine '((rat good) (rat awful)) '((rat bad) (bat good))
714| :test #'sameAnimal)
715| => ((RAT AWFUL) (BAT GOOD))
716|
717| (defun good-always-wins( x y ) (cond ((equal (second x) 'good) x) (t y)))
718|
719| (combine '((rat good) (rat awful)) '((rat bad) (bat good))
720| :test #'sameAnimal
721| :precedence #'good-always-wins) => ((RAT GOOD) (BAT GOOD))
722|
723|------------------------------------------------------------------------------"
724
725; Successively add elements from both lists to nil, eliminating
726; duplicated or low precedence items. If both lists are nil, dolist
727; does not loop, and we return nil.
728
729(let ( (new-list nil) )
730
731 (dolist (item (union list1 list2 :test #'equal))
732
733 (setq new-list (insertItemIntoList item new-list
734 :test test :precedence precedence)))
735new-list)
736)
737
738
739
740
741; ------------------------------------------------------------------------------
742; | core-of-item! |
743; ------------------------------------------------------------------------------
744;
745; DESCRIPTION
746;
747; Get the core of an item: the item but without the lookahead.
748;
749; CALLING SEQUENCE
750;
751; (core-of-item! item)
752;
753; item [A -> alpha . beta , gamma ]
754;
755; Returns: [A -> alpha . beta]
756;
757; EXAMPLE
758;
759; (core-of-item! '(sandwich -> bread meat DOT bread |,| knife))
760; => (SANDWICH -> BREAD MEAT DOT BREAD)
761;
762; ------------------------------------------------------------------------------
763
764(defun core-of-item!( item )
765
766 (getHeadOfListUpTo '|,| item)
767
768)
769
770
771
772
773; ------------------------------------------------------------------------------
774; | element-of-item? |
775; ------------------------------------------------------------------------------
776;
777; DESCRIPTION
778;
779; Find out if an item or its core is in a set of items.
780;
781; CALLING SEQUENCE
782;
783; (element-of-item item set-of-items compare-type)
784;
785; item [A -> alpha . beta , gamma]
786;
787; set-of-items ... [A' -> alpha' . beta' , gamma'] ...
788;
789; compare-type Whether to compare the whole item or only its core.
790;
791; Returns: if compare-type = 'core then T if A = A', alpha =
792; alpha', beta = beta'. gamma need not equal gamma'.
793; if compare-type = item then T if in addition,
794; gamma = gamma', and NIL otherwise.
795;
796; EXAMPLE
797;
798; (element-of-item? '(eat -> living death |,| scum)
799; '( (eat -> hot fudge |,| scum)
800; (eat -> living death |,| wimp))
801; 'core) => T
802;
803; But (element-of-item? . . . 'item) => NIL
804;
805; ------------------------------------------------------------------------------
806
807(defun element-of-item?( item set-of-items compare-type )
808
809(cond ((null set-of-items) nil) ; No items, no match.
810
811 ( (if (equal compare-type 'core)
812
813 (equal (core-of-item! item) ; Core of first item
814 (core-of-item! (first set-of-items))) ; was found.
815
816 (equal item (first set-of-items))) ; First items match.
817
818 T) ; First item is in set
819
820 ( t (element-of-item? item ; Continue to search.
821 (rest set-of-items)
822 compare-type)))
823)
824
825
826
827
828; ------------------------------------------------------------------------------
829; | contained-in-item? |
830; ------------------------------------------------------------------------------
831;
832; DESCRIPTION
833;
834; Find if the first set of items is contained in the second
835; set of items. Alternatively, find out if the cores of the
836; first set of items are contained in the cores of the second set.
837;
838; CALLING SEQUENCE
839;
840; (contained-in-item? set-of-items1 set-of-items2 compare-type)
841;
842; set-of-items1 First and ...
843;
844; set-of-items2 ... second sets of of items.
845;
846; compare-type Type of comparison: 'item or 'core.
847;
848; Returns: T if compare-type = 'item and the first set of items
849; is contained in the second set of items.
850; T if compare-type = 'core and the cores of the first
851; set of items are contained in the cores of the second
852; set of items.
853; EXAMPLE
854;
855; (contained-in-item? '( (a -> b DOT c |,| x)
856; (e -> f DOT |,| g))
857;
858; '( (a -> b DOT c |,| h)
859; (e -> f DOT |,| i)
860; (f -> g DOT h i |,| j) )
861; 'core ) => T
862;
863; However, (contained-in-item? . . . 'item) => NIL
864;
865; ------------------------------------------------------------------------------
866
867(defun contained-in-item?( set-of-items1 set-of-items2 compare-type )
868
869(cond ((null set-of-items1) T) ; Null set is contained in
870 ; every set.
871
872 ((element-of-item? (first set-of-items1) ; First item (or its core)
873 set-of-items2 ; is in the second set.
874 compare-type)
875
876 (if (null (rest set-of-items1)) ; No other elements in first set
877
878 T
879
880 (contained-in-item? (rest set-of-items1) ; Are the remaining
881 set-of-items2 ; items of the first
882 compare-type))) ; set in the second?
883
884 ( t nil )) ; First element of first set isn't in
885 ; the second set: first set can't be
886 ; contained in second set.
887)
888
889
890
891
892; ------------------------------------------------------------------------------
893; | equal-sets-of-items? |
894; ------------------------------------------------------------------------------
895;
896; DESCRIPTION
897;
898; Check if two sets of items are the same (or have the same core).
899; You can also use it to check if two arbitrary lists contain the
900; same elements.
901;
902; CALLING SEQUENCE
903;
904; (equal-sets-of-items? set-of-items1 set-of-items2 :compare-type type)
905;
906; set-of-items1 First and ...
907;
908; set-of-items2 ... second sets of of items.
909;
910; type Optional argument defaulting to 'item.
911;
912; Returns: T for type = 'item if both sets of items are identical.
913; T for type = 'core if both sets of items have the same
914; cores.
915; METHOD
916;
917; Two sets of items are the same if each one is contained within the
918; other. They have the same core if the core of one is contained in
919; the core of the other and vice-versa. We can't just test for equality
920; because the order of the items could be different.
921;
922; EXAMPLE
923;
924; (equal-sets-of-items? '( (a -> b DOT c |,| d) )
925; '( (a -> b DOT c |,| d) )) => T
926;
927; (equal-sets-of-items? '( (a -> b DOT c |,| d) )
928; '( (a -> b DOT c |,| e) )
929; :compare-type 'core ) => T
930;
931; (equal-sets-of-items? '(a (b c) d) '(d a (b c))) => T
932;
933; ------------------------------------------------------------------------------
934
935(defun equal-sets-of-items?( set-of-items1 set-of-items2
936 &key (compare-type 'item))
937
938(and (contained-in-item? set-of-items1 set-of-items2 compare-type)
939 (contained-in-item? set-of-items2 set-of-items1 compare-type))
940)
941
942
943
944
945; ==============================================================================
946; | Helper Functions on Symbols and Productions |
947; ==============================================================================
948
949; ------------------------------------------------------------------------------
950; | terminal? |
951; ------------------------------------------------------------------------------
952;
953; DESCRIPTION
954;
955; Find out if a symbol of the grammar is a terminal.
956;
957; CALLING SEQUENCE
958;
959; (terminal? symbol)
960;
961; *terminals* Global list of terminal symbols for the grammar.
962;
963; symbol: A grammar symbol
964;
965; Returns: T if the symbol is a terminal symbol, NIL otherwise.
966; EPSILON is not a terminal.
967;
968; EXAMPLE
969;
970; Let *terminals* = (c C),
971;
972; (terminal? '|c| ) => T
973; (terminal? 'C ) => NIL
974; (terminal? 'EPSILON) => NIL
975;
976; ------------------------------------------------------------------------------
977
978(defun terminal?( symbol )
979
980(itemInList symbol *terminals*)
981)
982
983
984
985
986; ------------------------------------------------------------------------------
987; | nonterminal? |
988; ------------------------------------------------------------------------------
989;
990; DESCRIPTION
991;
992; Find out if a symbol of the grammar is a nonterminal.
993;
994; CALLING SEQUENCE
995;
996; (nonterminal? symbol)
997;
998; symbol: A grammar symbol
999;
1000; Returns: T if the symbol is a nonterminal symbol, NIL otherwise.
1001; EPSILON is not a non-terminal.
1002;
1003; EXAMPLE
1004;
1005; (nonterminal? 'C ) => T
1006; (nonterminal? '|c| ) => NIL
1007; (nonterminal? 'EPSILON ) => NIL
1008;
1009; ------------------------------------------------------------------------------
1010
1011(defun nonterminal?( symbol )
1012
1013(and (not (equal symbol 'EPSILON))
1014 (not (terminal? symbol)))
1015
1016)
1017
1018
1019
1020
1021; ------------------------------------------------------------------------------
1022; | derives-leading-terminal? |
1023; ------------------------------------------------------------------------------
1024;
1025; DESCRIPTION
1026;
1027; Check if a production derives a leading terminal.
1028;
1029; CALLING SEQUENCE
1030;
1031; (derives-leading-terminal? production)
1032;
1033; production: A production of the form X -> a Y
1034;
1035; Returns: T if a is a terminal, NIL otherwise.
1036;
1037; EXAMPLE
1038;
1039; (derives-leading-terminal? '(C -> |c| C)) => T
1040; (derives-leading-terminal? '(C -> C C)) => NIL
1041;
1042; ------------------------------------------------------------------------------
1043
1044(defun derives-leading-terminal?( production )
1045
1046(terminal? (third production))
1047
1048)
1049
1050
1051
1052
1053; ------------------------------------------------------------------------------
1054; | derives-leading-nonterminal? |
1055; ------------------------------------------------------------------------------
1056;
1057; DESCRIPTION
1058;
1059; Check if a production derives a leading nonterminal.
1060;
1061; CALLING SEQUENCE
1062;
1063; (derives-leading-nonterminal? production)
1064;
1065; production: A production of the form X -> a Y
1066;
1067; Returns: T if a is a terminal, NIL otherwise.
1068;
1069; EXAMPLE
1070;
1071; (derives-leading-nonterminal? '(C -> C C)) => T
1072; (derives-leading-nonterminal? '(C -> |c| C)) => NIL
1073;
1074; ------------------------------------------------------------------------------
1075
1076(defun derives-leading-nonterminal?( production )
1077
1078(nonterminal? (third production))
1079
1080)
1081
1082
1083
1084
1085; ------------------------------------------------------------------------------
1086; | valid-production? |
1087; ------------------------------------------------------------------------------
1088;
1089; DESCRPTION
1090;
1091; Find out if a production starts with the given symbol.
1092;
1093; CALLING SEQUENCE
1094;
1095; (valid-production? symbol production)
1096;
1097; symbol Grammar symbol
1098;
1099; production A production of the form X -> alpha
1100;
1101; Returns: T if X = symbol, NIL otherwise.
1102;
1103; EXAMPLE
1104;
1105; (valid-production? 'C '(C -> |c| C)) => T
1106; (valid-production? 'S '(C -> |c| C)) => NIL
1107;
1108; ------------------------------------------------------------------------------
1109
1110(defun valid-production?( symbol production )
1111
1112(equal symbol (first production))
1113
1114)
1115
1116
1117
1118; ------------------------------------------------------------------------------
1119; | reduction? |
1120; ------------------------------------------------------------------------------
1121;
1122; DESCRIPTION
1123;
1124; Find out if an item calls for a reduction.
1125;
1126; CALLING SEQUENCE
1127;
1128; (reduction? item)
1129;
1130; item Any item [A -> alpha . beta , gamma].
1131;
1132; Returns: T if the item is of the form [A -> alpha . , gamma ]
1133; and NIL otherwise.
1134; Note [A -> alpha . EPSILON , gamma] =
1135; [A -> alpha . , gamma], to this is a reduction too.
1136;
1137; EXAMPLE
1138;
1139; (reduction? '(C -> |d| DOT |,| |c|)) => T
1140; (reduction? '(C -> |d| DOT |e| |,| |c|)) => NIL
1141; (reduction? '(C -> |d| DOT EPSILON |,| |c|)) => T
1142;
1143; ------------------------------------------------------------------------------
1144
1145(defun reduction?( item )
1146
1147; Get everything between the dot and comma. It will be empty for a reduction.
1148
1149(let ((between-dot-and-comma (getHeadOfListUpTo 'DOT (reverse (getHeadOfListUpTo '|,| item )))))
1150
1151 (or (null between-dot-and-comma)
1152 (equal (first between-dot-and-comma) 'epsilon)))
1153)
1154
1155
1156
1157
1158; ------------------------------------------------------------------------------
1159; | is-accept? |
1160; ------------------------------------------------------------------------------
1161;
1162; DESCRIPTION
1163;
1164; Find out if an item calls for an accept.
1165;
1166; CALLING SEQUENCE
1167;
1168; (is-accept? item)
1169;
1170; item Arbitrary item [A -> alpha . beta , gamma].
1171;
1172; *productions* Global list of productions for our grammar.
1173;
1174; Returns: T if the item is of the form [S' -> S . , $]
1175; S is the start symbol --- the left hand side symbol
1176; of the first production. S' (represented as SP) is
1177; the extra start symbol of the augmented grammar.
1178; EXAMPLE
1179;
1180; *productions* => ( (S -> C C) (C -> |c| C) (C -> |d|) )
1181; (is-accept? '(SP -> S DOT |,| $)) => T
1182;
1183; ------------------------------------------------------------------------------
1184
1185(defun is-accept?( item )
1186
1187 (equal item `(SP -> ,(first (first *productions*)) DOT |,| $))
1188
1189)
1190
1191
1192
1193
1194; ------------------------------------------------------------------------------
1195; | symbol-after-dot! |
1196; ------------------------------------------------------------------------------
1197;
1198; DESCRIPTION
1199;
1200; Find the symbol following the dot in an item.
1201;
1202;
1203; CALLING SEQUENCE
1204;
1205; (symbol-after-dot! item)
1206;
1207; item Item of the form [A -> alpha . B beta , gamma ]
1208;
1209; Returns: The symbol B, or NIL if there is none.
1210;
1211; EXAMPLE
1212;
1213; (symbol-after-dot! '(frogs -> are DOT keen |,| you bet)) => KEEN
1214; (symbol-after-dot! '(toads -> are not)) => NIL
1215;
1216; ------------------------------------------------------------------------------
1217
1218(defun symbol-after-dot!( item )
1219
1220(cond ( (null item) nil ) ; No dot was ever found.
1221
1222; Return the symbol after the dot or nil if there is none.
1223
1224 ( (equal (first item) 'DOT) (second item) )
1225
1226 ( T (symbol-after-dot! (rest item)))) ; Keep
1227 ; looking.
1228)
1229
1230
1231
1232
1233; ------------------------------------------------------------------------------
1234; | terminal-after-dot? |
1235; ------------------------------------------------------------------------------
1236;
1237; DESCRIPTION
1238;
1239; Check if an item has a terminal symbol after the dot.
1240;
1241; CALLING SEQUENCE
1242;
1243; (terminal-after-dot? item)
1244;
1245; item Any item [A -> alpha . beta delta , gamma]
1246;
1247; Returns: T if beta is a terminal symbol and NIL otherwise.
1248;
1249; EXAMPLE
1250;
1251; (terminal-after-dot? '(C -> C DOT |c| |,| $ )) => T
1252; (terminal-after-dot? '(C -> C DOT C |,| $ )) => NIL
1253;
1254; ------------------------------------------------------------------------------
1255
1256(defun terminal-after-dot?( item )
1257
1258(if (null (symbol-after-dot! item)) ; No symbol after the dot.
1259
1260 nil
1261
1262 (terminal? (symbol-after-dot! item))) ; Check if the symbol after the dot
1263 ; is a terminal.
1264)
1265
1266
1267
1268
1269
1270; ------------------------------------------------------------------------------
1271; | epsilon-production? |
1272; ------------------------------------------------------------------------------
1273;
1274; DESCRIPTION
1275;
1276; Find out if a production derives only epsilon.
1277;
1278; CALLING SEQUENCE
1279;
1280; (epsilon-production? production)
1281;
1282; production [A -> alpha].
1283;
1284; Returns: T if alpha = EPSILON.
1285;
1286; EXAMPLE
1287;
1288; (epsilon-production? '(A -> EPSILON)) => T
1289;
1290; ------------------------------------------------------------------------------
1291
1292(defun epsilon-production?( production )
1293
1294(and (equal (length production) 3)
1295 (equal (third production) 'EPSILON))
1296)
1297
1298
1299
1300
1301; ------------------------------------------------------------------------------
1302; | same-symbol? |
1303; ------------------------------------------------------------------------------
1304;
1305; DESCRIPTION
1306;
1307; Test if two tagged grammar symbols are equal.
1308;
1309; CALLING SEQUENCE
1310;
1311; (same-symbol? s1 s2)
1312;
1313; s1, s2 Tagged grammar symbols of the form (symbol tag), with
1314; tag = 'EPSILON-FREE or NIL.
1315;
1316; Returns T if the symbol parts are equal.
1317
1318; EXAMPLE
1319;
1320; (same-symbol? '(a NIL) '(a EPSILON-FREE)) => T
1321; (same-symbol? '(a EPSILON-FREE) '(b EPSILON-FREE)) => NIL
1322;
1323; ------------------------------------------------------------------------------
1324
1325(defun same-symbol?( s1 s2 )
1326
1327(equal (first s1) (first s2))
1328
1329)
1330
1331
1332
1333; ------------------------------------------------------------------------------
1334; | first-alternate! |
1335; ------------------------------------------------------------------------------
1336;
1337; DESCRIPTION
1338;
1339; Return the first alternate of a production.
1340;
1341; CALLING SEQUENCE
1342;
1343; (first-alternate! rhs)
1344;
1345; rhs The right hand side of a production containing alternates:
1346; alpha / beta / ...
1347;
1348; Returns: alpha
1349;
1350; EXAMPLE
1351;
1352; (first-alternate! '(A B / C D)) => (A B)
1353;
1354; ------------------------------------------------------------------------------
1355
1356(defun first-alternate!( rhs )
1357
1358 (getHeadOfListUpTo '/ rhs)
1359)
1360
1361
1362
1363
1364; ------------------------------------------------------------------------------
1365; | all-but-first-alternate! |
1366; ------------------------------------------------------------------------------
1367;
1368; DESCRIPTION
1369;
1370; Return all but the first alternates of of a production.
1371;
1372; CALLING SEQUENCE
1373;
1374; (all-but-first-alternate! rhs)
1375;
1376; rhs The right hand side of a production, with alternates
1377; (alpha / beta / ...)
1378;
1379; Returns: (beta / ...) or NIL if rhs has only one alternate:
1380; (alpha)
1381;
1382; EXAMPLE
1383;
1384; (all-but-first-alternate! '(B C / D E / F)) => (D E / F)
1385; (all-but-first-alternate! '(B C)) => NIL
1386; (all-but-first-alternate! '(B C / D E / F)) => (D E / F)
1387;
1388; ------------------------------------------------------------------------------
1389
1390(defun all-but-first-alternate!( rhs )
1391
1392; Get the first alternate, then strip it off.
1393
1394 (nthcdr (1+ (length (getHeadOfListUpTo '/ rhs))) rhs)
1395)
1396
1397
1398
1399
1400; ------------------------------------------------------------------------------
1401; | production-rhs! |
1402; ------------------------------------------------------------------------------
1403;
1404; DESCRIPTION
1405;
1406; Return the right hand side of a production.
1407;
1408; CALLING SEQUENCE
1409;
1410; (production-rhs! production)
1411;
1412; production Production of the form [A -> alpha].
1413;
1414; Returns: alpha
1415;
1416; EXAMPLE
1417;
1418; (production-rhs! '(sandwich -> bread meat bread)) => (BREAD MEAT BREAD)
1419;
1420; ------------------------------------------------------------------------------
1421
1422(defun production-rhs!( production )
1423
1424(nthcdr 2 production)
1425)
1426
1427
1428
1429
1430; ------------------------------------------------------------------------------
1431; | string-before-comma! |
1432; ------------------------------------------------------------------------------
1433;
1434; DESCRIPTION
1435;
1436; Return the symbols between the first symbol after the dot and the comma
1437; in an item.
1438;
1439; CALLING SEQUENCE
1440;
1441; (string-before-comma! item)
1442;
1443; item An item of the form [A -> alpha . B beta , gamma]
1444;
1445; Returns: beta or NIL if beta is empty.
1446;
1447; EXAMPLE
1448;
1449; (string-before-comma! '(A -> + DOT B * + + |,| a)) => (* + +)
1450; (string-before-comma! '(A -> + DOT B |,| a)) => NIL
1451; (string-before-comma! '(A -> + DOT |,| a)) => NIL
1452;
1453; ------------------------------------------------------------------------------
1454
1455(defun string-before-comma!( item )
1456
1457(let ((temp (reverse (getHeadOfListUpTo 'DOT (reverse item))))) ; Get everything past the
1458 ; dot.
1459
1460 (if (equal (first temp) '|,|) ; No symbol after the dot.
1461
1462 nil
1463
1464 (getHeadOfListUpTo '|,| (rest temp)))) ; Get everything past the
1465 ; symbol after the dot
1466 ; (which could be nil).
1467)
1468
1469
1470
1471
1472; ------------------------------------------------------------------------------
1473; | lookahead-of! |
1474; ------------------------------------------------------------------------------
1475;
1476; DESCRIPTION
1477;
1478; Return the lookahead symbol of an item.
1479;
1480; CALLING SEQUENCE
1481;
1482; (lookahead-of! item)
1483;
1484; item [A -> alpha . beta , gamma]
1485;
1486; Returns: gamma
1487;
1488; EXAMPLE
1489;
1490; (lookahead-of! '(SP -> DOT |d| |,| |c|)) => |c|
1491;
1492; ------------------------------------------------------------------------------
1493
1494(defun lookahead-of!( item )
1495
1496(cond ( (null item) nil ) ; Nothing at all.
1497
1498 ( (equal (first item) '|,|) (second item)) ; Lookahead (or nothing)
1499 ; follows the comma.
1500
1501 ( T (lookahead-of! (rest item)))) ; Search
1502)
1503
1504
1505
1506
1507; ------------------------------------------------------------------------------
1508; | split-up-production |
1509; ------------------------------------------------------------------------------
1510;
1511; DESCRIPTION
1512;
1513; Break a single production with alternates into separate productions.
1514;
1515; CALLING SEQUENCE
1516;
1517; (split-up-production production)
1518;
1519; production [A -> alpha / beta / ... ]
1520;
1521; Returns: The list [A -> alpha], [A -> beta], ...
1522;
1523; EXAMPLE
1524;
1525; (split-up-production '(A -> B C / D E / F))
1526; => ( (A -> B C) (A -> D E) (A -> F) )
1527;
1528; ------------------------------------------------------------------------------
1529
1530(defun split-up-production( production )
1531
1532; production = A -> B | C | ...
1533
1534(let ( (head `(,(first production)
1535 ,(second production))) ; Get the left hand side: A ->
1536
1537 (tail (nthcdr 2 production)) ; Get the right hand side: B | C | ...
1538
1539 (new-productions nil)
1540 (new-production nil) )
1541
1542 (loop (if (null tail) (return))
1543
1544 (setq new-production ; A -> B, A -> C, etc.
1545 (append head
1546 (first-alternate! tail)))
1547
1548; Strip off next list up to bar.
1549
1550 (setq tail (all-but-first-alternate! tail))
1551
1552 (setq new-productions (append new-productions (list new-production))))
1553
1554new-productions)
1555)
1556
1557
1558
1559
1560; ------------------------------------------------------------------------------
1561; | split-up-productions |
1562; ------------------------------------------------------------------------------
1563;
1564; DESCRIPTION
1565;
1566; Break a list of productions with alternates into a list of separate
1567; productions.
1568;
1569; CALLING SEQUENCE
1570;
1571; (split-up-productions production-list)
1572;
1573; production-list [A -> alpha / beta / ... ] [B -> gamma / delta ...] ...
1574;
1575; Returns: The list [A -> alpha], [A -> beta], ... [B -> gamma]
1576; [B -> delta], ...
1577; EXAMPLE
1578;
1579; (split-up-productions '((S -> C C) (C -> |c| C / |d|)))
1580; => ((S -> C C) (C -> |c| C) (C -> |d|))
1581;
1582; ------------------------------------------------------------------------------
1583
1584(defun split-up-productions( production-list )
1585
1586(let ((new-production-list nil))
1587
1588 (dolist (production production-list) ; Split up each production.
1589
1590 (setq new-production-list ; Add it to the growing list.
1591 (append new-production-list
1592 (split-up-production production))))
1593
1594 new-production-list)
1595)
1596
1597
1598
1599
1600; ------------------------------------------------------------------------------
1601; | make-item |
1602; ------------------------------------------------------------------------------
1603;
1604; DESCRIPTION
1605;
1606; Create an item with a leading dot from a production and a
1607; lookahead symbol.
1608;
1609; CALLING SEQUENCE
1610;
1611; (make-item production lookahead)
1612;
1613; production Any production [A -> alpha]
1614;
1615; lookahead Any lookahead symbol b.
1616;
1617; Returns: The item [A -> . alpha , b]
1618;
1619; EXAMPLE
1620;
1621; (make-item '(A -> B C) '|d|) => (A -> DOT B C |,| |d|)
1622;
1623; ------------------------------------------------------------------------------
1624
1625(defun make-item( production lookahead )
1626
1627`( ,(first production) ; Get the first symbol A.
1628 ,(second production) ; Get the arrow ->
1629 DOT ; Add the leading dot.
1630 ,@(nthcdr 2 production) ; Add the right hand side of the production.
1631 |,| ; Comma.
1632 ,lookahead ) ; Add the lookahead symbol last.
1633)
1634
1635
1636
1637
1638; ------------------------------------------------------------------------------
1639; | move-dot-right |
1640; ------------------------------------------------------------------------------
1641;
1642; DESCRIPTION
1643;
1644; Move the dot in an item to the right if possible.
1645;
1646; CALLING SEQUENCE
1647;
1648; (move-dot-right item)
1649;
1650; item [A -> alpha . X beta, b]
1651;
1652; Returns: [A -> alpha X . beta, b]
1653; If the item is of the form [A -> alpha . , b], we return it
1654; unchanged.
1655;
1656; EXAMPLE
1657;
1658; (move-dot-right '( A -> B DOT C |,| D)) => ( A -> B C DOT |,| D)
1659; (move-dot-right '( A -> B C DOT |,| D)) => ( A -> B C |,| DOT D)
1660;
1661; ------------------------------------------------------------------------------
1662
1663(defun move-dot-right( item )
1664
1665(cond ( (null item) nil )
1666
1667 ( (equal (first item) 'DOT) ; The item begins with a dot.
1668
1669 (if (null (second item)) ; item = DOT
1670
1671 item ; Leave it alone.
1672
1673; Move the dot right over the next symbol. We change [ . b c d ] to [b . c d].
1674
1675 `( ,(second item) ; b
1676 DOT ; Add a dot.
1677 ,@(nthcdr 2 item)))) ; The remainder, (c d).
1678
1679 ( t (cons (first item) ; Item doesn't begin with a dot.
1680
1681 (move-dot-right (rest item)))))
1682)
1683
1684
1685
1686
1687; ------------------------------------------------------------------------------
1688; | create-augmenting-item |
1689; ------------------------------------------------------------------------------
1690;
1691; DESCRIPTION
1692;
1693; Create the accept item of the augmented grammar.
1694;
1695; CALLING SEQUENCE
1696;
1697; (create-augmenting-item)
1698;
1699; *productions* List of productions for this grammar.
1700;
1701; Returns: The item (SP -> DOT S |,| $) where S is the start
1702; symbol: the left hand side nonterminal of the first
1703; production S -> alpha.
1704; EXAMPLE
1705;
1706; *productions* => ((E -> E T) (E -> id) (T -> id))
1707;
1708; (create-augmenting-item) => (SP -> DOT E |,| $)
1709;
1710; ------------------------------------------------------------------------------
1711
1712(defun create-augmenting-item()
1713
1714; Assume the first symbol of the left hand side of the first production is
1715; the start symbol.
1716
1717`(SP -> DOT ,(first (first *productions*)) |,| $)
1718
1719)
1720
1721
1722
1723
1724; ------------------------------------------------------------------------------
1725; | find-grammar-symbols |
1726; ------------------------------------------------------------------------------
1727;
1728; DESCRIPTION
1729;
1730; Create all the grammar symbols (terminal and nonterminal) by looking
1731; at the list of productions.
1732;
1733; CALLING SEQUENCE
1734;
1735; (find-grammar-symbols)
1736;
1737; Returns: List of grammar symbols. Note we don't include the endmarker,
1738; $ or the null string, EPSILON.
1739;
1740; EXAMPLE
1741;
1742; For productions S -> C C, S -> |c| C | d,
1743;
1744; (find-grammar-symbols) => (S C |c| |d|)
1745;
1746; ------------------------------------------------------------------------------
1747
1748(defun find-grammar-symbols()
1749
1750(let ((symbols nil))
1751
1752; Scan through all productions, collecting all terminals and nonterminals.
1753
1754 (dolist (production *productions*)
1755
1756 (setq symbols (append symbols (removeItemFromList '-> production))))
1757
1758
1759; Remove duplicated elements which occur later in the sequence. Remove any
1760; EPSILON's introduced by epsilon productions, A -> EPSILON.
1761
1762(removeItemFromList 'EPSILON (remove-duplicates symbols :from-end T)))
1763
1764)
1765
1766
1767; ------------------------------------------------------------------------------
1768; | item-to-production |
1769; ------------------------------------------------------------------------------
1770;
1771; DESCRIPTION
1772;
1773; Change an item to a production by removing the dot and lookahead part.
1774;
1775; CALLING SEQUENCE
1776;
1777; (item-to-production item)
1778;
1779; item [A -> alpha . beta , gamma]
1780;
1781; Returns: [A -> alpha beta]
1782;
1783; EXAMPLE
1784;
1785; (item-to-production '(rat -> on DOT rye |,| tail)) => (RAT -> ON RYE)
1786;
1787; ------------------------------------------------------------------------------
1788
1789(defun item-to-production( item )
1790
1791(removeItemFromList 'DOT (getHeadOfListUpTo '|,| item )))
1792
1793
1794
1795
1796; ------------------------------------------------------------------------------
1797; | production-number |
1798; ------------------------------------------------------------------------------
1799;
1800; DESCRIPTION
1801;
1802; Return the number of a production.
1803;
1804; CALLING SEQUENCE
1805;
1806; (production-number production)
1807;
1808; production Any production.
1809; *production* List of productions for the grammar.
1810;
1811; Returns: The number of the production in the list *productions*.
1812; The first production is numbered 1. Recall alternates
1813; of productions were split off into separate productions
1814; in the function load-input-and-initialize.
1815; EXAMPLE
1816;
1817; (production-number '(S -> C C)) => 1
1818;
1819; ------------------------------------------------------------------------------
1820
1821(defun production-number( production )
1822
1823(1+ (positionInList production *productions*))
1824
1825)
1826
1827
1828
1829
1830; ==============================================================================
1831; | First Derived Symbol Utilities |
1832; ==============================================================================
1833; | |
1834; | NOTE: In this section we will be using the sample grammar, |
1835; | |
1836; | S -> A B |
1837; | A -> C a | EPSILON |
1838; | B -> b |
1839; | C -> c | EPSILON |
1840; | |
1841; | with terminal symbols a b c |
1842; | |
1843; ==============================================================================
1844
1845
1846; ------------------------------------------------------------------------------
1847; | tag-symbol |
1848; ------------------------------------------------------------------------------
1849;
1850; DESCRIPTION
1851;
1852; Convert a grammar symbol A to tagged form (A NIL).
1853;
1854; CALLING SEQUENCE
1855;
1856; (tag-symbol symbol)
1857;
1858; symbol A grammar symbol.
1859;
1860; Returns: The list, (symbol NIL).
1861;
1862; EXAMPLE
1863;
1864; (tag-symbol 'a) => (A NIL)
1865;
1866; ------------------------------------------------------------------------------
1867
1868(defun tag-symbol( s )
1869
1870 `(,s NIL)
1871
1872)
1873
1874
1875
1876; ------------------------------------------------------------------------------
1877; | flag-epsilon-free! |
1878; ------------------------------------------------------------------------------
1879;
1880; DESCRIPTION
1881;
1882; Flag a tagged grammar symbol as coming from an epsilon-free derivation.
1883;
1884; CALLING SEQUENCE
1885;
1886; (flag-epsilon-free! tagged-symbol)
1887;
1888; tagged-symbol Tagged grammar symbol of the form (symbol tag).
1889;
1890; Returns: (symbol NIL)
1891;
1892; EXAMPLE
1893;
1894; (flag-epsilon-free! '(a nil)) => (A EPSILON-FREE)
1895;
1896; ------------------------------------------------------------------------------
1897
1898(defun flag-epsilon-free!( s )
1899
1900 `(,(first s) epsilon-free)
1901
1902)
1903
1904
1905
1906; ------------------------------------------------------------------------------
1907; | epsilon-free-only |
1908; ------------------------------------------------------------------------------
1909;
1910; DESCRIPTION
1911;
1912; Return only tagged grammar symbols with epsilon-free derivations.
1913;
1914; CALLING SEQUENCE
1915;
1916; (epsilon-free-only list)
1917;
1918; list List of tagged symbols, ( (s1 tag1) ... )
1919;
1920; Returns: Only those symbols in the list for which
1921; tag = 'epsilon-free
1922; EXAMPLE
1923;
1924; (epsilon-free-only '((a NIL) (b EPSILON-FREE) (c NIL)))
1925; => ((B EPSILON-FREE))
1926;
1927; ------------------------------------------------------------------------------
1928
1929(defun epsilon-free-only( l )
1930
1931(cond ( (null l) nil )
1932
1933 ( (equal (second (first l)) ; Keep this symbol: It is epsilon-free.
1934 'epsilon-free)
1935 (cons (first l) (epsilon-free-only (rest l))))
1936
1937 ( t (epsilon-free-only (rest l)))) ; Discard this symbol.
1938)
1939
1940
1941
1942; ------------------------------------------------------------------------------
1943; | untag-list |
1944; ------------------------------------------------------------------------------
1945;
1946; DESCRIPTION
1947;
1948; Remove the tags from a list of tagged grammar symbols.
1949;
1950; CALLING SEQUENCE
1951;
1952; (untag-list list)
1953;
1954; list List of tagged grammar symbols,
1955; ((a NIL) (b EPSILON-FREE) ... ).
1956;
1957; Returns: Untagged symbols, (a b ...).
1958;
1959; EXAMPLE
1960;
1961; (untag-list '( (a NIL) (b EPSILON-FREE) (c nil))) => (A B C)
1962;
1963; ------------------------------------------------------------------------------
1964
1965(defun untag-list( list )
1966
1967 (mapcar #'car list)
1968
1969)
1970
1971
1972
1973; ------------------------------------------------------------------------------
1974; | flag-non-epsilon-free |
1975; ------------------------------------------------------------------------------
1976;
1977; DESCRIPTION
1978;
1979; Flag a list of tagged symbols as being all not epsilon-free derived.
1980;
1981; CALLING SEQUENCE
1982;
1983; (flag-epsilon-free tagged-list)
1984;
1985; tagged-list Tagged list of grammar symbols, ( (s1 tag1) ... )
1986;
1987; Returns: List with all tags set to NIL, ( (s1 NIL) ... )
1988;
1989; EXAMPLE
1990;
1991; (flag-non-epsilon-free '((a epsilon-free) (b nil) (c epsilon-free))) =>
1992; ((A NIL) (B NIL) (C NIL))
1993;
1994; ------------------------------------------------------------------------------
1995
1996(defun flag-non-epsilon-free( s )
1997
1998 ; Apply an anonymous function to all elements of the list.
1999 (mapcar #'(lambda (x) (cons (first x) '(NIL))) s)
2000)
2001
2002
2003
2004; ------------------------------------------------------------------------------
2005; | precedence |
2006; ------------------------------------------------------------------------------
2007;
2008; DESCRIPTION
2009;
2010; Compare two tagged symbols and return the one of higher precedence.
2011;
2012; CALLING SEQUENCE
2013;
2014; (precedence s1 s2)
2015;
2016; s1, s2 Tagged grammar symbols of the form (s1 tag1), (s2 tag2) with
2017; tag1, tag2 = 'EPSILON-FREE or NIL.
2018;
2019; Returns (s1 tag1) if tag1 = EPSILON-FREE, (s2 tag2) otherwise.
2020;
2021; EXAMPLE
2022;
2023; (precedence '(a NIL) '(b EPSILON-FREE)) => (B EPSILON-FREE)
2024; (precedence '(a EPSILON-FREE) '(b EPSILON-FREE)) => (A EPSILON-FREE)
2025;
2026; ------------------------------------------------------------------------------
2027
2028(defun precedence( s1 s2 )
2029
2030(cond ((equal (second s1) 'epsilon-free) s1) ; Return the epsilon-free one.
2031 ( t s2))
2032)
2033
2034
2035
2036; ------------------------------------------------------------------------------
2037;
2038; DESCRIPTION
2039;
2040; Return the derived leading terminal of a production.
2041; e.g. the derived leading terminal a of the production X -> a Y
2042;
2043; CALLING SEQUENCE
2044;
2045; (derived-leading-terminal production)
2046;
2047; production [A -> a beta]
2048;
2049; Returns: a
2050;
2051; EXAMPLE
2052;
2053; (derived-leading-terminal '(A -> + B A)) =>
2054;
2055; ------------------------------------------------------------------------------
2056
2057(defun derived-leading-terminal( production )
2058
2059(third production)
2060
2061)
2062
2063
2064
2065; ------------------------------------------------------------------------------
2066; | first-terminals-of-rhs |
2067; ------------------------------------------------------------------------------
2068;
2069; DESCRIPTION
2070;
2071; Find the ith approximation of the first derived terminals of the right
2072; hand side of a production.
2073;
2074; CALLING SEQUENCE
2075;
2076; (first-terminals-of-rhs rhs hash-table)
2077;
2078; rhs The right hand side Y1 ... Yn of the production.
2079;
2080; hash-table The current approximation to the FIRST() function for
2081; the non-terminals. FIRST of the terminals is already exact.
2082;
2083; Returns: The first derived terminals of the string Y1 ... Yn. We
2084; tag the epsilon-free first derived symbols.
2085;
2086; METHOD
2087;
2088; F ( X ) = F( Y1 ) + ... + F( Yn )
2089; i 1 1
2090;
2091; EXAMPLE
2092;
2093; Assume we have just called initial-first-derived-terminals, so that
2094; hash-table contains the zeroth approximation to FIRST.
2095;
2096; (first-terminals-of-rhs '(A B) hash-table) => ( (b NIL) )
2097; because S => A B => EPSILON b => b, which is not in EFF().
2098;
2099; ------------------------------------------------------------------------------
2100
2101(defun first-terminals-of-rhs( rhs hash-table )
2102
2103; Compute FIRST( Y1 ) and FIRST( Y1 ) - EPSILON.
2104
2105(let* ((first-terms (gethash (first rhs) hash-table))
2106 (first-terms-minus-epsilon (removeItemFromList '(EPSILON NIL) first-terms
2107 :equalityTest 'same-symbol?)))
2108 (cond ( (null rhs) NIL)
2109
2110; If we have the case A -> alpha beta with FIRST( alpha ) = {}, we want to
2111; return {}.
2112
2113 ( (null first-terms) nil )
2114
2115
2116; If epsilon is in FIRST( Y1 ) , add all non-epsilon symbols in FIRST( Y1 )
2117; to the first derived terminals in the rest of the list. Flag all these new
2118; symbols as epsilon-derived. If there are duplicated symbols, keep only
2119; the epsilon-free ones.
2120
2121 ( (itemInList '(EPSILON NIL) first-terms :test 'same-symbol?)
2122
2123 (combine first-terms-minus-epsilon
2124 (flag-non-epsilon-free
2125 (first-terminals-of-rhs (rest rhs) hash-table))
2126 :test 'same-symbol? :precedence 'precedence))
2127
2128
2129; Otherwise, Y1 has only non-epsilon terminals. Return FIRST( Y1 ). Whether
2130; these symbols are epsilon-free depends on their previous flags.
2131
2132 ( t first-terms )))
2133)
2134
2135
2136
2137; ------------------------------------------------------------------------------
2138; | update-first-derived-function |
2139; ------------------------------------------------------------------------------
2140;
2141; DESCRIPTION
2142;
2143; Update the first derived terminals function to create a new version.
2144;
2145; CALLING SEQUENCE
2146;
2147; (update-first-derived-function hash-table update-hash-table)
2148;
2149; hash-table Old hash table.
2150;
2151; update-hash-table Changes to the old table. If an entry is NIL,
2152; it indicates no change is to be made to hash-table.
2153;
2154; Returns: Updated hash-table of the first derived terminals.
2155;
2156; EXAMPLE
2157;
2158; (update-first-derived-function) => Updated hash table.
2159;
2160; ------------------------------------------------------------------------------
2161
2162(defun update-first-derived-function( hash-table update-hash-table )
2163
2164; Update only changes to nonterminals because the FIRST of a terminal symbol
2165; does not change.
2166
2167(dolist (symbol (find-grammar-symbols))
2168
2169(if (nonterminal? symbol)
2170
2171 (if (not (null (gethash symbol update-hash-table)))
2172
2173 (setf (gethash symbol hash-table)
2174 (gethash symbol update-hash-table)))))
2175)
2176
2177
2178
2179; ------------------------------------------------------------------------------
2180; | initial-first-derived-terminals |
2181; ------------------------------------------------------------------------------
2182;
2183; DESCRIPTION
2184;
2185; The zeroth approximation to the first derived terminals function.
2186; It is exact for all terminals and epsilon.
2187;
2188; CALLING SEQUENCE
2189;
2190; (initial-first-derived-terminals hash-table :type type)
2191;
2192; *terminals* List of all the terminal symbols including the endmarker $
2193;
2194; hash-table Empty, but allocated hash table.
2195;
2196; Returns: Hash table of the zeroth approximation to the first
2197; derived terminals function for every grammar symbol.
2198; Epsilon-free first derived symbols are tagged with the
2199; flag 'epsilon-free.
2200;
2201; EXAMPLE
2202;
2203; (setq F0 (make-hash-table :size 100))
2204; (setq F0 (initial-first-derived-terminals F0))
2205; (gethash 'A F0) => ( (EPSILON NIL) )
2206;
2207; Grammar FIRST Grammar FIRST
2208; Symbol Symbol
2209; ------------------- -------------------
2210; S NIL |a| ((|a| EPSILON-FREE))
2211; A ((EPSILON NIL)) |b| ((|b| EPSILON-FREE))
2212; B ((|b| EPSILON-FREE)) |c| ((|c| EPSILON-FREE))
2213; C ((|c| EPSILON-FREE) EPSILON ((EPSILON NIL))
2214; (EPSILON NIL)) $ (($ EPSILON-FREE))
2215;
2216; |c| is flagged as being in EFF( C ). EPSILON is in FIRST( C ) but
2217; not in EFF( C ).
2218;
2219; ------------------------------------------------------------------------------
2220
2221(defun initial-first-derived-terminals( hash-table )
2222
2223(let ( (first-symbols nil)
2224 (nonterm nil)
2225 (new-symbol nil) )
2226
2227; FIRST( X ) = { (X 'epsilon-free) } if X is a terminal.
2228
2229 (dolist (terminal *terminals*)
2230
2231 (setf (gethash terminal hash-table)
2232 (list (flag-epsilon-free! (tag-symbol terminal)))))
2233
2234
2235; FIRST( EPSILON ) = { (EPSILON NIL) }.
2236
2237 (setf (gethash 'EPSILON hash-table) (list (tag-symbol 'EPSILON)))
2238
2239
2240; Every nonterminal appears as the left hand side of some production.
2241; Thus we can scan through the productions to define FIRST( A ) for every
2242; nonterminal A.
2243; Compute the zeroth approximation to FIRST(). Look for a production of
2244; the form A -> a alpha, where a is a nonterminal. Find the entry for
2245; A in the table, and add a to it.
2246; We tag productions of the form A -> EPSILON as not being epsilon-free
2247; derivations.
2248
2249 (dolist (production *productions*)
2250
2251 (cond ( (or (derives-leading-terminal? production)
2252 (epsilon-production? production))
2253
2254 (setq nonterm (first production))
2255
2256 (setq first-symbols (gethash nonterm hash-table))
2257
2258; Get a or EPSILON.
2259 (setq new-symbol
2260 (tag-symbol (derived-leading-terminal production)))
2261
2262; Flag a as an epsilon-free derivation, but EPSILON as not.
2263
2264 (if (not (epsilon-production? production))
2265 (setq new-symbol (flag-epsilon-free! new-symbol)))
2266
2267; Add a to FIRST( A ).
2268
2269 (setq first-symbols
2270 (insertItemIntoList new-symbol first-symbols))
2271
2272 (setf (gethash nonterm hash-table) first-symbols))))
2273 hash-table)
2274)
2275
2276
2277
2278; ------------------------------------------------------------------------------
2279; | create-all-first-derived-terminals |
2280; ------------------------------------------------------------------------------
2281;
2282; DESCRIPTION
2283;
2284; Create a hash table of all first derived terminals for every grammar
2285; symbol.
2286;
2287; CALLING SEQUENCE
2288;
2289; (create-all-first-derived-terminals)
2290;
2291; Returns: A hash table of the first derived terminals for every grammar
2292; symbol, including EPSILON and $. Flag the epsilon-free
2293; derived terminals.
2294; METHOD
2295;
2296; Successive approximation by transitive closure.
2297;
2298; EXAMPLE
2299;
2300; (setq h (create-all-first-derived-terminals)) => #<Hash-Table 8EDA53>
2301;
2302; (gethash 'S h) => ((|a| NIL) (|c| EPSILON-FREE) (|b| NIL))
2303; i.e. FIRST( S ) = { |a| |b| |c| }, but EFF( S ) = { |c| }
2304;
2305;
2306; Grammar FIRST Grammar FIRST
2307; Symbol Symbol
2308; -------------------------------- --------------------------------
2309; S ((|a| NIL) |a| ((|a| EPSILON-FREE))
2310; (|b| NIL) |b| ((|a| EPSILON-FREE))
2311; (|c| EPSILON-FREE)) |c| ((|c| EPSILON-FREE))
2312; A ((EPSILON NIL) EPSILON ((EPSILON NIL))
2313; (|a| NIL) $ (($ EPSILON-FREE))
2314; (|c| EPSILON-FREE))
2315; B ((|b| EPSILON-FREE))
2316; C ((|c| EPSILON-FREE)
2317; (EPSILON NIL))
2318;
2319; ------------------------------------------------------------------------------
2320
2321(defun create-all-first-derived-terminals()
2322
2323; Initialize the hash table. The size is extensible at run time.
2324
2325(let ( (hash-table (make-hash-table :size +initial-hash-table-size+))
2326 (update-hash-table (make-hash-table :size +initial-hash-table-size+))
2327 (nonterm nil)
2328 (new-first-symbols nil)
2329 (old-first-symbols nil)
2330 (change-flag T) )
2331
2332; Create the zeroth approximation to FIRST(), accurate for all terminals.
2333
2334 (initial-first-derived-terminals hash-table)
2335
2336
2337; Loop until no more changes occur in the approximation to FIRST.
2338
2339 (loop
2340
2341 (setq change-flag nil)
2342
2343
2344; Compute FIRST[i+1](A) for all the nonterminals A.
2345
2346 (dolist (production *productions*) ; Scan all productions A -> alpha
2347
2348 (setq nonterm (first production)) ; A
2349
2350
2351; FIRST[i+1]( A ) =
2352; first terminal of( FIRST[i]( Y1 ) ... FIRST[Yn]) U FIRST[i]( A ).
2353
2354
2355 (setq old-first-symbols (gethash nonterm hash-table))
2356
2357 (setq new-first-symbols
2358
2359 (combine old-first-symbols ; FIRST[i](A)
2360
2361 (first-terminals-of-rhs (production-rhs! production)
2362 hash-table)
2363 :test 'same-symbol? :precedence 'precedence))
2364
2365; Record if any changes occurred, and save FIRST[i+1]( A ) in a separate
2366; update hash table.
2367
2368 (cond ((not (equal-sets-of-items? new-first-symbols
2369 old-first-symbols))
2370
2371 (setq change-flag T)
2372
2373 (setf (gethash nonterm update-hash-table)
2374 new-first-symbols))))
2375
2376; Add updates to the old hash table for FIRST[i]() to create FIRST[i+1](),
2377; then clear out the update hash table.
2378
2379 (update-first-derived-function hash-table update-hash-table)
2380
2381 (clrhash update-hash-table)
2382
2383 (if (null change-flag) (return))) ; No more changes --- exit.
2384
2385; Return the hash table of first derived terminals for every grammar symbol.
2386
2387hash-table)
2388
2389)
2390
2391
2392
2393; ------------------------------------------------------------------------------
2394; | first-terminals-of-symbol |
2395; ------------------------------------------------------------------------------
2396;
2397; DESCRIPTION
2398;
2399; Return a list of the first derived terminals of a grammar symbol.
2400;
2401; CALLING SEQUENCE
2402;
2403; (first-terminals-of-symbol s)
2404;
2405; s Any grammar symbol (or EPSILON or $).
2406;
2407; *first-derived-terminals* Hash table of the first derived terminals
2408; for every grammar symbol.
2409;
2410; *epsilon-free-first-derived-terminals*
2411;
2412; Hash table of the epsilon-free first
2413; derived terminals for every grammar symbol.
2414;
2415; type Defaults to NIL for computing FIRST() and
2416; equals 'epsilon-free for computing EFF().
2417;
2418; Returns: List of first derived terminals of s.
2419; If type = 'epsilon-free, return the
2420; epsilon-free first derived terminals
2421; instead.
2422;
2423; Creates *first-derived-terminals* and
2424; *epsilon-free-first-derived-terminals*
2425; if they do not already exist.
2426; EXAMPLE
2427;
2428; (first-terminals-of-symbol 'S)
2429; => (|a| |c| |b|)
2430; (first-terminals-of-symbol 'S :type 'epsilon-free)
2431; => (|c|)
2432;
2433; ------------------------------------------------------------------------------
2434
2435(defun first-terminals-of-symbol( symbol &key (type NIL) )
2436
2437; Create the hash tables for FIRST() and EFF() if they do not exist.
2438
2439(cond ( (or (null *first-derived-terminals*)
2440 (null *epsilon-free-first-derived-terminals*))
2441
2442 ; Sort out first derived terminals from epsilon-free first derived terminals.
2443
2444 (setq *first-derived-terminals*
2445 (make-hash-table :size +initial-hash-table-size+))
2446 (setq *epsilon-free-first-derived-terminals*
2447 (make-hash-table :size +initial-hash-table-size+))
2448
2449 (let ( (old-hash-table (create-all-first-derived-terminals)) )
2450
2451 (dolist (symbol (cons '$ (find-grammar-symbols)))
2452
2453 (setf (gethash symbol *first-derived-terminals*)
2454 (untag-list (gethash symbol old-hash-table)))
2455
2456 (setf (gethash symbol *epsilon-free-first-derived-terminals*)
2457 (untag-list
2458 (epsilon-free-only
2459 (gethash symbol old-hash-table))))))))
2460
2461
2462
2463 ; Return FIRST() or EFF() depending on the customer's request.
2464
2465 (if (equal type 'epsilon-free)
2466
2467 (gethash symbol *epsilon-free-first-derived-terminals*)
2468
2469 (gethash symbol *first-derived-terminals*))
2470)
2471
2472
2473
2474; ------------------------------------------------------------------------------
2475; | first-derived-terminals |
2476; ------------------------------------------------------------------------------
2477;
2478; DESCRIPTION
2479;
2480; Return a list of the first derived terminals of a grammar string.
2481;
2482; CALLING SEQUENCE
2483;
2484; (first-derived-terminals string :type type)
2485;
2486; string A list of grammar symbols, X1 ... Xn
2487;
2488; type NIL by default.
2489;
2490; Returns: First derived terminals of the list, FIRST( X1 ... Xn )
2491; if type = NIL, but EFF( X1 ... Xn ) if type = 'epsilon-free.
2492;
2493; METHOD
2494;
2495; FIRST( X1 ... Xn ) = FIRST( X1 ) + ... + FIRST( Xn )
2496; 1 1
2497;
2498; EFF( X1 ... Xn ) = EFF( X1 ) + FIRST( X2 ... Xn )
2499; 1
2500;
2501; EXAMPLE
2502;
2503; (first-derived-terminals '(S A)) => (|a| |c| |b|)
2504; (first-derived-terminals '(S A) :type 'epsilon-free) => (|c|)
2505;
2506; because FIRST( S ) = (|a| |b| |c|) and FIRST( A ) = (|a| |c| EPSILON)
2507; and |c| is the only terminal with a non-epsilon derivation,
2508; S => A B => C a b => c a b. |b|, for example has only the derivation
2509; S => A B => A b => EPSILON b = b, in which we must replace a leading
2510; non-terminal A with EPSILON.
2511;
2512; (first-derived-terminals '(A B)) => (|c| |a| |b|)
2513; because FIRST( B ) = { |b| }
2514;
2515; (first-derived-terminals '(A B)) => (|c|)
2516;
2517; ------------------------------------------------------------------------------
2518
2519(defun first-derived-terminals( string &key (type NIL) )
2520
2521; We want FIRST( EPSILON ) = (EPSILON) and EFF( EPSILON ) = NIL.
2522
2523(cond ( (null string) (if (equal type 'epsilon-free)
2524 NIL
2525 (list 'EPSILON)))
2526
2527; If EPSILON is in FIRST( Y1 ), add all non-epsilon terminals of FIRST( Y1 ).
2528; If we are computing EFF(), we do EFF( Y1 ) instead.
2529
2530 ( (itemInList 'EPSILON
2531 (first-terminals-of-symbol (first string) :type type))
2532
2533 (union (removeItemFromList 'EPSILON
2534 (first-terminals-of-symbol (first string)))
2535 (first-derived-terminals (rest string))
2536 :test #'equal
2537 )
2538 )
2539
2540; Otherwise, return the non-epsilon symbols of FIRST( Y1 ) or of EFF( Y1 ).
2541
2542 (t (first-terminals-of-symbol (first string) :type type)))
2543)
2544
2545
2546
2547
2548; ==============================================================================
2549; | Item functions: closure, goto, cores, etc. |
2550; ==============================================================================
2551
2552
2553; ------------------------------------------------------------------------------
2554; | closure |
2555; ------------------------------------------------------------------------------
2556;
2557; DESCRIPTION
2558;
2559; Return the closure of a list of items.
2560;
2561; CALLING SEQUENCE
2562;
2563; (closure set-of-items)
2564;
2565; *productions* Global list of productions.
2566; set-of-items
2567;
2568; Returns: For each item [A -> alpha . B beta , a] in the set, add
2569; [B -> . gamma , b] where (B -> gamma) is a production
2570; and b is the first derived symbol of the string "beta a".
2571; METHOD
2572;
2573; Intuitively, we saw alpha already and expect to see B next.
2574; That is, we expect to see any string of terminals gamma derived from B.
2575; The next symbol we expect is the lookahead, which is the first
2576; derived terminal symbol of the string beta a.
2577;
2578; EXAMPLE
2579;
2580; (closure '( (SP -> DOT S |,| $) ) ) =>
2581;
2582; ( (SP -> DOT S |,| $ )
2583; (S -> DOT C C |,| $ )
2584; (C -> DOT |c| C |,| |c|)
2585; (C -> DOT |c| C |,| |d|)
2586; (C -> DOT |d| |,| |c|)
2587; (C -> DOT |d| |,| |d|) )
2588;
2589;
2590; ------------------------------------------------------------------------------
2591
2592(defun closure( item-list )
2593
2594(let ((closed-item-list item-list) ; Closure of item-list.
2595 (item-num -1) ; nth item in item-list.
2596 (nonterm nil) ; B
2597 (first-syms nil) ; FIRST[ beta a ]
2598 (item nil) ; Current item in item-list.
2599 (new-item nil)) ; [B -> . gamma, b]
2600
2601 (loop ; Loop over each item.
2602
2603 (setq item-num (1+ item-num)) ; Advance to next item.
2604
2605 (setq item (nth item-num closed-item-list)) ; Get current item,
2606 ; [A -> alpha . B beta , a]
2607
2608 (if (null item) (return)) ; End of the list.
2609
2610 (setq nonterm (symbol-after-dot! item)) ; Get B.
2611
2612
2613 (if (nonterminal? nonterm) ; B is nonterminal.
2614
2615 (dolist (production *productions*)
2616
2617 (cond ((valid-production? nonterm ; production = [B -> gamma]
2618 production)
2619
2620 (setq first-syms ; FIRST[ beta a ]
2621 (first-derived-terminals
2622 `(,@(string-before-comma! item) ; Get beta.
2623 ,(lookahead-of! item)))) ; Get a.
2624
2625 (dolist (lookahead first-syms) ; for each b in
2626 ; FIRST[ beta a ]
2627
2628 (setq new-item ; [ B -> . gamma , b ]
2629 (make-item production
2630 lookahead))
2631
2632 (setq closed-item-list ; Add to end of list.
2633 (insertItemIntoList new-item
2634 closed-item-list))))))))
2635 closed-item-list)
2636)
2637
2638
2639
2640
2641; ------------------------------------------------------------------------------
2642; | compute-goto |
2643; ------------------------------------------------------------------------------
2644;
2645; DESCRIPTION
2646;
2647; Compute the goto on a set-of-items and a grammar symbol.
2648;
2649; CALLING SEQUENCE
2650;
2651; (compute-goto set-of-items grammar-symbol)
2652;
2653; set-of-items Set of items I.
2654;
2655; grammar-symbol Grammar symbol X.
2656;
2657; Returns: Goto function GOTO( I, X ) defined as follows:
2658;
2659; For all items [A -> alpha . X beta , a] in I,
2660; add together the closures of [A -> alpha X . beta, a].
2661; EXAMPLE
2662;
2663; (compute-goto '( (SP -> DOT s |,| $)
2664; ( S -> DOT c c |,| $)
2665; ( c -> |c| c |,| c)
2666; ( c -> |c| c |,| d)
2667; ( c -> d |,| c)
2668; ( c -> d |,| d))
2669;
2670; 'S) => ( (SP -> S DOT |,| $))
2671;
2672; ------------------------------------------------------------------------------
2673
2674(defun compute-goto( set-of-items grammar-symbol )
2675
2676 (let ( (new-set nil) )
2677
2678 (dolist (item set-of-items)
2679
2680 ; Examine each of the form [A -> alpha . X beta, a]
2681 (if (equal (symbol-after-dot! item)
2682 grammar-symbol)
2683
2684 ; Add [A -> alpha X . beta , a ] if not already there.
2685 (setq new-set
2686 (insertItemIntoList (move-dot-right item)
2687 new-set))
2688 )
2689 )
2690
2691 ; Closure of the new list.
2692 (closure new-set)
2693 )
2694)
2695
2696
2697
2698
2699; ==============================================================================
2700; | Goto Graph Functions |
2701; ==============================================================================
2702
2703
2704; ------------------------------------------------------------------------------
2705; | create-new-node |
2706; ------------------------------------------------------------------------------
2707;
2708; DESCRIPTION
2709;
2710; Create a new node in the goto graph given the data.
2711;
2712; CALLING SEQUENCE
2713;
2714; (create-new-node state hash-value set-of-items)
2715;
2716; hash-value Hash value of core of items.
2717;
2718; Returns:
2719;
2720; EXAMPLE
2721;
2722; (create-new-node 1 3668 '((SP -> S DOT |,| $)) 3648)
2723; => (1 3668 ((SP -> S DOT |,| $)))
2724;
2725; ------------------------------------------------------------------------------
2726
2727(defun create-new-node( current-state
2728 hash-value-of-core-of-items
2729 list-of-items )
2730
2731 `(,current-state ,hash-value-of-core-of-items ,list-of-items)
2732)
2733
2734(defun create-new-link( current-state
2735 grammar-symbol
2736 next-state)
2737
2738 `(,current-state ,grammar-symbol ,next-state)
2739)
2740
2741
2742; ------------------------------------------------------------------------------
2743; | select-items! |
2744; ------------------------------------------------------------------------------
2745;
2746; DESCRIPTION
2747;
2748; Select out the set of items in a node of the goto graph.
2749;
2750; CALLING SEQUENCE
2751;
2752; (select-items! node)
2753;
2754; node A node in the goto graph, (i2 i1 X SET-OF-ITEMS)
2755;
2756; Returns: SET-OF-ITEMS
2757;
2758; EXAMPLE
2759;
2760; (select-items!
2761; '( 0
2762; 3668
2763; (
2764; (SP -> DOT S |,| $)
2765; ( S -> DOT S |a| S |b| |,| $)
2766; )
2767; )
2768; )
2769;
2770; =>
2771;
2772; ------------------------------------------------------------------------------
2773
2774(defun select-items!( node )
2775
2776(third node)
2777
2778)
2779
2780
2781(defun hash-value!( node )
2782 (second node)
2783)
2784
2785(defun links!( goto-graph )
2786 (first goto-graph)
2787)
2788
2789(defun nodes!( goto-graph )
2790 (second goto-graph)
2791)
2792
2793(defun nth-node!( node-num goto-graph )
2794
2795 (nth node-num (nodes! goto-graph))
2796
2797)
2798
2799(defun first-node( goto-graph )
2800 (first (nodes! goto-graph))
2801)
2802
2803(defun rest-node( goto-graph )
2804 (rest (nodes! goto-graph))
2805)
2806
2807(defun insert-node( node goto-graph )
2808
2809 `( ,(links! goto-graph)
2810 ,(insertItemIntoList node
2811 (nodes! goto-graph))
2812 )
2813)
2814
2815(defun insert-link( link goto-graph )
2816
2817 `( ,(insertItemIntoList link (links! goto-graph))
2818 ,(nodes! goto-graph)
2819 )
2820)
2821
2822
2823
2824
2825; ------------------------------------------------------------------------------
2826; | current-state! |
2827; ------------------------------------------------------------------------------
2828;
2829; DESCRIPTION
2830;
2831; Get the number of a node in the goto graph.
2832;
2833; CALLING SEQUENCE
2834;
2835; (current-state! node)
2836;
2837; node A node in the goto graph, (i1 i2 X SET-OF-ITEMS))
2838;
2839; Returns: i1
2840;
2841; EXAMPLE
2842;
2843; (current-state! '(1 0 S ((SP -> S DOT |,| $)))) => 1
2844;
2845; -----------------------------------------------------------------------------
2846
2847(defun current-state!( node )
2848
2849(first node)
2850
2851)
2852
2853
2854
2855
2856; ------------------------------------------------------------------------------
2857; | transition-symbol! |
2858; ------------------------------------------------------------------------------
2859;
2860; DESCRIPTION
2861;
2862; Return the symbol upon which an action is performed.
2863;
2864; CALLING SEQUENCE
2865;
2866; (transition-symbol! node)
2867;
2868; node A node in the goto graph, (i1 i2 X SET-OF-ITEMS))
2869;
2870; Returns: X
2871;
2872; EXAMPLE
2873;
2874; (transition-symbol! '(1 0 S ((SP -> S DOT |,| $)))) => S
2875;
2876; ------------------------------------------------------------------------------
2877
2878(defun transition-symbol!( node )
2879
2880(third node)
2881
2882)
2883
2884
2885; ------------------------------------------------------------------------------
2886; | set-of-items-in-graph? |
2887; ------------------------------------------------------------------------------
2888;
2889; DESCRIPTION
2890;
2891; Find out if a goto graph contains a given a set of items (or
2892; their cores).
2893;
2894; CALLING SEQUENCE
2895;
2896; (set-of-items-in-graph? set-of-items goto-graph :compare-type type)
2897;
2898; set-of-items Any set of items.
2899;
2900; goto-graph The goto graph of the grammar.
2901;
2902; type Optional keyword. If omitted, it defaults to 'item.
2903;
2904; Returns T if any node in goto-graph has the same set of items
2905; (for type = 'item) or the same core (for type = 'core)
2906; as set-of-items.
2907;
2908; EXAMPLE
2909;
2910; (set-of-items-in-graph?
2911; '( (a -> b DOT c |,| d) (e -> f DOT g |,| h) )
2912; '( ( (-1 nil 0) (0 a 1) )
2913; ( (0 12 ( (a -> b DOT c |,| ddd) (e -> f DOT g |,| h) ) )
2914; (1 23 ( (i -> j DOT |,| k) ) ) ))
2915; ) => nil
2916;
2917; but
2918;
2919; (set-of-items-in-graph?
2920; '( (a -> b DOT c |,| d) (e -> f DOT g |,| h) )
2921; '( ( (-1 nil 0) (0 a 1) )
2922; ( (0 12 ( (a -> b DOT c |,| d) (e -> f DOT g |,| h) ) )
2923; (1 23 ( (i -> j DOT |,| k) ) ) ))
2924; :compare-type 'core) => T
2925;
2926;
2927; ------------------------------------------------------------------------------
2928
2929(defun set-of-items-in-graph?( set-of-items goto-graph
2930 &key (compare-type 'item) )
2931
2932(cond ( (null goto-graph) nil) ; goto graph = ()
2933 ( (null (first-node goto-graph)) nil) ; goto graph = ( (...) () )
2934
2935 ( t
2936
2937 ; Scan all nodes in the goto-graph, looking for one which has
2938 ; a matching item.
2939 (dolist (node (nodes! goto-graph))
2940
2941 (if (equal-sets-of-items? set-of-items (select-items! node)
2942 :compare-type compare-type)
2943 (return t)
2944 )
2945 )
2946 ; return nil by default
2947 )
2948)
2949
2950)
2951
2952
2953
2954; ------------------------------------------------------------------------------
2955;
2956; DESCRIPTION
2957;
2958; Find out the current node (state) number of a node in the goto
2959; graph which contains the given set of items or their cores.
2960;
2961; CALLING SEQUENCE
2962;
2963; (node-number set-of-items goto-graph :compare-type compare-type)
2964;
2965; set-of-items Set of items to search for.
2966;
2967; goto-graph Goto graph of the grammar.
2968;
2969; compare-type If 'item, find identical set of items, but if 'core,
2970; find identical cores. Defaults to 'item.
2971;
2972; Returns: Number of the node in the goto graph containing the given
2973; set of items or core.
2974;
2975; EXAMPLE
2976;
2977; (node-number '(( S -> C C DOT |,| $)) *goto-graph*) => 5
2978; (node-number '(( S -> C C DOT |,| |e|)) *goto-graph*) => NIL
2979; but
2980; (node-number '(( S -> C C DOT |,| |e|)) *goto-graph*
2981; :compare-type 'core) => 5
2982;
2983; ------------------------------------------------------------------------------
2984
2985(defun node-number( set-of-items goto-graph &key (compare-type 'item) )
2986
2987(cond ( (null goto-graph) -1) ; goto graph = ()
2988 ( (null (first-node goto-graph)) -1) ; goto graph = ( (...) () )
2989
2990 ( t
2991
2992 ; Scan all nodes in the goto-graph, looking for one which has
2993 ; a matching item.
2994 (dolist (node (nodes! goto-graph))
2995
2996 (if (equal-sets-of-items? set-of-items (select-items! node)
2997 :compare-type compare-type)
2998 (return (current-state! node))
2999 )
3000 )
3001 ; return nil by default
3002 )
3003)
3004
3005)
3006
3007
3008
3009; Hash value of the core of an item.
3010; (core-hash-value-of-item '(S -> S DOT |a| S |b| |,| $)) => 1790
3011;
3012; Sum up the integer value of all characters in each of the symbols.
3013; Multiply by the position of DOT in the item to distinguish items
3014; with the same symbols.
3015;
3016(defun core-hash-value-of-item( item )
3017
3018 (let ( (hash-value 0)
3019 (symbol-position -1)
3020 (string-of-symbol "")
3021 (length-of-string 0) )
3022
3023 ; Hash the core of the item only.
3024 (dolist (s (core-of-item! item))
3025
3026 ; Symbol index in the item, starting with 0.
3027 (setq symbol-position (+ 1 symbol-position))
3028
3029 ; Convert symbol to string and get its length.
3030 (setq string-of-symbol (symbol-name s))
3031 (setq length-of-string (length string-of-symbol))
3032
3033 ; Sum the integer values of each character in the symbol.
3034 (dotimes (i length-of-string)
3035 (setq hash-value
3036 (+ hash-value
3037 (char-int (char string-of-symbol i)))
3038 )
3039 )
3040
3041 ; Multiply by the index position of the DOT symbol
3042 ; to distinguish between same items with dots in different
3043 ; locations such as
3044 ; [S -> a . b , c] and [S -> a b . , c]
3045 (if (equal s 'DOT)
3046 (setq hash-value (* hash-value symbol-position))
3047 )
3048 )
3049 hash-value)
3050)
3051
3052; Only the core matters:
3053; (core-hash-value-of-set-of-items
3054; '( (SP -> S DOT |,| $)
3055; ( S -> S DOT |a| S |b| |,| $)
3056; ( S -> S DOT |a| S |b| |,| |a|))) => 3542
3057;
3058; (core-hash-value-of-set-of-items
3059; '( (SP -> S DOT |,| $)
3060; ( S -> S DOT |a| S |b| |,| $))) => 3542
3061;
3062; (core-hash-value-of-set-of-items
3063; '( (SP -> S DOT |,| $))) => 1752
3064;
3065(defun core-hash-value-of-set-of-items( set-of-items )
3066
3067 (let ( (hashes-of-items (mapcar #'core-hash-value-of-item set-of-items))
3068 (sum 0)
3069 )
3070
3071 ; Hash value on the entire set of items.
3072 ; Don't count duplicate items.
3073 (dolist (i (remove-duplicates hashes-of-items))
3074 (setq sum (+ sum i))
3075 )
3076
3077 ; Modulo to keep within size of an integer.
3078 (mod sum +hash-value-upper-limit+)
3079 )
3080)
3081
3082
3083
3084
3085; ==============================================================================
3086; | LALR(1) Core Merging Functions
3087; ==============================================================================
3088
3089;
3090; Partition
3091;
3092; merge-equivalence-classes( '(2 4) '() )
3093; => ( (2 4) )
3094;
3095; merge-equivalence-classes( '(2 4) '( (4 5) (6 7) ) )
3096; => ( (2 4 5) (6 7) )
3097;
3098; merge-equivalence-classes( '(2 4) '( (4 5) (2 7) (3 6) ) )
3099; => ( (3 6) (2 4 5 7) )
3100;
3101(defun merge-equivalence-classes( equivalence partition )
3102
3103 (cond
3104 ; Dispose of trivial inputs.
3105 ( (null equivalence) partition)
3106 ( (= (length equivalence) 1) partition)
3107
3108 ; Partition is empty.
3109 ( (null partition) (list equivalence) )
3110
3111 ; First set in the partition has common elements
3112 ; with the equivalence.
3113 ( (intersection equivalence (first partition) )
3114
3115 ; Sort the elements in the equivalence classes.
3116 (mapcar #'(lambda (x) (sort x #'(lambda (x y) (< x y))))
3117
3118 ; Remerge the other sets in the partition.
3119 (merge-equivalence-classes
3120
3121 ; Merge the equivalence into the first set in the
3122 ; partition.
3123 (union equivalence (first partition) :test #'equal)
3124 (rest partition)
3125 )
3126 )
3127 )
3128
3129 (t
3130
3131 ; Sort the elements in the equivalence classes.
3132 (mapcar #'(lambda (x) (sort x #'(lambda (x y) (< x y))))
3133
3134 ; Merge the other sets in the partition.
3135 (cons (first partition)
3136 (merge-equivalence-classes equivalence (rest partition))
3137 )
3138 )
3139 )
3140 )
3141)
3142
3143
3144; If member of equiv. class in the partition, return the smallest
3145; equivalent element.
3146(defun remap-equivalent( num partition )
3147
3148 (cond ( (null partition) num)
3149
3150 ( (member num (first partition))
3151 (caar partition)
3152 )
3153
3154 (t
3155 (remap-equivalent num (rest partition))
3156 )
3157 )
3158)
3159
3160
3161
3162; ------------------------------------------------------------------------------
3163; | merge-lookaheads |
3164; ------------------------------------------------------------------------------
3165;
3166; DESCRIPTION
3167;
3168; Collapse together two sets of items, eliminating duplicated items.
3169;
3170; CALLING SEQUENCE
3171;
3172; (merge-lookaheads set-of-items1 set-of-items2)
3173;
3174; set-of-items
3175;
3176; node A node in the goto graph with the same cores as in
3177; set-of-items.
3178;
3179; Returns: Updated node with the same core as before, but
3180; added lookaheads.
3181;
3182; METHOD
3183;
3184; Remove duplicates and use a set union to merge the lookaheads.
3185;
3186; EXAMPLE
3187;
3188; (merge-lookaheads '( (D -> E DOT F |,| |b|)
3189; (A -> B DOT C |,| |a|) )
3190;
3191; '( (A -> B DOT C |,| |a|)
3192; (A -> B DOT C |,| |a|)
3193; (D -> E DOT F |,| |c|) )) =>
3194;
3195; ( (D -> E DOT F |,| |b|)
3196; (A -> B DOT C |,| |a|)
3197; (D -> E DOT F |,| |c|) )
3198;
3199; ------------------------------------------------------------------------------
3200
3201(defun merge-lookaheads( set-of-items1 set-of-items2 )
3202
3203 ; Use the equal function to test for duplicates, since we are handling
3204 ; elements which are lists, not atoms.
3205 (union (remove-duplicates set-of-items1)
3206 (remove-duplicates set-of-items2)
3207 :test #'equal)
3208)
3209
3210
3211
3212
3213; ------------------------------------------------------------------------------
3214; | merge-cores |
3215; ------------------------------------------------------------------------------
3216;
3217; DESCRIPTION
3218;
3219; If the given set of items has the same core as a node in the goto graph,
3220; merge it into the node.
3221;
3222; CALLING SEQUENCE
3223;
3224; merge-cores( goto-graph )
3225;
3226; goto-graph Goto graph of the grammar.
3227;
3228; Returns: All sets of items with the same cores are merged,
3229; and states and links are renumbered.
3230;
3231; EXAMPLE
3232;
3233; ------------------------------------------------------------------------------
3234
3235(defun merge-cores( goto-graph )
3236
3237(let ( (nodes (nodes! goto-graph)) ; Get the nodes out
3238 (links (links! goto-graph)) ; and the links.
3239 (previous-node nil)
3240 (previous-state -1)
3241 (previous-hash-value -1)
3242 (equiv-class nil)
3243 (merged-goto-graph '(() ()) ) ; New merged goto graph.
3244 )
3245
3246 ; Sort the nodes on hash value to keep sets of items with the same
3247 ; cores adjacent.
3248 (setq nodes
3249 (sort nodes #'(lambda (x y) (< (hash-value! x) (hash-value! y)))))
3250
3251 ; Scan through the nodes, looking for sets of items with the
3252 ; same cores.
3253 (dolist (node nodes)
3254
3255 ; Current node and previous node have same cores.
3256 (cond ( (= (hash-value! node) previous-hash-value)
3257
3258 (setq equiv-class
3259 (merge-equivalence-classes
3260 (list (current-state! node) previous-state)
3261 equiv-class
3262 )
3263 )
3264
3265 ; Create a new merged node.
3266 (setq node
3267 (create-new-node
3268
3269 ; Use the lowest numbered state
3270 ; for the new node number.
3271 (if (< (current-state! node)
3272 (current-state! previous-node))
3273 (current-state! node)
3274 (current-state! previous-node)
3275 )
3276
3277 ; Hash value.
3278 (hash-value! node)
3279
3280 ; Merge the cores in the items.
3281 (merge-lookaheads (select-items! node)
3282 (select-items! previous-node))
3283 )
3284 )
3285 )
3286
3287 ; Current node differs, send off previous node.
3288 (t
3289 (if (not (null previous-node))
3290 (setq merged-goto-graph
3291 (insert-node previous-node merged-goto-graph))
3292 )
3293 )
3294 )
3295
3296 (setq previous-node node)
3297 (setq previous-hash-value (hash-value! node))
3298 (setq previous-state (current-state! node))
3299 )
3300
3301 ; Send off last node, merged or otherwise, in any case.
3302 (setq merged-goto-graph
3303 (insert-node previous-node merged-goto-graph))
3304
3305 ; Renumber states in the links.
3306 (dolist (link links)
3307
3308 (setq link
3309 `( ,(remap-equivalent (first link) equiv-class)
3310 ,(second link)
3311 ,(remap-equivalent (third link) equiv-class)
3312 )
3313 )
3314 (setq merged-goto-graph (insert-link link merged-goto-graph))
3315 )
3316 merged-goto-graph
3317)
3318
3319)
3320
3321
3322
3323
3324
3325; ==============================================================================
3326; | LR(1) Action and Goto table utilities |
3327; ==============================================================================
3328
3329
3330
3331; ------------------------------------------------------------------------------
3332; | create-goto-graph |
3333; ------------------------------------------------------------------------------
3334;
3335; DESCRIPTION
3336;
3337; Create a goto graph containing the sets of items for the grammar.
3338;
3339; CALLING SEQUENCE
3340;
3341; (create-goto-graph parser-type)
3342;
3343; parser-type The type of grammar: 'LR1 or 'LALR1
3344;
3345; Returns: Goto graph of the grammar.
3346;
3347; METHOD
3348;
3349; We create a DFA which recognizes the viable prefixes of the grammar.
3350;
3351; The DFA is called the goto graph. Each node in the graph is of the
3352; form (i2 i1 X SET-OF-ITEMS).
3353;
3354; i1 = V( gamma ) = (set of all items valid for viable prefix gamma).
3355; i2 = V( gamma X )
3356; X = a grammar symbol (but not EPSILON).
3357;
3358; An item [A -> alpha . beta] is valid for viable prefix gamma alpha if
3359; gamma A is also a viable prefix.
3360;
3361; The prefix gamma is viable if there is a rightmost derivation
3362; S =>* gamma w.
3363;
3364; The first state is I0 = V( EPSILON ) = { [S -> . S , $] }.
3365;
3366; We process nodes as follows:
3367;
3368; node-num ---> 0
3369; ...
3370; node-num ---> 3 ----+----+
3371; | a |
3372; 4 <---+ | b
3373; |
3374; 5 <---+----+
3375; ...
3376; 3 ----+----+
3377; | a |
3378; 4 <---+ | b
3379; |
3380; node-num ---> 5 <---+----+
3381;
3382; -----------------------------------------------------------------------------
3383
3384(defun create-goto-graph( parser-type )
3385
3386(let* ( (goto-of-item nil) ; Set of items, GOTO( I, X )
3387 (node nil) ; Node in graph.
3388 (node-num 0) ; Next node in goto graph to process.
3389 (new-node nil) ; New node in Goto graph.
3390 (new-link nil)
3391 (new-state-num 1) ; State number of the next node.
3392 (goto-graph '( () () ) ); Initial goto-graph.
3393 )
3394
3395
3396 ; Our very first set of items I0 is the closure of [S' -> .S, $]
3397 (setq goto-of-item (closure (list (create-augmenting-item))))
3398
3399 ; The initial node has state 0, items as above, and hash value.
3400 (setq node (create-new-node 0
3401 (core-hash-value-of-set-of-items
3402 goto-of-item)
3403 goto-of-item))
3404
3405 (setq new-link (create-new-link -1 nil 0))
3406
3407 ; Insert nodes and links into the goto graph.
3408 (setq goto-graph (insert-node node goto-graph))
3409 (setq goto-graph (insert-link new-link goto-graph))
3410
3411 (loop
3412 ; Latest unprocessed node in the goto graph. Starting with I0.
3413 (setq node (nth-node! node-num goto-graph))
3414
3415 (if (null node) (return)) ; No more sets of items.
3416
3417 ; For each grammar symbol X ...
3418 (dolist (grammar-symbol (find-grammar-symbols))
3419
3420 ; ...compute GOTO( I, X ), the new set of items.
3421 (setq goto-of-item
3422 (compute-goto (select-items! node)
3423 grammar-symbol))
3424
3425 ; Create a new node with set of items GOTO( I, X ),
3426 (setq new-node
3427 (create-new-node new-state-num
3428 (core-hash-value-of-set-of-items
3429 goto-of-item)
3430 goto-of-item )
3431 )
3432
3433 ; GOTO( I, X ) is empty.
3434 (if (not (null goto-of-item))
3435
3436 (cond (
3437 ; Our GOTO( I, X ) has computed the same sets of
3438 ; items.
3439 (set-of-items-in-graph? goto-of-item
3440 goto-graph)
3441
3442 ; Insert a new link
3443 ; X
3444 ; I ---> <existing node in graph>
3445 (setq new-link (create-new-link
3446 node-num
3447 grammar-symbol
3448 (node-number goto-of-item
3449 goto-graph))
3450 )
3451
3452 (setq goto-graph (insert-link new-link goto-graph))
3453 )
3454
3455
3456
3457 ; Add a new node with a new set of items and
3458 ; a new link.
3459 ; Increment the current state number.
3460 (t
3461 (setq goto-graph (insert-node new-node goto-graph))
3462
3463 (setq new-link (create-new-link (current-state! node)
3464 grammar-symbol
3465 new-state-num))
3466 (setq goto-graph (insert-link new-link goto-graph))
3467
3468 (setq new-state-num (1+ new-state-num))
3469 )
3470
3471 ) ; end cond
3472
3473 ) ; end if empty GOTO( I, X )
3474 ) ; end dolist
3475
3476 ; Bump up the node number.
3477 (setq node-num (1+ node-num ))
3478
3479 ) ; end loop
3480
3481
3482 ; For LALR(1) languages, sort the goto graph on core hash value
3483 ; then merge states with the same cores.
3484 (if (equal parser-type 'LALR1)
3485 (setq goto-graph (merge-cores goto-graph))
3486 )
3487 goto-graph
3488
3489) ; end let
3490
3491)
3492
3493; ------------------------------------------------------------------------------
3494; | goto |
3495; ------------------------------------------------------------------------------
3496;
3497; DESCRIPTION
3498;
3499; The LR GOTO function derived from the goto graph.
3500;
3501; CALLING SEQUENCE
3502;
3503; (goto i A goto-graph)
3504;
3505; goto-graph The goto graph with entries of the form
3506; (i2 i1 X <list of items>)
3507;
3508; state The initial state i1.
3509;
3510; symbol The transition symbol X.
3511;
3512; Returns: The next state i2, or NIL if GOTO is undefined.
3513;
3514; EXAMPLE
3515;
3516; Suppose *goto-graph* = ( ( (6 |a| 4) ) (nodes) )
3517;
3518; (goto 6 '|a| goto-graph) => 4
3519;
3520; ------------------------------------------------------------------------------
3521
3522(defun goto( state symbol goto-graph)
3523
3524 (dolist (link (links! goto-graph))
3525
3526 (if (and (= state (first link))
3527 (equal symbol (second link))
3528 )
3529
3530 (return (third link))
3531 )
3532 )
3533 ; Return nil by default.
3534)
3535
3536
3537; ------------------------------------------------------------------------------
3538; | action-list! |
3539; ------------------------------------------------------------------------------
3540;
3541; DESCRIPTION
3542;
3543; Return the list of actions in a line of the action table.
3544;
3545; CALLING SEQUENCE
3546;
3547; (action-list action-table-line)
3548;
3549; action-table-line One line of action table of the form
3550; ( (stateNumber) (listOfActions) )
3551;
3552; Returns: (listOfActions)
3553;
3554; EXAMPLE
3555;
3556; (action-list! '( (0) ((|c| (S 3)) (|d| (S 4)))))
3557; => ((|c| (S 3)) (|d| (S 4)))
3558;
3559; ------------------------------------------------------------------------------
3560
3561(defun action-list!( line-of-table )
3562
3563(second line-of-table)
3564)
3565
3566
3567
3568; ------------------------------------------------------------------------------
3569; | action-line-state! |
3570; ------------------------------------------------------------------------------
3571;
3572; DESCRIPTION
3573;
3574; Return the state of a line of the action table.
3575;
3576; CALLING SEQUENCE
3577;
3578; (action-line-state! action-table)
3579;
3580; action-table Table of the form ( (stateNum) (listOfActions) )
3581;
3582; Returns: stateNum
3583;
3584; EXAMPLE
3585;
3586; (action-line-state! '( (0) ((|c| (S 3)) (|d| (S 4)) (DEFAULT (ERROR)))) )
3587; => 0
3588;
3589; ------------------------------------------------------------------------------
3590
3591(defun action-line-state!( action-table-line )
3592
3593(first (first action-table-line))
3594
3595)
3596
3597
3598
3599
3600; ------------------------------------------------------------------------------
3601; | action-trigger-symbol! |
3602; ------------------------------------------------------------------------------
3603;
3604; DESCRIPTION
3605;
3606; Return the transition symbol in an action pair.
3607;
3608; CALLING SEQUENCE
3609;
3610; (action-trigger-symbol! action-pair)
3611;
3612; action-pair An action/new-state pair of a line in the action table
3613; of the form (X (action i)).
3614;
3615; Returns: X
3616;
3617; EXAMPLE
3618;
3619; (action-trigger-symbol! '(|c| (S 3))) => |c|
3620;
3621; ------------------------------------------------------------------------------
3622
3623(defun action-trigger-symbol!( action-pair )
3624
3625(first action-pair)
3626
3627)
3628
3629
3630
3631; ------------------------------------------------------------------------------
3632; | insert-action-or-goto-into-list |
3633; ------------------------------------------------------------------------------
3634;
3635; DESCRIPTION
3636;
3637; Insert an action into a line of the action table. Check for conflicts.
3638;
3639; CALLING SEQUENCE
3640;
3641; (insert-action-or-goto-into-list symbol new-state list-of-actions action)
3642;
3643; symbol The transition symbol X.
3644;
3645; new-state The new state i.
3646;
3647; list-of-actions The action list part of one line of the action or
3648; goto table.
3649;
3650; action If 'NONE, update a goto list, else add this action
3651; to an action list.
3652;
3653; Returns: Augmented action list containing a new action pair
3654; (X (action i)) or a conflict pair
3655; (CONFLICT (X (action i)) (X (old-action j)))
3656; Similarly for a goto list.
3657; EXAMPLE
3658;
3659; (insert-action-or-goto-into-list 'a 666 '((b (s 3)) (c (r 2))) :action 's)
3660; =>((B (S 3)) (C (R 2)) (A (S 666)))
3661;
3662; (insert-action-or-goto-into-list 'b 666 '((b (s 3)) (c (r 2))) :action 's)
3663; => ((B (S 3)) (C (R 2)) (CONFLICT ((B (S 666)) (B (S 3)))))
3664;
3665; (insert-action-or-goto-into-list 'a 666 '((b 5) (c 6)))
3666; => ((B 5) (C 6) (A 666))
3667;
3668; ------------------------------------------------------------------------------
3669
3670(defun insert-action-or-goto-into-list( symbol new-state list-of-actions
3671 &key (action 'NONE) )
3672
3673
3674; Nothing or only a default in the list. Insert a new action.
3675
3676 (cond ( (or (null list-of-actions)
3677 (equal (first list-of-actions) '(default (error))))
3678
3679 (cons (if (equal action 'NONE)
3680 `(,symbol ,new-state) ; Insert a goto.
3681 `(,symbol (,action ,new-state))) ; Insert an action.
3682 list-of-actions))
3683
3684; Ignore duplicate actions.
3685
3686 ((equal (first list-of-actions)
3687 (if (equal action 'NONE)
3688 `(,symbol ,new-state) ; Compare a goto.
3689 `(,symbol (,action ,new-state)))) ; Compare an action.
3690
3691 list-of-actions) ; Return list unchanged.
3692
3693
3694; We have a conflict on the first action. Insert a conflict report at the
3695; end of the row, unless it is there already.
3696
3697 ((equal symbol (action-trigger-symbol! (first list-of-actions)))
3698
3699 (setq *conflicts* T)
3700
3701 (insertItemIntoList (if (equal action 'NONE)
3702 `(conflict ((,symbol ,new-state)
3703 (,@(first list-of-actions))))
3704 `(conflict ((,symbol (,action ,new-state))
3705 (,@(first list-of-actions)))))
3706
3707 list-of-actions))
3708
3709
3710; No conflict yet --- try insertion in the rest of the list.
3711
3712 ( t (cons (first list-of-actions)
3713 (insert-action-or-goto-into-list symbol
3714 new-state
3715 (rest list-of-actions)
3716 :action action))))
3717)
3718
3719
3720
3721; ------------------------------------------------------------------------------
3722; | add-action-or-goto |
3723; ------------------------------------------------------------------------------
3724;
3725; DESCRIPTION
3726;
3727; Add an action to the action table or a goto to the goto table.
3728;
3729;
3730; CALLING SEQUENCE
3731;
3732; (add-action-or-goto( state symbol new-state table action)
3733;
3734; state The current state i1.
3735;
3736; new-state The new state i2
3737;
3738; table The action or goto table.
3739;
3740; action Defaults to 'NONE for the goto table, otherwise, the
3741; action to take (e.g. S, R, ACC, ERROR)
3742;
3743; Returns: The updated action or goto table.
3744;
3745; EXAMPLE
3746;
3747; Let table = ( ( (2) ( (a (s 5))
3748; (b (r 2))
3749; (default (error))))
3750; ( (4) ( ($ (acc nil))
3751; (default (error)))))
3752;
3753; To insert ACTION[ 2, b ] = (shift 6) into the table, call
3754;
3755; (add-action-or-goto 2 'b 6 table :action 's) =>
3756;
3757; ( ( (2) ( (A (S 5))
3758; (B (R 2))
3759; (DEFAULT (ERROR))
3760; (CONFLICT ((B (S 6)) (B (R 2))))))
3761; ( (4) ( ($ (ACC NIL))
3762; (DEFAULT (ERROR)))))
3763;
3764; We detect a shift/reduce conflict on symbol b and report it.
3765;
3766; On the other hand,
3767;
3768; (add-action-or-goto 2 'c 6 table :action 's) =>
3769;
3770; ( ( (2) ( (A (S 5))
3771; (B (R 2))
3772; (C (S 6))
3773; (DEFAULT (ERROR))))
3774; ( (4) ( ($ (ACC NIL))
3775; (DEFAULT (ERROR)))))
3776;
3777; Suppose we have a goto table,
3778;
3779; table = ( ( (0) ( (a 10)
3780; (b 20)
3781; (default (error))))
3782; ( (4) ( (a 11)
3783; (default (error)))))
3784;
3785; To insert GOTO[ 0, c ] = 6 call
3786;
3787; (add-action-or-goto 0 'c 6 table) =>
3788;
3789; ( ( (0) ( (A 10)
3790; (B 20)
3791; (C 6)
3792; (DEFAULT (ERROR))))
3793; ( (4) ( (A 11)
3794; (DEFAULT (ERROR)))))
3795;
3796; -----------------------------------------------------------------------------
3797
3798(defun add-action-or-goto( state symbol new-state table
3799 &key (action 'NONE))
3800
3801 ; The table has no entries. Create a new action table of the form
3802 ; ( (State) ( (TransitionSymbol (Action NewState)) (default (error))))
3803 ; or Goto table of the form,
3804 ; ( (State) ( (TransitionSymbol (NewState)) (default (error)))).
3805 ;
3806 ; NOTE:
3807 ; We assume the Goto graph starts with state 0.
3808 ; Since we insert new states into the action table in order,
3809 ; the order will be maintained as we scan through the Goto graph.
3810
3811 (cond ( (null table) `(
3812 ( (,state)
3813
3814 (
3815 ,(if (equal action 'NONE)
3816 `(,symbol ,new-state) ; goto table
3817 `(,symbol (,action ,new-state))
3818 )
3819
3820 (default (error))
3821 )
3822 )
3823 )
3824 )
3825
3826
3827 ; Found state in first line of table. Add the new action to
3828 ; this line.
3829 ( (= (action-line-state! (first table))
3830 state)
3831
3832 (cons (list (first (first table)) ; Get state of first line.
3833
3834 (insert-action-or-goto-into-list symbol
3835 new-state
3836 (action-list! (first table))
3837 :action action))
3838 (rest table)))
3839
3840 ; State is smaller than first line's state. Create a new line
3841 ; containing a new state, action and (default (error)) and add it
3842 ; before the first line.
3843 ( (< state (action-line-state! (first table)))
3844
3845 (cons `( (,state)
3846 ( ,(if (equal action 'NONE)
3847 `(,symbol ,new-state) ; goto table
3848 `(,symbol (,action ,new-state))
3849 )
3850 (default (error))
3851 )
3852 )
3853 table)
3854 )
3855
3856 ; State is bigger than the first line's state. Decide later.
3857 ( t (cons (first table)
3858 (add-action-or-goto state symbol new-state (rest table)
3859 :action action))))
3860)
3861
3862
3863; ------------------------------------------------------------------------------
3864; | build-action-table |
3865; ------------------------------------------------------------------------------
3866;
3867; DESCRIPTION
3868;
3869; Build the ACTION table of a cannonical LR(1) parser.
3870;
3871;
3872; CALLING SEQUENCE
3873;
3874; (build-action-table goto-graph)
3875;
3876; goto-graph The goto graph generated by make-items.
3877;
3878; Returns: Action table of the grammar.
3879;
3880; METHOD
3881;
3882; We initially add the action (default (error)) to each line of the table.
3883; If we generate any shift-reduce or reduce-reduce conflicts,
3884; we record them in the action table and check them later.
3885;
3886; EXAMPLE
3887;
3888; ------------------------------------------------------------------------------
3889
3890(defun build-action-table( goto-graph )
3891
3892(let ( (action-table nil)
3893 (first-symbols-after-dot nil) )
3894
3895 (dolist (node (nodes! goto-graph)) ; Scan through every node in
3896 ; in the goto graph.
3897 (dolist (item (select-items! node))
3898
3899 (cond (
3900 ; For the item [S' -> S. , $],
3901 ; ACTION[ i, $ ] = (accept).
3902 (is-accept? item)
3903
3904 (setq action-table
3905 (add-action-or-goto
3906 (current-state! node) ; Current state i
3907 '$ ; Transition.
3908 'nil ; No state.
3909 action-table
3910 :action 'acc) ; No state.
3911 )
3912 )
3913
3914 ; For the item [A -> alpha . , b]
3915 ; ACTION[ i, b ] = (reduce k)
3916 ; where k is the number of the production A -> alpha
3917 ( (reduction? item)
3918
3919 (setq action-table
3920 (add-action-or-goto
3921 (current-state! node) ; Current state i
3922 (lookahead-of! item) ; b.
3923 (production-number ; Production num.
3924 (item-to-production item))
3925 action-table
3926 :action 'r)
3927 )
3928 )
3929
3930; Prepare to add a possible shift.
3931
3932 ( t
3933
3934 (if *has-epsilon-productions*
3935
3936 ; When the grammar has epsilon-productions, for the item
3937 ; [A -> alpha . beta , b]
3938 ; where beta is not equal to the null-string EPSILON,
3939 ; for all a in EFF( beta b ), we add
3940 ; ACTION[ i, a ] = (shift j) where j = GOTO( i , a ).
3941 (setq first-symbols-after-dot
3942
3943 (if (reduction? item) ; beta = epsilon
3944
3945 nil
3946
3947 (first-derived-terminals `(,(symbol-after-dot! item)
3948 ,@(string-before-comma! item)
3949 ,(lookahead-of! item))
3950 :type 'epsilon-free)))
3951
3952 ; For a grammar with no epsilon productions, for the item
3953 ; [A -> alpha . a beta , b]
3954 ; where a is a terminal, we add
3955 ; ACTION[ i, a ] = (shift j) where j = GOTO( i , a ).
3956 (setq first-symbols-after-dot
3957
3958 (if (terminal-after-dot? item)
3959
3960 (list (symbol-after-dot! item))
3961
3962 nil))
3963 )
3964
3965
3966; Add a shift, if any.
3967 (dolist (term first-symbols-after-dot)
3968
3969 (setq action-table
3970 (add-action-or-goto (current-state! node) ; Current state i
3971 term ; Terminal a.
3972 (goto ; into state j.
3973 (current-state! node)
3974 term
3975 goto-graph)
3976 action-table
3977 :action 's))))))) ; Do a shift.
3978
3979 action-table)
3980)
3981
3982
3983
3984; ------------------------------------------------------------------------------
3985; | build-goto-table |
3986; ------------------------------------------------------------------------------
3987;
3988; DESCRIPTION
3989;
3990; Build the GOTO table for an LR(1) parser.
3991;
3992;
3993; CALLING SEQUENCE
3994;
3995; (build-goto-table)
3996;
3997; goto-graph The goto graph.
3998;
3999; Returns: The goto table.
4000;
4001;
4002; METHOD
4003;
4004; Whenever we have a link i which has a transition
4005; on a nonterminal A to the link j, we fill the table with
4006; GOTO( i, A ) = j.
4007;
4008; EXAMPLE
4009;
4010; ------------------------------------------------------------------------------
4011
4012(defun build-goto-table( goto-graph )
4013
4014(let ((goto-table nil))
4015
4016 (dolist (link (links! goto-graph))
4017
4018 (if (and (> (first link) -1)
4019 (nonterminal? (second link)))
4020
4021 (setq goto-table
4022 (add-action-or-goto (first link)
4023 (second link)
4024 (third link)
4025 goto-table)
4026 )
4027 )
4028 )
4029 goto-table)
4030)
4031
4032
4033
4034
4035
4036; ==============================================================================
4037; | Input and Output Functions |
4038; ==============================================================================
4039
4040; ------------------------------------------------------------------------------
4041; | write-header |
4042; ------------------------------------------------------------------------------
4043;
4044; DESCRIPTION
4045;
4046; Write a header for the parse tables file.
4047;
4048; CALLING SEQUENCE
4049;
4050; (write-header fp parser-type)
4051;
4052; fp Pointer to the currently open file.
4053;
4054; parser-type 'LR1 or 'LALR1. The title will be adjusted
4055; automatically based on the parser type.
4056;
4057; Returns: Header text written to file.
4058;
4059; EXAMPLE
4060;
4061; ------------------------------------------------------------------------------
4062
4063(defun write-header( fp parser-type )
4064
4065(format fp "~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~%"
4066 ";---------------------"
4067
4068 (if (equal parser-type 'LR1)
4069 "; LR(1) parse tables"
4070 "; LALR(1) parse tables")
4071
4072 ";---------------------"
4073 ";"
4074 "; Suitable for input to the Common Lisp program "
4075 ";"
4076 "; LR(1)AndLALR(1)Parser.lsp"
4077 ";"
4078)
4079
4080)
4081
4082
4083; ------------------------------------------------------------------------------
4084; | write-terminals |
4085; ------------------------------------------------------------------------------
4086;
4087; DESCRIPTION
4088;
4089; Write a header for the parse tables file.
4090;
4091; CALLING SEQUENCE
4092;
4093; (write-terminals fp)
4094;
4095; fp Pointer to the currently open file.
4096;
4097; Returns: Terminal symbols written to file.
4098;
4099; EXAMPLE
4100;
4101; ------------------------------------------------------------------------------
4102
4103(defun write-terminals( fp terminals )
4104
4105 (format fp "~A~%~A~%~%"
4106 "; TERMINALS"
4107 ";"
4108 )
4109
4110 (format fp "~S~%~%" terminals)
4111
4112 (fresh-line fp)
4113 (fresh-line fp)
4114)
4115
4116
4117; ------------------------------------------------------------------------------
4118; | write-productions |
4119; ------------------------------------------------------------------------------
4120;
4121; DESCRIPTION
4122;
4123; Write the split up productions with their numbers.
4124;
4125; CALLING SEQUENCE
4126;
4127; (write-productions fp productions)
4128;
4129; fp Pointer to the currently open file.
4130;
4131; productions List of productions to write.
4132;
4133; Returns: Neat list of numbered productions. (These are
4134; the ones expanded from the alternates.)
4135;
4136; EXAMPLE
4137;
4138; See the files lalrparser.dat and parser.dat for examples.
4139;
4140; ------------------------------------------------------------------------------
4141
4142(defun write-productions( fp productions )
4143
4144 (format fp "~A~%~A~%~A~%~A~%~%~A~%"
4145 "; PRODUCTIONS"
4146 ";"
4147 "; Productions are numbered starting with 1."
4148 "; All alternates were expanded into separate productions."
4149 "(" )
4150
4151 (dolist (production productions)
4152
4153 ; Print each production.
4154 (format fp "~A~D~A~S~A~%"
4155 " ( "
4156 `(,(production-number production))
4157 " "
4158 production
4159 " )" )
4160 )
4161
4162 (format fp "~A~%~%"
4163 ")" )
4164)
4165
4166
4167
4168(defun construct-error-messages( action-table )
4169
4170(let ( (error-messages nil)
4171 (transition-symbols nil) )
4172
4173 ; Scan through each line of the action table.
4174 (dolist (action-line action-table)
4175
4176 (setq transition-symbols nil)
4177
4178 ; Scan through the actions in each line.
4179 (dolist (action (action-list! action-line))
4180
4181 ; Found an error state; add message to the list.
4182 (if (equal (second action) '(ERROR))
4183 (push `( (,(action-line-state! action-line))
4184 (,(concatenate 'string
4185 "error - expecting one of the symbols "
4186 (string-trim "("
4187 (string-trim ")"
4188 (write-to-string transition-symbols))))))
4189 error-messages)
4190
4191 ; else keep collecting transition symbols.
4192 (setq transition-symbols
4193 (cons (first action)
4194 transition-symbols))
4195
4196 )
4197 )
4198 )
4199
4200 (reverse error-messages))
4201)
4202
4203
4204; ------------------------------------------------------------------------------
4205; | write-error-message-table |
4206; ------------------------------------------------------------------------------
4207;
4208; DESCRIPTION
4209;
4210; Write the error message table with templates for the user to fill in.
4211;
4212; CALLING SEQUENCE
4213;
4214; (write-error-message-table fp action-table)
4215;
4216; fp Pointer to the currently open file.
4217;
4218; action-table
4219;
4220; Returns: Error message table.
4221;
4222; EXAMPLE
4223;
4224;
4225; ------------------------------------------------------------------------------
4226
4227(defun write-error-message-table( fp action-table )
4228
4229 (format fp "~A~%~%~%"
4230"
4231; ERROR MESSAGE TABLE
4232;
4233; If the action table has an error state, the other non-error
4234; actions show which symbol was failed to appear next on the input.
4235;
4236; The user can modify these minimal error messages.
4237" )
4238
4239 ; Opening parenthesis.
4240 (format fp "(~%~%")
4241
4242 ; Iterate over error states.
4243 (dolist (error-message (construct-error-messages action-table))
4244
4245 (format fp " ~S ~%" error-message)
4246 )
4247
4248 ; Closing parenthesis.
4249 (format fp ")~%~%")
4250)
4251
4252
4253
4254; ------------------------------------------------------------------------------
4255; | write-goto-graph |
4256; ------------------------------------------------------------------------------
4257;
4258; DESCRIPTION
4259;
4260; Write the formatted goto graph to a file.
4261;
4262; CALLING SEQUENCE
4263;
4264; (write-goto-graph fp goto-graph)
4265;
4266; fp Pointer to (open) file which is to contain the graph.
4267;
4268; goto-graph Goto graph itself, which will be pretty-printed.
4269;
4270;
4271; EXAMPLE
4272;
4273; (write-goto-graph fp " *goto-graph*)
4274; => ... see the sample output files parser.dat and lalrparser.dat.
4275;
4276; ------------------------------------------------------------------------------
4277
4278(defun write-goto-graph( fp goto-graph )
4279
4280 ; Write the title first and the opening parenthesis.
4281 (format fp "~A~%~%"
4282"; GOTO GRAPH
4283;
4284; Not needed for the parser, but here for reference and debugging.
4285; **********
4286; Goto graph of the LR(1) or LALR(1) grammar of the form
4287;
4288; (
4289; ( <-- List of links.
4290; (6 |a| 4) <-- Transition in Goto graph from state 6 to
4291; state 4 on symbol a.
4292; (1 |a| 2) <-- Transition from state 1 to state 2 on a.
4293; )
4294;
4295; ( <-- List of sets of items.
4296; ( 0 <-- State number 0.
4297; 3668 <-- Hash value of core.
4298; (
4299; (SP -> DOT S |,| $) ----+
4300; ( S -> DOT S |a| S |b| |,| $) |
4301; ( S -> DOT EPSILON |,| $) +---- Set of items for state 0
4302; ( S -> DOT S |a| S |b| |,| |a|) |
4303; ( S -> DOT EPSILON |,| |a|) |
4304; ) ----+
4305; ) "
4306)
4307
4308 ; Opening parenthesis of graph.
4309 (format fp "(~%")
4310
4311 ; Opening parenthesis of links.
4312 (format fp "~3,4@T(~%")
4313
4314 ; Print each link.
4315 (dolist (link (links! goto-graph))
4316
4317 (format fp "~3,8@T(~D ~S ~D)~%"
4318 (first link)
4319 (second link)
4320 (third link))
4321 )
4322
4323 ; Closing parenthesis of links.
4324 (format fp "~3,4@T)~%")
4325
4326 ; Opening parenthesis of nodes.
4327 (format fp "~3,4@T(~%")
4328
4329 ; Print each node in the graph.
4330 (dolist (node (nodes! goto-graph))
4331
4332 ; Print open paren of node, state and hash value.
4333 (format fp "~3,8@T(~D~%~3,8@T~D~%"
4334 (current-state! node)
4335 (hash-value! node))
4336
4337 ; Print out each item.
4338 (dolist (item (select-items! node))
4339 (format fp "~3,12@T~S~%" item))
4340
4341 ; Closing paren of node.
4342 (format fp "~3,8@T)~%")
4343 )
4344
4345 ; Closing parenthesis of nodes.
4346 (format fp "~3,4@T)~%")
4347
4348 ; Closing parenthesis of graph.
4349 (format fp ")~%~%")
4350)
4351
4352
4353; ------------------------------------------------------------------------------
4354; | write-action-or-goto-table |
4355; ------------------------------------------------------------------------------
4356;
4357; DESCRIPTION
4358;
4359; Write the formatted action or goto table to a file.
4360;
4361; CALLING SEQUENCE
4362;
4363; (write-action-or-goto-table fp table)
4364;
4365; fp Pointer to (open) file which is to contain the
4366; action-table.
4367;
4368; table Action or goto table itself, which will be
4369; pretty-printed.
4370;
4371;
4372; EXAMPLE
4373;
4374; (write-action-or-goto-table fp " *action-table)
4375; => ... see the sample output files parser.dat and lalrparser.dat.
4376;
4377; ------------------------------------------------------------------------------
4378
4379(defun write-action-or-goto-table( fp table &key (table-type 'ACTION))
4380
4381 ; Write the title first and the opening parenthesis.
4382 (format fp "~A~%~A~%~A~%~A~%~A~%~%~A~%"
4383 (cond ( (equal table-type 'ACTION) "; ACTION TABLE")
4384 ( (equal table-type 'GOTO) "; GOTO TABLE" ))
4385 ";"
4386 "; (state"
4387 "; (item)"
4388 "; ..."
4389 "(" )
4390
4391 ; Print actions for each state.
4392 (dolist (state table)
4393
4394 ; Print the opening paren of the table and the state
4395 ; number in parentheses.
4396 (format fp "~3,4@T( (~D) ~%"
4397 (action-line-state! state)
4398 )
4399
4400 ; Print the word NIL explicitly if the list of items is empty.
4401 (if (null (action-list! state))
4402 (format fp "~3,8@TNIL~%")
4403
4404 ; Print out the list of actions.
4405 (progn
4406 ; Print first paren of action list.
4407 (format fp "~3,8@T(~%")
4408
4409 ; Print actions.
4410 (dolist (item (action-list! state))
4411 (format fp "~3,12@T~S~%" item))
4412
4413 ; Print first paren of action list.
4414 (format fp "~3,8@T)~%")
4415 )
4416 )
4417
4418 (format fp "~3,4@T)~%")
4419 )
4420
4421 ; Closing parenthesis.
4422 (format fp ")~%~%")
4423)
4424
4425
4426; ------------------------------------------------------------------------------
4427; | print-legal-notice |
4428; ------------------------------------------------------------------------------
4429;
4430; DESCRIPTION
4431;
4432; Write legal notice when the program starts up.
4433;
4434; CALLING SEQUENCE
4435;
4436; Returns: Legal notice to standard output.
4437;
4438; EXAMPLE
4439;
4440; ------------------------------------------------------------------------------
4441
4442(defun print-legal-notice()
4443
4444 ; Print a few newlines, the notice and a few more newlines.
4445 (format t "~%~%~A~%~%"
4446 "
4447 LR(1)AndLALR(1)ParserGenerator Version 5.6
4448
4449 An LR(1) and LALR(1) Parser Generator written in Common Lisp.
4450
4451 Copyright (C) 1989-2024 by Sean Erik O'Connor. All Rights Reserved.
4452
4453 This program is free software: you can redistribute it and/or modify
4454 it under the terms of the GNU General Public License as published by
4455 the Free Software Foundation, either version 3 of the License, or
4456 (at your option) any later version.
4457
4458 This program is distributed in the hope that it will be useful,
4459 but WITHOUT ANY WARRANTY; without even the implied warranty of
4460 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4461 GNU General Public License for more details.
4462
4463 You should have received a copy of the GNU General Public License
4464 along with this program. If not, see <http://www.gnu.org/licenses/>.
4465
4466 The author's address is seanerikoconnor!AT!gmail!DOT!com
4467 with the !DOT! replaced by . and the !AT! replaced by @"
4468 )
4469)
4470
4471
4472
4473; ------------------------------------------------------------------------------
4474;
4475; NAME
4476;
4477; load-input-and-initialize
4478;
4479; DESCRIPTION
4480;
4481; Load the grammar from file. Initialize global variables.
4482;
4483; CALLING SEQUENCE
4484;
4485; (load-input-and-initialize filename)
4486;
4487; filename Name of the file containing the productions and terminals for
4488; the grammar.
4489;
4490; Returns: *terminals* After this is read from file, we add the extra
4491; terminal $ (the language's right endmarker).
4492;
4493; *productions* After reading the list of productions,
4494;
4495; [A -> alpha | beta ...]
4496;
4497; from file, we split up the alternates to
4498; generate the set of productions
4499;
4500; [A -> alpha], [A -> beta], ...
4501;
4502; *first-derived-terminals*
4503; *epsilon-free-first-derived-terminals*
4504;
4505; Set to NIL.
4506;
4507; *has-epsilon-productions*
4508;
4509; Set to NIL unless we have epsilon
4510; productions of the
4511; form A -> EPSILON.
4512;
4513; *conflicts* Set to NIL.
4514;
4515; *goto-graph*,
4516; *action-table*
4517; *goto-table* Set to NIL just for the hell of it.
4518;
4519; EXAMPLE
4520;
4521; (load-input-and-initialize "grammar.dat")
4522;
4523; *productions* => ((S -> S |a| S |b|) (S -> EPSILON)
4524; *terminals* => (|a| |b| $)
4525; *first-derived-terminals* => NIL
4526; *epsilon-free-first-derived-terminals* => NIL
4527; *conflicts* => NIL
4528; *has-epsilon-productions* => NIL
4529;
4530; ------------------------------------------------------------------------------
4531
4532(defun load-input-and-initialize( grammar-file )
4533
4534; Better safe than sorry.
4535(setq *goto-graph* nil)
4536(setq *action-table* nil)
4537(setq *goto-table* nil)
4538(setq *conflicts* nil)
4539(setq *first-derived-terminals* nil)
4540(setq *epsilon-free-first-derived-terminals* nil)
4541
4542
4543; Split up productions and add the endmarker to the list of terminals.
4544(let ( (fp (open grammar-file :direction :input)) )
4545
4546 (setq *productions* (read fp))
4547 (setq *terminals* (read fp))
4548
4549 ; Add the endmarker to the list of terminals.
4550 (setq *terminals* (append *terminals* '($)))
4551
4552 ; Split up productions (so we don't handle alternates directly)
4553 (setq *productions* (split-up-productions *productions*))
4554
4555
4556 ; Detect epsilon productions.
4557 (setq *has-epsilon-productions* nil)
4558
4559 (dolist (production *productions*)
4560
4561 (if (epsilon-production? production)
4562
4563 (setq *has-epsilon-productions* T)))
4564
4565 (close fp))
4566)
4567
4568
4569; ------------------------------------------------------------------------------
4570; | compile-all |
4571; ------------------------------------------------------------------------------
4572;
4573; DESCRIPTION
4574;
4575; Compile all the functions in this program, except compile-all itself.
4576;
4577; CALLING SEQUENCE
4578;
4579; (compile-all)
4580;
4581; EXAMPLE
4582;
4583; (compile-all) =>
4584;
4585; ;;; Compiling function LOAD-INPUT-AND-INITIALIZE...tail-merging...
4586; assembling...emitting...done.
4587;
4588; --- and so on, with pauses for garbage collection ---
4589;
4590; ;;; Compiling function PARSER-GENERATOR...assembling...emitting...done
4591; NIL
4592;
4593; ------------------------------------------------------------------------------
4594
4595(defun compile-all()
4596
4597; Tell the compiler the following variables are global (have dynamic binding).
4598
4599 (proclaim '(special *productions*))
4600 (proclaim '(special *has-epsilon-productions*))
4601 (proclaim '(special *terminals*))
4602 (proclaim '(special *first-derived-terminals*))
4603 (proclaim '(special *epsilon-free-first-derived-terminals*))
4604 (proclaim '(special *goto-graph*))
4605 (proclaim '(special *action-table*))
4606 (proclaim '(special *goto-table*))
4607 (proclaim '(special *conflicts*))
4608
4609(let ( (functions-to-compile
4610
4611 '( print-legal-notice
4612 load-input-and-initialize
4613
4614 getHeadOfListUpTo
4615 removeItemFromList
4616 positionInList
4617 insertItemIntoList
4618 combine
4619 itemInList
4620
4621 terminal?
4622 nonterminal?
4623 derives-leading-terminal?
4624 derives-leading-nonterminal?
4625 valid-production?
4626 set-of-items-in-graph? reduction?
4627 is-accept? terminal-after-dot?
4628 equal-sets-of-items?
4629 contained-in-item?
4630 element-of-item?
4631 epsilon-production?
4632 same-symbol?
4633
4634 first-alternate!
4635 all-but-first-alternate!
4636 production-rhs!
4637 symbol-after-dot!
4638 string-before-comma!
4639 lookahead-of!
4640 select-items!
4641 hash-value!
4642 current-state!
4643 action-list!
4644 transition-symbol!
4645 action-line-state!
4646 action-trigger-symbol!
4647
4648 core-of-item!
4649 core-hash-value-of-item
4650 core-hash-value-of-set-of-items
4651 merge-lookaheads
4652 merge-cores
4653
4654 split-up-production
4655 split-up-productions
4656 make-item
4657 move-dot-right
4658 create-augmenting-item
4659 find-grammar-symbols
4660 create-new-node
4661 create-new-link
4662
4663 node-number
4664 item-to-production
4665 production-number
4666 tag-symbol
4667 flag-epsilon-free!
4668 epsilon-free-only
4669 untag-list
4670 flag-non-epsilon-free precedence
4671
4672 derived-leading-terminal
4673 initial-first-derived-terminals
4674 first-terminals-of-rhs
4675 update-first-derived-function
4676 create-all-first-derived-terminals
4677 first-terminals-of-symbol
4678 first-derived-terminals
4679
4680 add-action-or-goto
4681 insert-action-or-goto-into-list
4682 goto closure compute-goto
4683
4684 create-goto-graph
4685 build-action-table
4686 build-goto-table
4687
4688 write-header
4689 write-terminals
4690 write-productions
4691 write-goto-graph
4692 write-action-or-goto-table
4693 write-error-message-table
4694 construct-error-messages
4695
4696 parser-generator
4697 file-exists?
4698 base-path!
4699 test-parser-generator)))
4700
4701; Compile all the functions, except compile-all itself.
4702
4703(dolist (function-to-compile functions-to-compile)
4704
4705 (compile function-to-compile)))
4706)
4707
4708
4709
4710; ==============================================================================
4711; | Main Program |
4712; ==============================================================================
4713
4714; ------------------------------------------------------------------------------
4715; | parser-generator |
4716; ------------------------------------------------------------------------------
4717;
4718; DESCRIPTION
4719;
4720; Main program which produces the LR(1) and LALR(1) parsing tables.
4721;
4722; CALLING SEQUENCE
4723;
4724; (parser-generator in-file out-file :parser-type parser-type)
4725;
4726; in-file Productions and terminals for the grammar. See
4727; the file grammar.dat for an example.
4728;
4729; out-file The numbered productions, goto graph, action and
4730; parsing tables for the grammar. See the files
4731; lalrparser.dat and parser.dat for examples.
4732;
4733; parser-type 'LR1 or 'LALR1 parsing. The default is 'LALR1.
4734;
4735; Returns: A string indicating if any conflicts have occurred.
4736;
4737; EXAMPLE
4738;
4739; (parser-generator "grammar.dat" "parser.dat" :parser-type 'lr1)
4740; => NIL and the file parser.dat
4741;
4742; (parser-generator "grammar.dat" "lalrparser.dat" :parser-type 'lalr1)
4743; => NIL and the file lalrparser.dat
4744;
4745; (parser-generator "grammar.dat" "lalrparser.dat")
4746; => same as above
4747;
4748; (parser-generator "grammar4.dat" "junk" :parser-type 'lalr1)
4749; => "Conflicts were detected" and the file junk.
4750;
4751; ------------------------------------------------------------------------------
4752
4753(defun parser-generator( in-file out-file &key (parser-type 'LALR1) )
4754
4755 ; Keep my lawyer happy.
4756 (print-legal-notice)
4757
4758 ; Read in the grammar file productions and terminals.
4759 (load-input-and-initialize in-file)
4760
4761 (let ( (fp (open out-file :direction :output :if-exists :supersede)) )
4762
4763 ; Compute the goto graph for the grammar.
4764 (setq *goto-graph* (create-goto-graph parser-type))
4765
4766 ; Construct the action and goto parsing tables.
4767 (setq *action-table* (build-action-table *goto-graph*))
4768 (setq *goto-table* (build-goto-table *goto-graph*))
4769
4770 ; Write out the terminals and productions for reference.
4771 (write-header fp parser-type)
4772 (write-terminals fp *terminals*)
4773 (write-productions fp *productions*)
4774
4775 ; Write out the goto graph.
4776 (write-goto-graph fp *goto-graph*)
4777
4778 ; Write out the action and goto parse tables.
4779 (write-action-or-goto-table fp *action-table* :table-type 'ACTION)
4780 (write-action-or-goto-table fp *goto-table* :table-type 'GOTO)
4781
4782 ; Write out the error message template.
4783 (write-error-message-table fp *action-table*)
4784
4785 (close fp)
4786
4787 (if *conflicts*
4788 "Conflicts were detected")
4789 )
4790)
4791
4792
4793
4794; ------------------------------------------------------------------------------
4795; | print-file-to-console |
4796; ------------------------------------------------------------------------------
4797;
4798; DESCRIPTION
4799;
4800; List the lines of a file to the console.
4801;
4802; CALLING SEQUENCE
4803;
4804; (print-file-to-console filename)
4805;
4806; filename Name of the file.
4807;
4808; Returns:
4809;
4810; EXAMPLE
4811;
4812; (print-file-to-console "grammar.dat")
4813; => ; GrammarE=E+T_T.dat
4814; ---------------------------------------------------------------------------
4815;
4816; A grammar of arithmetic expressions,
4817;
4818; E -> E + T | T
4819; ...
4820;
4821; ------------------------------------------------------------------------------
4822
4823(defun print-file-to-console( file-name )
4824 (format t "~%~%=========================== ~A =============================~%~%~%" file-name)
4825
4826 (with-open-file (stream file-name)
4827 (do ( (line (read-line stream nil) ; nil inhibits throw at eof
4828 (read-line stream nil) ) ; and read-line returns nil at eof
4829 )
4830 ( (null line) ) ; Terminate at eof
4831 (format t "~A~%" line)
4832 )
4833 )
4834)
4835
4836
4837(defun component-present-p (value)
4838 (and value (not (eql value :unspecific))))
4839
4840(defun directory-pathname-p (p)
4841 (and
4842 (not (component-present-p (pathname-name p)))
4843 (not (component-present-p (pathname-type p)))
4844 p))
4845
4846(defun pathname-as-directory (name)
4847 (let ((pathname (pathname name)))
4848 (when (wild-pathname-p pathname)
4849 (error "Can't reliably convert wild pathnames."))
4850 (if (not (directory-pathname-p name))
4851 (make-pathname
4852 :directory (append (or (pathname-directory pathname) (list :relative))
4853 (list (file-namestring pathname)))
4854 :name nil
4855 :type nil
4856 :defaults pathname)
4857 pathname)))
4858
4859
4860; ------------------------------------------------------------------------------
4861; | file-exists? |
4862; ------------------------------------------------------------------------------
4863;
4864; DESCRIPTION
4865;
4866; Portable way to check if a file or directory exists.
4867;
4868; CALLING SEQUENCE
4869;
4870; (file-exists? directory-or-file)
4871;
4872; directory-or-file Pathname for directory or file
4873; Returns: t if it is there, nil if not.
4874;
4875;
4876; EXAMPLES
4877;
4878; (file-exists? "/NotThere") => nil
4879; (file-exists? "/Volumes/seanoconnor") => t
4880;
4881; ------------------------------------------------------------------------------
4882
4883(defun file-exists? (pathname)
4884 "Check if the file exists"
4885 #+(or sbcl lispworks openmcl)
4886 (probe-file pathname)
4887
4888 #+(or allegro cmu)
4889 (or (probe-file (pathname-as-directory pathname))
4890 (probe-file pathname))
4891
4892 #+clisp
4893 (or (ignore-errors
4894 (probe-file (pathname-as-file pathname)))
4895 (ignore-errors
4896 (let ((directory-form (pathname-as-directory pathname)))
4897 (when (ext:probe-directory directory-form)
4898 directory-form))))
4899
4900 #-(or sbcl cmu lispworks openmcl allegro clisp)
4901 (error "file-exists-p not implemented")
4902)
4903
4904
4905
4906; ------------------------------------------------------------------------------
4907; | base-path! |
4908; ------------------------------------------------------------------------------
4909;
4910; DESCRIPTION
4911;
4912; Try to find out where the base directory for the web page is located.
4913;
4914; CALLING SEQUENCE
4915;
4916; (base-path!)
4917;
4918; Returns: String of base path or nil if it can't find it.
4919;
4920;
4921; EXAMPLES
4922;
4923; (base-path!) => "C:/Sean/WebSite" ; Got it.
4924; (base-path!) => nil ; Could't find it.
4925;
4926; ------------------------------------------------------------------------------
4927
4928(defun base-path!()
4929 (let ( (possible-directories-list '(
4930 "/cygdrive/c/Sean/WebSite" ; Windows / Cygwin
4931 "/Users/seanoconnor/Desktop/Sean/WebSite" ; Mac OS
4932 "/home/seanoconnor/Desktop/Sean/WebSite" ; Ubuntu Linux
4933 )))
4934
4935 (dolist (base-path possible-directories-list)
4936; (format t "base path = ~S exists = ~S~%" base-path (file-exists? base-path) )
4937 (if (file-exists? base-path) (return (concatenate 'string base-path "/"))))
4938 )
4939)
4940
4941
4942
4943; ------------------------------------------------------------------------------
4944; | test-parser-generator |
4945; ------------------------------------------------------------------------------
4946;
4947; DESCRIPTION
4948;
4949; Run the parser generator on a test grammar and produce test parsing
4950; tables.
4951;
4952; CALLING SEQUENCE
4953;
4954; (test-parser-generator)
4955;
4956; Set the files and paths to your requirements. I'm assuming you've
4957; installed cygwin if you're on a Windows machine.
4958;
4959; ------------------------------------------------------------------------------
4960
4961(defun test-parser-generator()
4962
4963 ; Compile all the functions for speed.
4964 (compile-all)
4965
4966 ; Garbage collect.
4967 (gc)
4968
4969 ; Generate a set of parse tables from a test grammar, both LR(1) and
4970 ; LALR(1).
4971 (let* (
4972 ; Set up the base directory paths.
4973 (base-path (base-path!))
4974
4975 (sub-path "ComputerScience/Compiler/ParserGeneratorAndParser/")
4976 (grammar-path "Grammars/" )
4977 (parse-table-path "ParseTables/")
4978
4979 ; List the grammar files (input) and parse table files (output).
4980 (grammar-file '( "GrammarS=SaSbEPSILON.dat"
4981 "GrammarE=E+T_T.dat"
4982 "GrammarPoly.dat"
4983 "GrammarLR(1)NotLALR(1).dat"
4984 "GrammarNotLR(1)NotLALR(1).dat") )
4985 (parse-file-LR1 '( "ParseTablesLR(1)_S=SaSbEPSILON.dat"
4986 "ParseTablesLR(1)_E=E+T_T.dat"
4987 "ParseTablesLR(1)_Poly.dat"
4988 "ParseTablesLR(1)_NotLALR(1).dat"
4989 "ParseTablesLR(1)_NotLR(1)NotLALR(1).dat") )
4990 (parse-file-LALR1 '( "ParseTablesLALR(1)_S=SaSbEPSILON.dat"
4991 "ParseTablesLALR(1)_E=E+T_T.dat"
4992 "ParseTablesLALR(1)_Poly.dat"
4993 "ParseTablesLALR(1)_NotLALR(1).dat"
4994 "ParseTablesLALR(1)_NotLR(1)NotLALR(1).dat") )
4995 )
4996
4997 (dotimes (i (length grammar-file))
4998
4999 (let* (
5000 ; Create the full file path.
5001 (full-grammar-file
5002 (concatenate 'string
5003 base-path sub-path grammar-path
5004 (nth i grammar-file))
5005 )
5006
5007 (full-parse-file-LR1
5008 (concatenate 'string
5009 base-path sub-path parse-table-path
5010 (nth i parse-file-LR1))
5011 )
5012
5013 (full-parse-file-LALR1
5014 (concatenate 'string
5015 base-path sub-path parse-table-path
5016 (nth i parse-file-LALR1))
5017 )
5018 )
5019
5020 ; Call the parser generator to generate parse tables for
5021 ; both LR(1) and LALR(1).
5022 (parser-generator full-grammar-file full-parse-file-LR1
5023 :parser-type 'LR1)
5024
5025 (parser-generator full-grammar-file full-parse-file-LALR1)
5026
5027 ; Display the results to the console.
5028 (print-file-to-console full-grammar-file)
5029 (print-file-to-console full-parse-file-LR1)
5030 (print-file-to-console full-parse-file-LALR1)
5031 )
5032 )
5033 )
5034)