Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Parsers for expressions with binary operators | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
11 | ;;; |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
26 | (cl:in-package #:sod-parser) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
122cd950 | 29 | ;;; Basic protocol. |
dea4d055 MW |
30 | |
31 | (defclass expression-parse-state () | |
32 | ((opstack :initform nil :type list) | |
33 | (valstack :initform nil :type list) | |
34 | (nesting :initform 0 :type fixnum)) | |
35 | (:documentation | |
36 | "State for the expression parser. Largely passive.")) | |
37 | ||
122cd950 MW |
38 | (defgeneric push-operator (operator state) |
39 | (:documentation | |
40 | "Push an OPERATOR onto the STATE's operator stack. | |
41 | ||
42 | This should apply existing stacked operators as necessary to obey the | |
43 | language's precedence rules.")) | |
44 | ||
45 | (defgeneric apply-operator (operator state) | |
46 | (:documentation | |
47 | "Apply the OPERATOR to arguments on the STATE's value stack. | |
48 | ||
49 | This should pop any necessary arguments, and push the result.")) | |
dea4d055 MW |
50 | |
51 | (defmethod push-operator (operator (state expression-parse-state)) | |
52 | (with-slots (opstack) state | |
53 | (loop | |
54 | (when (null opstack) (return)) | |
55 | (let ((head (car opstack))) | |
56 | (ecase (operator-push-action head operator) | |
57 | (:push (return)) | |
58 | (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~ | |
59 | operators aren't associative" | |
60 | head operator)) | |
61 | (:apply (apply-operator head state) | |
62 | (setf opstack (cdr opstack)))))) | |
63 | (push operator opstack))) | |
64 | ||
65 | (defgeneric apply-pending-operators (state) | |
66 | (:documentation | |
67 | "Apply all of the pending operators to their arguments. | |
68 | ||
69 | The return value is the final result of the parse. By the time all of the | |
70 | operators have been applied, of course, there ought to be exactly one | |
71 | operand remaining.") | |
72 | (:method ((state expression-parse-state)) | |
73 | (with-slots (opstack valstack) state | |
74 | (dolist (operator opstack) | |
75 | (apply-operator operator state)) | |
76 | (assert (and (consp valstack) (null (cdr valstack)))) | |
77 | (pop valstack)))) | |
78 | ||
79 | ;;;-------------------------------------------------------------------------- | |
80 | ;;; Basic operator implementation. | |
81 | ||
82 | (defmethod operator-push-action (left right) | |
83 | (let ((lprec (operator-right-precedence left)) | |
84 | (rprec (operator-left-precedence right))) | |
85 | (cond ((< lprec rprec) :push) | |
86 | ((> lprec rprec) :apply) | |
87 | (t (let ((lassoc (operator-associativity left)) | |
88 | (rassoc (operator-associativity right))) | |
89 | (cond ((not (eq lassoc rassoc)) | |
90 | (cerror* "Parse error: ... ~A ... ~A ...: ~ | |
91 | inconsistent associativity: ~ | |
92 | ~(~A~) versus ~(~A~))" | |
93 | left right | |
94 | (or lassoc "none") (or rassoc "none")) | |
95 | :apply) | |
96 | ((not lassoc) | |
97 | (cerror* "Parse error: ... ~A ... ~A ...: ~ | |
98 | operators are not associative" | |
99 | left right) | |
100 | :apply) | |
101 | ((eq lassoc :left) :apply) | |
102 | ((eq lassoc :right) :push) | |
103 | (t (error "Invalid associativity ~S ~ | |
104 | for operators ~A and ~A" | |
105 | lassoc left right)))))))) | |
106 | ||
107 | (defmethod print-object ((operator simple-operator) stream) | |
108 | (maybe-print-unreadable-object (operator stream :type t) | |
109 | (princ (operator-name operator) stream))) | |
110 | ||
111 | (defmethod shared-initialize :after | |
112 | ((operator simple-binary-operator) slot-names &key) | |
113 | (when (slot-boundp operator 'lprec) | |
114 | (default-slot (operator 'rprec slot-names) | |
115 | (slot-value operator 'lprec)))) | |
116 | ||
dea4d055 MW |
117 | (defmethod push-operator |
118 | ((operator prefix-operator) (state expression-parse-state)) | |
119 | ||
120 | ;; It's not safe to apply stacked operators here. Already-stacked prefix | |
121 | ;; operators won't have their operands yet, so we'll end up in an | |
122 | ;; inconsistent state. | |
123 | (with-slots (opstack) state | |
124 | (push operator opstack))) | |
125 | ||
126 | (defmethod apply-operator | |
127 | ((operator simple-unary-operator) (state expression-parse-state)) | |
4b8e5c03 | 128 | (with-slots ((function %function)) operator |
dea4d055 MW |
129 | (with-slots (valstack) state |
130 | (assert (not (null valstack))) | |
131 | (push (funcall function (pop valstack)) valstack)))) | |
132 | ||
133 | (defmethod apply-operator | |
134 | ((operator simple-binary-operator) (state expression-parse-state)) | |
4b8e5c03 | 135 | (with-slots ((function %function)) operator |
dea4d055 MW |
136 | (with-slots (valstack) state |
137 | (assert (not (or (null valstack) | |
138 | (null (cdr valstack))))) | |
139 | (let ((second (pop valstack)) | |
140 | (first (pop valstack))) | |
141 | (push (funcall function first second) valstack))))) | |
142 | ||
143 | ;;;-------------------------------------------------------------------------- | |
144 | ;;; Parenthesis protocol implementation. | |
145 | ||
146 | (defmethod push-operator :after | |
147 | ((paren open-parenthesis) (state expression-parse-state)) | |
148 | (with-slots (nesting) state | |
149 | (incf nesting))) | |
150 | ||
151 | (defmethod push-operator | |
152 | ((paren close-parenthesis) (state expression-parse-state)) | |
153 | (with-slots (opstack nesting) state | |
154 | (with-slots (tag) paren | |
155 | (flet ((fail () | |
156 | (cerror* "Parse error: spurious `~A'" tag) | |
157 | (return-from push-operator))) | |
158 | (loop | |
159 | (when (null opstack) (fail)) | |
160 | (let ((head (car opstack))) | |
161 | (cond ((not (typep head 'open-parenthesis)) | |
162 | (apply-operator head state)) | |
54fa7095 | 163 | ((not (eql (slot-value head 'tag) tag)) |
dea4d055 MW |
164 | (fail)) |
165 | (t | |
166 | (return))) | |
167 | (setf opstack (cdr opstack)))) | |
168 | (setf opstack (cdr opstack)) | |
169 | (decf nesting))))) | |
170 | ||
171 | (defmethod apply-operator | |
172 | ((paren open-parenthesis) (state expression-parse-state)) | |
173 | (with-slots (tag) paren | |
174 | (cerror* "Parse error: missing `~A'" tag))) | |
175 | ||
176 | (defmethod operator-push-action (left (right open-parenthesis)) | |
1d8cc67a | 177 | (declare (ignore left)) |
dea4d055 MW |
178 | :push) |
179 | ||
180 | (defmethod operator-push-action ((left open-parenthesis) right) | |
1d8cc67a | 181 | (declare (ignore right)) |
dea4d055 MW |
182 | :push) |
183 | ||
184 | ;;;-------------------------------------------------------------------------- | |
185 | ;;; Main expression parser implementation. | |
186 | ||
187 | (defun parse-expression (p-operand p-binop p-preop p-postop) | |
bf090e02 MW |
188 | "Parse an expression consisting of operands and various kinds of operators. |
189 | ||
190 | The arguments are all parser functions: they will be called with one | |
191 | argument NESTEDP, which indicates whether the parse has encountered an | |
192 | unmatched parenthesis." | |
193 | ||
dea4d055 MW |
194 | (let ((state (make-instance 'expression-parse-state)) |
195 | (consumed-any-p nil)) | |
196 | ||
197 | (labels ((fail (expected) | |
198 | (return-from parse-expression | |
199 | (values expected nil consumed-any-p))) | |
200 | ||
201 | (parse (parser) | |
202 | (unless parser | |
203 | (return-from parse (values nil nil))) | |
204 | (multiple-value-bind (value winp consumedp) | |
205 | (funcall parser (plusp (slot-value state 'nesting))) | |
206 | (when consumedp (setf consumed-any-p t)) | |
207 | (unless (or winp (not consumedp)) (fail value)) | |
208 | (values value winp))) | |
209 | ||
210 | (get-operand () | |
211 | (loop (multiple-value-bind (value winp) (parse p-preop) | |
212 | (unless winp (return)) | |
213 | (push-operator value state))) | |
214 | (multiple-value-bind (value winp) (parse p-operand) | |
215 | (unless winp (fail value)) | |
122cd950 | 216 | (push value (slot-value state 'valstack))) |
dea4d055 MW |
217 | (loop (multiple-value-bind (value winp) (parse p-postop) |
218 | (unless winp (return)) | |
219 | (push-operator value state))))) | |
220 | ||
221 | (get-operand) | |
222 | (loop | |
223 | (multiple-value-bind (value winp) (parse p-binop) | |
224 | (unless winp (return)) | |
225 | (push-operator value state)) | |
226 | (get-operand)) | |
227 | ||
228 | (values (apply-pending-operators state) t consumed-any-p)))) | |
229 | ||
230 | ;;;----- That's all, folks -------------------------------------------------- |