1#|-----------------------------------------------------------------------------
2
3NAME
4
5 LR(1)AndLALR(1)Parser.lsp
6
7DESCRIPTION
8
9 Bottom up LR(1)/LALR(1) parser. It halts and either accepts a sentence in
10 an LR(1) or LALR(1) grammar or it prints an error message.
11
12
13CALLING SEQUENCE
14
15 Once you are in a Common Lisp interpreter, load this file,
16
17 (load "LR(1)AndLALR(1)Parser.lsp")
18
19 The normal calling sequence is
20
21 (parser "parse-tables.dat" "parse-input.dat" "parse-output.dat")
22
23 You can do an automated test it by calling,
24
25 (test-parser)
26
27 you may have to change the base directory location in the function test-parser.
28
29 Online documentation when you're in the lisp interpreter is given by the
30 standard documentation function,
31
32 (apropos 'element-of?)
33 => ELEMENT-OF?
34 (documentation 'element-of? 'function)
35 (documentation '*productions* 'variable)
36
37
38INPUT FILES:
39
40 parse-tables.dat A numbered list of productions for the grammar,
41 followed by the LR(1) or LALR(1) parsing action and
42 goto tables, followed by a table of error messages.
43 See the file parse-tables.dat for an example.
44
45 parse-input.dat A sequence of sentences to parse. See the file
46 parse-input.dat for an example.
47
48 You can use UNIX's yacc compiler-compiler to generate the parse tables
49 above. Run yacc with the -v option. It generates the y.output file
50 which contains the parsing action and goto tables.
51
52 You can also run my program LR(1)AndLALR(1)ParserGenerator.lsp
53 to get the action and goto tables.
54
55 You'll need to create the error messages yourself, either by looking at
56 the goto graph output of LR(1)AndLALR(1)ParserGenerator.lsp
57 or by the state of the parse in yacc's y.output file.
58
59
60OUTPUT FILES:
61
62 parse-output.dat The results of the parse on the input file. See
63 "parse-output.dat" for an example of correct output.
64
65
66METHOD
67
68 We use algorithm 4.7 [Aho 86, pgs. 216-220] which works like this:
69
70 The initial parser configuration is
71
72 (s0 | a1 ... an $)
73
74 where a1 ... an is the input and s0 = 0 is the initial state.
75 The parse stack is to the left of the bar and the unprocessed
76 input is to the right. Now suppose the configuration is
77
78 (s0 x1 ... xm sm | ai ai+1 ... an $)
79
80 There are four possible things we can do:
81
82 (1) Shift the input. ACTION[ sm, ai ] = shift s
83
84 (s0 X1 ... Xm sm ai s | ai+1 ... an $)
85
86 (2) Reduce. ACTION[ sm, ai ] = reduce( A -> beta )
87
88 (s0 X1 ... Xm-r sm-r A s | ai ai+1 ... an $)
89
90 where s = GOTO[ sm-r, A ] and r = length( beta )
91
92 (3) Accept (i.e. halt). ACTION[ sm, ai ] = accept
93
94 The sentence is in the grammar; we halt and accept it.
95
96 (4) Abort with error. ACTION[ sm, ai ] = error
97
98 We produce the error message using the current parsing state
99 lookahead symbol ai.
100
101REFERENCES
102
103 See http://www.seanerikoconnor.freeservers.com for a review of the
104 parsing theory behind this program.
105
106
107 [Aho 86] COMPILERS: PRINCIPLES, TECHNIQUES, AND TOOLS,
108 Alfred V. Aho, Ravi Sethi, and Jeffrey D. Ullman,
109 Addison-Wesley, 1986.
110
111 [Aho 74] "LR Parsing", Alfred V. Aho and Stephen C. Johnson,
112 Computing Surveys, Vol. 6, No. 2, June 1974, pg. 99-124.
113
114
115AUTHOR
116
117 Sean E. O'Connor 06 Jun 1989 Version 1.0
118
119LEGAL
120
121 LR(1)AndLALR(1)ParserGenerator Version 5.6
122 An LR(1) and LALR(1) Parser Generator written in Common Lisp.
123
124 Copyright (C) 1989-2024 by Sean Erik O'Connor. All Rights Reserved.
125
126 This program is free software: you can redistribute it and/or modify
127 it under the terms of the GNU General Public License as published by
128 the Free Software Foundation, either version 3 of the License, or
129 (at your option) any later version.
130
131 This program is distributed in the hope that it will be useful,
132 but WITHOUT ANY WARRANTY; without even the implied warranty of
133 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
134 GNU General Public License for more details.
135
136 You should have received a copy of the GNU General Public License
137 along with this program. If not, see <http://www.gnu.org/licenses/>.
138
139 The author's address is seanerikoconnor!AT!gmail!DOT!com
140 with the !DOT! replaced by . and the !AT! replaced by @
141
142BUGS
143
144 We'd like to modify the data type of the stack elements so we can
145 associate a semantic action with each reduction.
146
147-----------------------------------------------------------------------------|#
148
149
150; ------------------------------------------------------------------------------
151; | Global Variables |
152; ------------------------------------------------------------------------------
153
154(defvar *productions* nil
155" List of productions of the unaugmented grammar."
156)
157
158(defvar *action-table* nil) ; LR(1) or LALR(1) action table.
159
160(defvar *goto-table* nil) ; LR(1) or LALR(1) goto table.
161
162(defvar *error-message* nil) ; Table of error message for each state.
163
164(defvar *input-stack* nil) ; Input stack of not yet processed symbols.
165
166(defvar *old-input-stack* nil) ; Already processed input.
167
168(defvar *parse-stack* nil) ; Parser stack.
169
170(defvar *terminals* nil)
171
172(defvar *goto-graph* nil)
173
174 (proclaim '(special *goto-table*))
175 (proclaim '(special *error-messages*))
176
177 (proclaim '(special *input-stack*))
178 (proclaim '(special *old-input-stack*))
179 (proclaim '(special *parse-stack*))
180
181; DATA STRUCTURES
182
183; *productions* = (PRODUCTION1 PRODUCTION2...)
184; production = (A -> B C D ...)
185
186
187; *action-table* = (TABLE-LINE1 TABLE-LINE2 ...)
188; table-line = ((STATE1 STATE2 ...) LIST-OF-ACTIONS)
189; list-of-actions = (ACTION-PAIR1 ACTION-PAIR2 ...)
190; action-pair = (TRIGGER-SYMBOL ACTION)
191; action = (S i), (R i), (ACC NIL)
192
193; *goto-table* = (TABLE-LINE1 TABLE-LINE2 ...)
194; table-line = ((STATE1 STATE2 ...) LIST-OF-GOTOS)
195; list-of-gotos = (GOTO-PAIR1 GOTO-PAIR2 ...)
196; goto-pair = (TRIGGER-SYMBOL GOTO-STATE)
197; trigger-symbol = any nonterminal or DEFAULT
198;
199; ------------------------------------------------------------------------------
200
201
202
203; ------------------------------------------------------------------------------
204; | print-legal-notice |
205; ------------------------------------------------------------------------------
206;
207; DESCRIPTION
208;
209; Write legal notice when the program starts up.
210;
211; CALLING SEQUENCE
212;
213; Returns: Legal notice to standard output.
214;
215; EXAMPLE
216;
217; ------------------------------------------------------------------------------
218
219(defun print-legal-notice()
220
221 ; Print a few newlines, the notice and a few more newlines.
222 (format t "~%~%~A~%~%"
223 "
224 LR(1)AndLALR(1)Parser Version 5.6
225
226 An LR(1) and LALR(1) Parser written in Common Lisp.
227
228 Copyright (C) 1989-2024 by Sean Erik O'Connor. All Rights Reserved.
229
230 This program is free software: you can redistribute it and/or modify
231 it under the terms of the GNU General Public License as published by
232 the Free Software Foundation, either version 3 of the License, or
233 (at your option) any later version.
234
235 This program is distributed in the hope that it will be useful,
236 but WITHOUT ANY WARRANTY; without even the implied warranty of
237 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
238 GNU General Public License for more details.
239
240 You should have received a copy of the GNU General Public License
241 along with this program. If not, see <http://www.gnu.org/licenses/>.
242
243 The author's address is seanerikoconnor!AT!gmail!DOT!com
244 with the !DOT! replaced by . and the !AT! replaced by @"
245
246 )
247)
248
249
250
251; ********************************* Input I/O ********************************
252
253
254; ------------------------------------------------------------------------------
255; | print-file-to-console |
256; ------------------------------------------------------------------------------
257;
258; DESCRIPTION
259;
260; List the lines of a file to the console.
261;
262; CALLING SEQUENCE
263;
264; (print-file-to-console filename)
265;
266; filename Name of the file.
267;
268; Returns:
269;
270; EXAMPLE
271;
272; (print-file-to-console "grammar.dat")
273; => ; GrammarE=E+T_T.dat
274; ---------------------------------------------------------------------------
275;
276; A grammar of arithmetic expressions,
277;
278; E -> E + T | T
279; ...
280;
281; ------------------------------------------------------------------------------
282
283(defun print-file-to-console( file-name )
284 (format t "~%~%=========================== ~A =============================~%~%~%" file-name)
285
286 (with-open-file (stream file-name)
287 (do ( (line (read-line stream nil) ; nil inhibits throw at eof
288 (read-line stream nil) ) ; and read-line returns nil at eof
289 )
290 ( (null line) ) ; Terminate at eof
291 (format t "~A~%" line)
292 )
293 )
294)
295
296; ------------------------------------------------------------------------------
297; | load-input-initialize-parser |
298; ------------------------------------------------------------------------------
299;
300; DESCRIPTION
301;
302; Load the productions and the parsing action and goto tables from file.
303;
304; CALLING SEQUENCE
305;
306; (load-input-initialize-parser filename)
307;
308; filename Name of the file containing a numbered list of productions,
309; the parsing action and goto tables, and error messages.
310;
311; Returns:
312; *productions*, *action-table*, *goto-table*, *error-messages*,
313; set to their values in the file. *parse-stack*, *input-stack*,
314; and *old-input-stack* are set to nil.
315;
316; EXAMPLE
317;
318; (load-input-initialize-parser "parse-tables.dat")
319; *productions* => ( ((1) (E -> E + T))
320; ((2) (E -> T))
321; ((3) (T -> T * F))
322; ((4) (T -> F))
323; ((5) (F -> [ E ]))
324; ((6) (F -> ID)) )
325;
326; ------------------------------------------------------------------------------
327
328(defun load-input-initialize-parser( parsing-tables-file )
329
330
331(let ( (fp (open parsing-tables-file :direction :input)) )
332
333 (setq *terminals* (read fp))
334 (setq *productions* (read fp))
335 (setq *goto-graph* (read fp))
336 (setq *action-table* (read fp))
337 (setq *goto-table* (read fp))
338 (setq *error-messages* (read fp))
339
340 (setq *parse-stack* nil)
341 (setq *input-stack* nil)
342 (setq *old-input-stack* nil)
343
344 (close fp))
345)
346
347
348
349
350; ************************** General List Manipulation *************************
351
352(defun element-of?( element list &key (test NIL) )
353"
354 DESCRIPTION
355
356 Find out if an atom or a list is a member of a given list.
357
358 CALLING SEQUENCE
359
360 (element-of? element list :test test)
361 => T if element is in list; NIL if not.
362
363 test The name of the function which tests if two symbols are
364 equal. It should be a function of two arguments which
365 returns T if the symbols are equal and NIL otherwise.
366 test defaults to NIL, in which case we use #'equal to
367 compare.
368
369 EXAMPLE
370
371 (element-of? '(hot dog) '((cool cat) (cool dog))) => NIL
372
373 (defun no-value-judgements( s1 s2 ) (equal (second s1) (second s2)))
374
375 (element-of? '(hot dog) '((cool cat) (cool dog))
376 :test 'no-value-judgements) => T
377"
378
379(cond ( (null list) nil) ; Not in the list.
380
381 ( (if (not (null test)) ; First item matches...
382
383 (funcall test element (first list)) ; ... according to test function
384
385 (equal element (first list))) ; ... according to equal.
386
387 t)
388
389 ( t (element-of? element (rest list) ; Try again on rest of list.
390 :test test)))
391)
392
393
394
395
396; ------------------------------------------------------------------------------
397; | rfirst, rrest and rcons |
398; ------------------------------------------------------------------------------
399;
400; DESCRIPTION
401;
402; Reversed versions of first (car), rest (cdr) and cons.
403;
404; CALLING SEQUENCE
405;
406; (rfirst list) => Last element in list.
407; (rfirst nil) => nil
408; (rrest list) => List with last element deleted.
409; (rfirst nil) => nil
410; (rcons atom list) => List with atom appended to the end.
411;
412; EXAMPLE
413;
414; (rfirst '(I am fnugled)) => fnugled
415; (rrest '(I am fnugled)) => (I am)
416; (rcons 'fnugled '(I am)) => (I am fnugled)
417;
418; ------------------------------------------------------------------------------
419
420(defun rfirst( list )
421
422 (first (reverse list))
423)
424
425(defun rrest( list )
426
427 (reverse (rest (reverse list)))
428)
429
430(defun rcons( atom list )
431
432 `(,@list ,atom)
433)
434
435
436
437
438; ********************************* Predicates *********************************
439
440; ------------------------------------------------------------------------------
441; | shift?, reduce?, accept? and error? |
442; ------------------------------------------------------------------------------
443;
444; DESCRIPTION
445;
446; Operators to recognize different parsing actions.
447;
448; CALLING SEQUENCE
449;
450; (shift? action)
451; (reduce? action)
452; (accept? action)
453; (error? action)
454;
455; action The code for the action to perform from the parsing
456; action table.
457;
458; Returns: T if the action matches the code.
459;
460; EXAMPLE
461;
462; (shift? '(s 5)) => T
463; (reduce? '(r 3)) => T
464; (accept? '(acc nil)) => T
465; (error? '(error "sample error message")) => T
466;
467; ------------------------------------------------------------------------------
468
469(defun shift?( action )
470
471 (equal (first action) 's)
472)
473
474(defun reduce?( action )
475
476 (equal (first action) 'r)
477)
478
479(defun accept?( action )
480
481 (equal (first action) 'acc)
482)
483
484(defun error?( action )
485
486 (equal (first action) 'error)
487)
488
489
490
491
492; ********************************* Table Lookup *******************************
493
494; ------------------------------------------------------------------------------
495; | list-lookup |
496; ------------------------------------------------------------------------------
497;
498; DESCRIPTION
499;
500; Lookup an item in a line of an action, goto or error message table by
501; state and by symbol.
502;
503; CALLING SEQUENCE
504;
505; (list-lookup symbol table :table-type type)
506;
507; symbol The transition symbol for action or goto. Ignored when
508; looking up an error message. You can set it to nil.
509;
510; list A line of an action, goto or error message table to search.
511;
512; table-type The type of table to lookup in: 'action or 'goto.
513; Defaults to 'action.
514;
515; Returns: The action to take (for an action table) or the new state
516; (for a goto table).
517;
518; EXAMPLE
519;
520; Please refer to the file parse-tables.dat.
521;
522; (list-lookup 'ID '( ([ (S 4)) (ID (S 5)) (DEFAULT ERROR) )
523; :table-type 'action) => (S 5)
524;
525; (list-lookup 'F '( (T 9) (F 3) (DEFAULT ERROR) ) :table-type 'goto) => 3
526;
527; ------------------------------------------------------------------------------
528
529(defun list-lookup( symbol list &key (table-type 'action) )
530
531(cond ( (or (equal (first (first list)) symbol) ; Found symbol.
532 (equal (length list) 1)) ; Not found - use default
533 ; (last) item.
534 (cond ( (or (equal table-type 'action)
535 (equal table-type 'goto))
536
537 (second (first list)))))
538
539
540 ( t (list-lookup symbol (rest list) :table-type table-type)))
541)
542
543
544; ------------------------------------------------------------------------------
545; | table-lookup |
546; ------------------------------------------------------------------------------
547;
548; DESCRIPTION
549;
550; Lookup an item in an action, goto or error message table by state and
551; by symbol.
552;
553; CALLING SEQUENCE
554;
555; (table-lookup state symbol table :table-type type)
556;
557; state The number of the state or production.
558;
559; symbol The transition symbol for action or goto. Ignored when
560; looking up an error message or production. Set it to
561; nil for these two cases.
562;
563; table The action, goto or error message table to search in.
564;
565; table-type The type of table to lookup in: 'action, 'goto,
566; 'error-message or 'production. Defaults to 'action.
567;
568; Returns: The action to take (for an action table), the new state
569; (for a goto table), the error message (for an error message
570; table) the production (for the list of productions).
571; We return NIL if state was not found.
572;
573; EXAMPLE
574;
575; Please refer to the file parse-tables.dat.
576;
577; (table-lookup 6 'ID *action-table* :table-type 'action) => (S 5)
578;
579; (table-lookup 6 'F *goto-table* :table-type 'goto) => 3
580;
581; (table-lookup 66 'F *goto-table* :table-type 'goto) => NIL
582;
583; (table-lookup 6 nil *error-messages* :table-type 'error-message)
584; => "Missing id or left parenthesis"
585;
586; (table-lookup 6 nil *productions* :table-type 'production)
587; => (F -> ID)
588;
589; ------------------------------------------------------------------------------
590
591(defun table-lookup( state symbol table &key (table-type 'action) )
592
593(let ((first-line-of-table (first table)))
594
595; Does this line contain the state we want?
596
597(cond ( (null table) nil)
598
599 ( (element-of? state (first first-line-of-table))
600
601; If so, find the entry for the corresponding symbol.
602
603 (cond ( (equal table-type 'error-message)
604
605 (first (second first-line-of-table)) )
606
607 ( (equal table-type 'production)
608
609 (second first-line-of-table) )
610
611 (t (list-lookup symbol (second first-line-of-table)
612 :table-type table-type))))
613
614; State wasn't found in the first line of the table. Search the rest of the
615; table.
616
617 ( t (table-lookup state symbol (rest table) :table-type table-type))))
618)
619
620
621
622
623
624; ****************************** Parsing Functions *****************************
625
626; ------------------------------------------------------------------------------
627; | shift! |
628; ------------------------------------------------------------------------------
629;
630; DESCRIPTION
631;
632; Make one parsing shift move.
633;
634; CALLING SEQUENCE
635;
636; (shift! state-to-shift)
637;
638; state-to-shift State to be shifted onto the top of the stack.
639;
640; Returns: (SHIFT state-to-shift)
641; We transfer one token from the input stack to the
642; parse stack and also append it to the old input stack.
643; We also place state-to-shift on top of the parse stack.
644;
645; EXAMPLE
646;
647; (setq *parse-stack* '(0))
648; (setq *input-stack* '(id + [ id * id ] $))
649;
650; (shift! 5) => (SHIFT 5)
651;
652; *parse-stack* => (0 id 5)
653; *input-stack* => (+ [ id * id ] $)
654;
655; ------------------------------------------------------------------------------
656
657(defun shift!( state-to-shift )
658
659; Shift one token from the input stack to the parse stack.
660; Save the token on the old input stack.
661; Pop this token from the input stack.
662
663(setq *parse-stack* (rcons (first *input-stack*) *parse-stack*))
664
665(setq *old-input-stack* (rcons (first *input-stack*) *old-input-stack*))
666
667(setq *input-stack* (rest *input-stack*))
668
669
670; Shift the new state onto the parse stack.
671
672(setq *parse-stack* (rcons state-to-shift *parse-stack*))
673
674`(shift ,state-to-shift)
675)
676
677
678
679
680; ------------------------------------------------------------------------------
681; | reduce! |
682; ------------------------------------------------------------------------------
683;
684; DESCRIPTION
685;
686; Make one parsing reduce move.
687;
688; CALLING SEQUENCE
689;
690; (reduce! production-number)
691;
692; production-number State to be shifted onto the top of the stack.
693;
694; Returns: (REDUCE production-number production)
695;
696; Pop twice the number of tokens in the right hand side
697; of the production off the parse stack.
698;
699; Find out the goto state, then push the left hand side
700; of the production and the goto state onto the parse
701; stack.
702;
703; EXAMPLE
704;
705; (setq *parse-stack* '(0 id 5))
706; (setq *input-stack* '(id + [ id * id ] $))
707;
708; (reduce! 6) => (REDUCE 6 (F -> ID))
709;
710; *parse-stack* => (0 F 3)
711; *input-stack* => (ID + [ ID * ID ] $)
712;
713; ------------------------------------------------------------------------------
714
715(defun reduce!( production-number )
716
717; Fetch the production.
718
719(let* ( (production (table-lookup production-number nil *productions*
720 :table-type 'production))
721
722; Get the production's right hand side length and its left hand side
723; non-terminal. If it is an epsilon production, A -> EPSILON, the
724; length is zero.
725
726 (production-length
727
728 (if (equal (last production) '(EPSILON))
729
730 0
731 (length (nthcdr 2 production))))
732
733 (non-term (first production))
734 (goto-state nil) )
735
736
737
738; Pop off the grammar symbols and states corresponding to the production.
739
740 (setq *parse-stack* (reverse (nthcdr (* 2 production-length)
741 (reverse *parse-stack*))))
742
743; Find out the goto state.
744
745 (setq goto-state (table-lookup (rfirst *parse-stack*)
746 non-term
747 *goto-table*))
748
749; Push the non-terminal onto the parse stack.
750
751 (setq *parse-stack* (rcons non-term *parse-stack*))
752
753
754; Push the goto state.
755
756 (setq *parse-stack* (rcons goto-state *parse-stack*))
757
758
759`(reduce ,production-number ,production))
760
761)
762
763
764
765
766; ------------------------------------------------------------------------------
767; | error-message |
768; ------------------------------------------------------------------------------
769;
770; DESCRIPTION
771;
772; Return an error message.
773;
774; CALLING SEQUENCE
775;
776; (error-message)
777;
778; Returns: (ERROR "error message")
779; The error message is based upon the current state on
780; top of the stack.
781;
782; EXAMPLE
783;
784; (setq *parse-stack* '(0 E 1 + 6))
785;
786; (error-message) => (ERROR "Missing id or left parenthesis")
787;
788; ------------------------------------------------------------------------------
789
790(defun error-message()
791
792(let ( (state (rfirst *parse-stack*)) )
793
794
795; Lookup the error message.
796
797`(error ,(table-lookup state nil *error-messages*
798 :table-type 'error-message)))
799)
800
801
802
803
804; ------------------------------------------------------------------------------
805; | parse-one-step |
806; ------------------------------------------------------------------------------
807;
808; DESCRIPTION
809;
810; Make one parsing step.
811;
812; CALLING SEQUENCE
813;
814; (parse-one-step)
815;
816; Returns: (ACCEPT), (ERROR <error message>), (SHIFT state)
817; or (REDUCE production-number production).
818;
819; Make changes to *parse-stack*, *input-stack* and
820; *old-input-stack* using the algorithm described
821; under METHOD in the introduction.
822;
823; EXAMPLE
824;
825; (setq *parse-stack* '(0 id 5))
826; (setq *input-stack* '(id + [ id * id ] $))
827;
828; (parse-one-step) => (REDUCE 6 (F -> ID))
829;
830; *parse-stack* => (0 F 3)
831; *input-stack* => (ID + [ ID * ID ] $)
832;
833; ------------------------------------------------------------------------------
834
835(defun parse-one-step()
836
837; Action from action table based on state on top of stack and lookahead.
838
839(let ( (action (table-lookup (rfirst *parse-stack*)
840 (first *input-stack*)
841 *action-table*)) )
842
843 ; Based on the action, update the parse and input stacks.
844 (cond ( (shift? action) (shift! (second action)))
845 ( (reduce? action) (reduce! (second action)))
846 ( (accept? action) '(accept))
847 ( (error? action) (error-message)))
848)
849
850)
851
852
853
854
855; ********************************* Main program *******************************
856
857; ------------------------------------------------------------------------------
858; | parser |
859; ------------------------------------------------------------------------------
860;
861; DESCRIPTION
862;
863; Main program which parses a sentence in an LR(1) or LALR(1) grammar.
864;
865; CALLING SEQUENCE
866;
867; (parser parse-file in-file out-file)
868;
869; parse-file Name of file containing productions, action and goto
870; tables.
871;
872; in-file Name of file containing the sentences to be parsed.
873;
874; out-file Parsing results.
875;
876; EXAMPLE
877;
878; See the files "parse-input.dat" and "parse-output.dat" for sample
879; input and output.
880;
881; ------------------------------------------------------------------------------
882
883(defun parser( parse-file in-file out-file)
884
885(let ( (fp1 (open in-file :direction :input))
886 (fp2 (open out-file :direction :output :if-exists :supersede))
887 (parse-action nil)
888 (raw-input nil) )
889
890; Obligatory legal notice.
891(print-legal-notice)
892
893(load-input-initialize-parser parse-file)
894
895; Parse each sentence in the input.
896
897 (loop
898
899; Exit upon end of file.
900
901 (setq raw-input (read fp1 nil 'eof))
902
903 (if (equal raw-input 'eof) (return))
904
905
906; Read the next input sentence and append the end of input delimiter, $.
907
908 (setq *input-stack* (rcons '$ raw-input))
909
910
911; Print an introductory header.
912
913 (write-line (format nil "~%~%~%~A~S~%"
914 "Parsing the sentence: " raw-input) fp2)
915
916 (write-line (format nil "~35A~20@A~3A~25A~%"
917 "PARSE STACK"
918 "INPUT STACK" " "
919 "ACTION") fp2)
920
921 (setq *parse-stack* '(0))
922 (setq *old-input-stack* nil)
923
924
925; Parse each sentence.
926
927 (loop
928
929 ; Print the current parser configuration.
930 (format fp2 "~35S~20@S~3A"
931 *parse-stack*
932 *input-stack* " ")
933
934 ; One step of parsing, with updates to input and parse stacks.
935 (setq parse-action (parse-one-step))
936
937
938; Print the parser action.
939(cond ( (equal (first parse-action) 'error)
940
941 ; Declare error.
942 (write-line (format nil "~25A~%"
943 "ERROR") fp2)
944
945 ; Print the error message.
946 (write-line (format nil "~A~%" (second parse-action)) fp2)
947 )
948
949 (t
950 (write-line (format nil "~25S~%" parse-action) fp2))
951)
952
953
954; Accept the sentence, or halt with error.
955
956 (cond ( (equal (first parse-action) 'accept)
957
958 (write-line (format nil "~A~%"
959 "Sentence was grammatical.")
960 fp2)
961 (fresh-line fp2)
962 (fresh-line fp2)
963 (return) )
964
965 ( (equal (first parse-action) 'error)
966
967 (write-line (format nil "~A~%"
968 "Sentence was not in the grammar.")
969 fp2)
970 (fresh-line fp2)
971 (fresh-line fp2)
972 (return) ))))
973
974 (close fp1)
975 (close fp2))
976)
977
978
979
980; ------------------------------------------------------------------------------
981; | parser-compile-all |
982; ------------------------------------------------------------------------------
983;
984; DESCRIPTION
985;
986; Compile all the functions in this program, except parser-compile-all itself.
987;
988; CALLING SEQUENCE
989;
990; (parser-compile-all)
991;
992; EXAMPLE
993;
994; (parser-compile-all) =>
995;
996; ;;; Compiling function LOAD-INPUT-AND-INITIALIZE...tail-merging...
997; assembling...emitting...done.
998;
999; --- and so on, with pauses for garbage collection ---
1000;
1001; ;;; Compiling function PARSER-GENERATOR...assembling...emitting...done
1002; NIL
1003;
1004; ------------------------------------------------------------------------------
1005
1006(defun parser-compile-all()
1007
1008; Tell the compiler the following variables are global (have dynamic binding).
1009
1010 (proclaim '(special *terminals*))
1011 (proclaim '(special *goto-graph*))
1012 (proclaim '(special *productions*))
1013 (proclaim '(special *action-table*))
1014 (proclaim '(special *goto-table*))
1015 (proclaim '(special *error-messages*))
1016
1017 (proclaim '(special *input-stack*))
1018 (proclaim '(special *old-input-stack*))
1019 (proclaim '(special *parse-stack*))
1020
1021(let ( (functions-to-compile
1022
1023 '(load-input-initialize-parser
1024
1025 element-of?
1026 rfirst
1027 rrest
1028 rcons
1029
1030 shift?
1031 reduce?
1032 accept?
1033 error?
1034
1035 table-lookup
1036 list-lookup
1037
1038 shift!
1039 reduce!
1040 error-message
1041
1042 parse-one-step
1043
1044 parser
1045
1046 print-file-to-console
1047 file-exists?
1048 base-path!
1049 test-parser)))
1050
1051
1052; Compile all the functions, except parser-compile-all itself.
1053
1054(dolist (function-to-compile functions-to-compile)
1055
1056 (compile function-to-compile)))
1057)
1058
1059
1060(defun component-present-p (value)
1061 (and value (not (eql value :unspecific))))
1062
1063(defun directory-pathname-p (p)
1064 (and
1065 (not (component-present-p (pathname-name p)))
1066 (not (component-present-p (pathname-type p)))
1067 p))
1068
1069(defun pathname-as-directory (name)
1070 (let ((pathname (pathname name)))
1071 (when (wild-pathname-p pathname)
1072 (error "Can't reliably convert wild pathnames."))
1073 (if (not (directory-pathname-p name))
1074 (make-pathname
1075 :directory (append (or (pathname-directory pathname) (list :relative))
1076 (list (file-namestring pathname)))
1077 :name nil
1078 :type nil
1079 :defaults pathname)
1080 pathname)))
1081
1082
1083; ------------------------------------------------------------------------------
1084; | file-exists? |
1085; ------------------------------------------------------------------------------
1086;
1087; DESCRIPTION
1088;
1089; Portable way to check if a file or directory exists.
1090;
1091; CALLING SEQUENCE
1092;
1093; (file-exists? directory-or-file)
1094;
1095; directory-or-file Pathname for directory or file
1096; Returns: t if it is there, nil if not.
1097;
1098;
1099; EXAMPLES
1100;
1101; (file-exists? "/NotThere") => nil
1102; (file-exists? "/Volumes/seanoconnor") => t
1103;
1104; ------------------------------------------------------------------------------
1105
1106(defun file-exists? (pathname)
1107 "Check if the file exists"
1108 #+(or sbcl lispworks openmcl)
1109 (probe-file pathname)
1110
1111 #+(or allegro cmu)
1112 (or (probe-file (pathname-as-directory pathname))
1113 (probe-file pathname))
1114
1115 #+clisp
1116 (or (ignore-errors
1117 (probe-file (pathname-as-file pathname)))
1118 (ignore-errors
1119 (let ((directory-form (pathname-as-directory pathname)))
1120 (when (ext:probe-directory directory-form)
1121 directory-form))))
1122
1123 #-(or sbcl cmu lispworks openmcl allegro clisp)
1124 (error "file-exists-p not implemented")
1125)
1126
1127
1128
1129; ------------------------------------------------------------------------------
1130; | base-path! |
1131; ------------------------------------------------------------------------------
1132;
1133; DESCRIPTION
1134;
1135; Try to find out where the base directory for the web page is located.
1136;
1137; CALLING SEQUENCE
1138;
1139; (base-path!)
1140;
1141; Returns: String of base path or nil if it can't find it.
1142;
1143;
1144; EXAMPLES
1145;
1146; (base-path!) => "C:/Sean/WebSite" ; Got it.
1147; (base-path!) => nil ; Could't find it.
1148;
1149; ------------------------------------------------------------------------------
1150
1151(defun base-path!()
1152 (let ( (possible-directories-list '(
1153 "/cygdrive/c/Sean/WebSite" ; Windows / Cygwin
1154 "/Users/seanoconnor/Desktop/Sean/WebSite" ; Mac OS
1155 "/home/seanoconnor/Desktop/Sean/WebSite" ; Ubuntu Linux
1156 )))
1157
1158 (dolist (base-path possible-directories-list)
1159; (format t "base path = ~S exists = ~S~%" base-path (file-exists? base-path) )
1160 (if (file-exists? base-path) (return (concatenate 'string base-path "/"))))
1161 )
1162)
1163
1164
1165
1166; ------------------------------------------------------------------------------
1167; | test-parser |
1168; ------------------------------------------------------------------------------
1169;
1170; DESCRIPTION
1171;
1172; Run the parser on test input.
1173;
1174; CALLING SEQUENCE
1175;
1176; (test-parser)
1177;
1178; Set the files and paths to your requirements. I'm assuming you've
1179; installed cygwin if you're on a Windows machine.
1180;
1181; ------------------------------------------------------------------------------
1182
1183(defun test-parser()
1184
1185 ; Compile all the functions for speed.
1186 (parser-compile-all)
1187
1188 ; Parse sentences using the parse tables.
1189 (let* (
1190 ; Set up the base directory paths.
1191 (base-path (base-path!))
1192 (sub-path "ComputerScience/Compiler/ParserGeneratorAndParser/")
1193 (parse-table-path "ParseTables/")
1194 (sentence-path "Sentences/" )
1195
1196 ; List the parse table files and sentences (inputs) and
1197 ; parsed sentence files (output).
1198 (parse-table-file '( "ParseTablesLALR(1)_S=SaSbEPSILON.dat"
1199 "ParseTablesLALR(1)_E=E+T_T.dat"
1200 "ParseTablesLALR(1)_Poly.dat" ) )
1201 (sentence-file '( "SentencesS=SaSbEPSILON.dat"
1202 "SentencesE=E+T_T.dat"
1203 "SentencesPoly.dat" ) )
1204 (parsed-file '( "ParsedSentencesLALR(1)S=SaSbEPSILON.dat"
1205 "ParsedSentencesLALR(1)E=E+T_T.dat"
1206 "ParsedSentencesLALR(1)Poly.dat") )
1207 )
1208
1209 (dotimes (i (length parse-table-file))
1210 (let* (
1211 ; Create the full file path.
1212 (full-parse-table-file
1213 (concatenate 'string
1214 base-path sub-path parse-table-path
1215 (nth i parse-table-file))
1216 )
1217
1218 (full-sentence-file
1219 (concatenate 'string
1220 base-path sub-path sentence-path
1221 (nth i sentence-file))
1222 )
1223
1224 (full-parsed-file
1225 (concatenate 'string
1226 base-path sub-path sentence-path
1227 (nth i parsed-file))
1228 )
1229 )
1230
1231 ; Call the parser.
1232 (parser full-parse-table-file full-sentence-file
1233 full-parsed-file)
1234
1235 ; Display the results to the console.
1236 (print-file-to-console full-parsed-file)
1237 (print-file-to-console full-sentence-file)
1238 (print-file-to-console full-parsed-file)
1239 )
1240 )
1241 )
1242)