1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
#!/usr/local/calypso
;
; parser - test a parse table
;
;
; data abstraction
;
; a non terminal is a symbol bound to a list of lists
; a terminal is a symbol not bound to a list
; an action is a string
;
(defun non-terminalp (item)
(and (symbolp item)
(boundp item)
(listp (eval item))
)
)
(defun terminalp (item)
(or (null item)
(and (symbolp item)
(not (non-terminalp item))
)
)
)
(defun actionp (item)
(stringp item)
)
(defun null-production (p)
(if (null p)
t
elseif (stringp (car p))
(null-production (cdr p))
else
nil
)
)
(defun start-symbolp (item) (equal item start-symbol))
(defun parser (parse-table start-symbol end-token)
(let ((stack (list start-symbol end-token))
(input-token (lex))
(table-entry)
(tos)
)
(while stack
(patom "stack is ")
(print stack)
(setq tos (car stack)) (setq stack (cdr stack))
(if (non-terminalp tos)
(setq table-entry (dictionary-lookup parse-table
(list input-token tos))
)
(if (null table-entry)
(error (strcat "parser: error on " (sprint input-token)))
)
(patom " pushing production ") (print (cadr table-entry)) (terpr)
(cond ((cadr table-entry)
(setq stack (conc (cadr table-entry) stack))
)
)
elseif (actionp tos)
(patom "token is ") (print input-token)
(patom " performing action ") (print tos) (terpr)
(action tos input-token)
elseif (terminalp tos)
(if (= tos input-token)
(patom " matching token ") (print tos) (terpr)
(if (not (= tos end-token))
(setq input-token (lex))
)
else
(error (strcat "parser error on " (sprint input-token)))
)
)
)
)
)
(defun lex ()
(let ((char (getchar)))
(cond ((or (= char ~ )
(= char ~\t )
)
(lex)
)
((or (= char nil)
(= char -1)
)
(symbol "$" parse-dictionary)
)
(t
(symbol (scons char nil) parse-dictionary)
)
)
)
)
(setq value-stack nil)
(defun pop-stack ()
(let ((t (car value-stack)))
(setq value-stack (cdr value-stack))
t)
)
(defun push-stack (t)
(setq value-stack (cons t value-stack))
t
)
(setq value-temp 0)
(defun action (name value)
(let ((t1) (t2))
(cond ((= "ADD" name)
(push-stack (+ (pop-stack) (pop-stack)))
)
((= "SUBTRACT" name)
(setq t1 (pop-stack))
(setq t2 (pop-stack))
(push-stack (- t2 t1))
)
((= "MULTIPLY" name)
(push-stack (* (pop-stack) (pop-stack)))
)
((= "DIVIDE" name)
(setq t1 (pop-stack))
(setq t2 (pop-stack))
(push-stack (/ t2 t1))
)
((= "PUSH" name)
(push-stack value-temp)
)
((= "NEGATE" name)
(push-stack (- 0 (pop-stack)))
)
((= "CLEAR" name)
(setq value-temp 0)
)
((= "ADD-DIGIT" name)
(setq value-temp (+ (* value-temp 10)
(- (scar (get-name value)) ~0)
)
)
)
((= "PRINT" name)
(print (pop-stack)) (terpr)
)
)
)
)
(defun init ()
(setq parse-table (new-dictionary))
(setq parse-dictionary (new-dictionary))
(setq end-token (symbol "$" parse-dictionary))
)
(defun cadaar (l) (car (cdr (car (car l)))))
(defun bind-to-lists (atoms)
(cond (atoms (set (car atoms) '(foo)) (bind-to-lists (cdr atoms)))
(t nil)
)
)
(defun put-lists-into-parse-table (lists parse-table)
(cond (lists
(dictionary-insert parse-table (caar lists) (car lists))
(put-lists-into-parse-table (cdr lists) parse-table)
)
(t nil)
)
)
(defun process-file (file-in)
(init)
(setq terminals (fread-dictionary file-in parse-dictionary))
(setq non-terminals (fread-dictionary file-in parse-dictionary))
(bind-to-lists non-terminals)
(setq table (fread-dictionary file-in parse-dictionary))
(setq start-symbol (cadaar table))
(put-lists-into-parse-table table parse-table)
(parser parse-table (cadaar table) end-token)
)
(defun main-parser ()
(setq file-in stdin)
(if argv
(setq file-in (fopen (car argv) 'r))
(if (null file-in)
(error (strcat "parser: can't open " (sprint (car argv))))
)
)
(process-file file-in)
(fclose file-in)
)
(main-parser)
|
