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 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Basic protocol implementation. | |
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 | ||
38 | (defmethod push-value (value (state expression-parse-state)) | |
39 | (with-slots (valstack) state | |
40 | (push value valstack))) | |
41 | ||
42 | (defmethod push-operator (operator (state expression-parse-state)) | |
43 | (with-slots (opstack) state | |
44 | (loop | |
45 | (when (null opstack) (return)) | |
46 | (let ((head (car opstack))) | |
47 | (ecase (operator-push-action head operator) | |
48 | (:push (return)) | |
49 | (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~ | |
50 | operators aren't associative" | |
51 | head operator)) | |
52 | (:apply (apply-operator head state) | |
53 | (setf opstack (cdr opstack)))))) | |
54 | (push operator opstack))) | |
55 | ||
56 | (defgeneric apply-pending-operators (state) | |
57 | (:documentation | |
58 | "Apply all of the pending operators to their arguments. | |
59 | ||
60 | The return value is the final result of the parse. By the time all of the | |
61 | operators have been applied, of course, there ought to be exactly one | |
62 | operand remaining.") | |
63 | (:method ((state expression-parse-state)) | |
64 | (with-slots (opstack valstack) state | |
65 | (dolist (operator opstack) | |
66 | (apply-operator operator state)) | |
67 | (assert (and (consp valstack) (null (cdr valstack)))) | |
68 | (pop valstack)))) | |
69 | ||
70 | ;;;-------------------------------------------------------------------------- | |
71 | ;;; Basic operator implementation. | |
72 | ||
73 | (defmethod operator-push-action (left right) | |
74 | (let ((lprec (operator-right-precedence left)) | |
75 | (rprec (operator-left-precedence right))) | |
76 | (cond ((< lprec rprec) :push) | |
77 | ((> lprec rprec) :apply) | |
78 | (t (let ((lassoc (operator-associativity left)) | |
79 | (rassoc (operator-associativity right))) | |
80 | (cond ((not (eq lassoc rassoc)) | |
81 | (cerror* "Parse error: ... ~A ... ~A ...: ~ | |
82 | inconsistent associativity: ~ | |
83 | ~(~A~) versus ~(~A~))" | |
84 | left right | |
85 | (or lassoc "none") (or rassoc "none")) | |
86 | :apply) | |
87 | ((not lassoc) | |
88 | (cerror* "Parse error: ... ~A ... ~A ...: ~ | |
89 | operators are not associative" | |
90 | left right) | |
91 | :apply) | |
92 | ((eq lassoc :left) :apply) | |
93 | ((eq lassoc :right) :push) | |
94 | (t (error "Invalid associativity ~S ~ | |
95 | for operators ~A and ~A" | |
96 | lassoc left right)))))))) | |
97 | ||
98 | (defmethod print-object ((operator simple-operator) stream) | |
99 | (maybe-print-unreadable-object (operator stream :type t) | |
100 | (princ (operator-name operator) stream))) | |
101 | ||
102 | (defmethod shared-initialize :after | |
103 | ((operator simple-binary-operator) slot-names &key) | |
104 | (when (slot-boundp operator 'lprec) | |
105 | (default-slot (operator 'rprec slot-names) | |
106 | (slot-value operator 'lprec)))) | |
107 | ||
dea4d055 MW |
108 | (defmethod push-operator |
109 | ((operator prefix-operator) (state expression-parse-state)) | |
110 | ||
111 | ;; It's not safe to apply stacked operators here. Already-stacked prefix | |
112 | ;; operators won't have their operands yet, so we'll end up in an | |
113 | ;; inconsistent state. | |
114 | (with-slots (opstack) state | |
115 | (push operator opstack))) | |
116 | ||
117 | (defmethod apply-operator | |
118 | ((operator simple-unary-operator) (state expression-parse-state)) | |
4b8e5c03 | 119 | (with-slots ((function %function)) operator |
dea4d055 MW |
120 | (with-slots (valstack) state |
121 | (assert (not (null valstack))) | |
122 | (push (funcall function (pop valstack)) valstack)))) | |
123 | ||
124 | (defmethod apply-operator | |
125 | ((operator simple-binary-operator) (state expression-parse-state)) | |
4b8e5c03 | 126 | (with-slots ((function %function)) operator |
dea4d055 MW |
127 | (with-slots (valstack) state |
128 | (assert (not (or (null valstack) | |
129 | (null (cdr valstack))))) | |
130 | (let ((second (pop valstack)) | |
131 | (first (pop valstack))) | |
132 | (push (funcall function first second) valstack))))) | |
133 | ||
134 | ;;;-------------------------------------------------------------------------- | |
135 | ;;; Parenthesis protocol implementation. | |
136 | ||
137 | (defmethod push-operator :after | |
138 | ((paren open-parenthesis) (state expression-parse-state)) | |
139 | (with-slots (nesting) state | |
140 | (incf nesting))) | |
141 | ||
142 | (defmethod push-operator | |
143 | ((paren close-parenthesis) (state expression-parse-state)) | |
144 | (with-slots (opstack nesting) state | |
145 | (with-slots (tag) paren | |
146 | (flet ((fail () | |
147 | (cerror* "Parse error: spurious `~A'" tag) | |
148 | (return-from push-operator))) | |
149 | (loop | |
150 | (when (null opstack) (fail)) | |
151 | (let ((head (car opstack))) | |
152 | (cond ((not (typep head 'open-parenthesis)) | |
153 | (apply-operator head state)) | |
54fa7095 | 154 | ((not (eql (slot-value head 'tag) tag)) |
dea4d055 MW |
155 | (fail)) |
156 | (t | |
157 | (return))) | |
158 | (setf opstack (cdr opstack)))) | |
159 | (setf opstack (cdr opstack)) | |
160 | (decf nesting))))) | |
161 | ||
162 | (defmethod apply-operator | |
163 | ((paren open-parenthesis) (state expression-parse-state)) | |
164 | (with-slots (tag) paren | |
165 | (cerror* "Parse error: missing `~A'" tag))) | |
166 | ||
167 | (defmethod operator-push-action (left (right open-parenthesis)) | |
1d8cc67a | 168 | (declare (ignore left)) |
dea4d055 MW |
169 | :push) |
170 | ||
171 | (defmethod operator-push-action ((left open-parenthesis) right) | |
1d8cc67a | 172 | (declare (ignore right)) |
dea4d055 MW |
173 | :push) |
174 | ||
175 | ;;;-------------------------------------------------------------------------- | |
176 | ;;; Main expression parser implementation. | |
177 | ||
178 | (defun parse-expression (p-operand p-binop p-preop p-postop) | |
bf090e02 MW |
179 | "Parse an expression consisting of operands and various kinds of operators. |
180 | ||
181 | The arguments are all parser functions: they will be called with one | |
182 | argument NESTEDP, which indicates whether the parse has encountered an | |
183 | unmatched parenthesis." | |
184 | ||
dea4d055 MW |
185 | (let ((state (make-instance 'expression-parse-state)) |
186 | (consumed-any-p nil)) | |
187 | ||
188 | (labels ((fail (expected) | |
189 | (return-from parse-expression | |
190 | (values expected nil consumed-any-p))) | |
191 | ||
192 | (parse (parser) | |
193 | (unless parser | |
194 | (return-from parse (values nil nil))) | |
195 | (multiple-value-bind (value winp consumedp) | |
196 | (funcall parser (plusp (slot-value state 'nesting))) | |
197 | (when consumedp (setf consumed-any-p t)) | |
198 | (unless (or winp (not consumedp)) (fail value)) | |
199 | (values value winp))) | |
200 | ||
201 | (get-operand () | |
202 | (loop (multiple-value-bind (value winp) (parse p-preop) | |
203 | (unless winp (return)) | |
204 | (push-operator value state))) | |
205 | (multiple-value-bind (value winp) (parse p-operand) | |
206 | (unless winp (fail value)) | |
207 | (push-value value state)) | |
208 | (loop (multiple-value-bind (value winp) (parse p-postop) | |
209 | (unless winp (return)) | |
210 | (push-operator value state))))) | |
211 | ||
212 | (get-operand) | |
213 | (loop | |
214 | (multiple-value-bind (value winp) (parse p-binop) | |
215 | (unless winp (return)) | |
216 | (push-operator value state)) | |
217 | (get-operand)) | |
218 | ||
219 | (values (apply-pending-operators state) t consumed-any-p)))) | |
220 | ||
221 | ;;;----- That's all, folks -------------------------------------------------- |