3 ;;; Parsers for expressions with binary operators
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
26 (cl:in-package #:sod-parser)
28 ;;;--------------------------------------------------------------------------
31 (defclass expression-parse-state ()
32 ((opstack :initform nil :type list)
33 (valstack :initform nil :type list)
34 (nesting :initform 0 :type fixnum))
36 "State for the expression parser. Largely passive."))
38 (defgeneric push-operator (operator state)
40 "Push an OPERATOR onto the STATE's operator stack.
42 This should apply existing stacked operators as necessary to obey the
43 language's precedence rules."))
45 (defgeneric apply-operator (operator state)
47 "Apply the OPERATOR to arguments on the STATE's value stack.
49 This should pop any necessary arguments, and push the result."))
51 (defmethod push-operator (operator (state expression-parse-state))
52 (with-slots (opstack) state
54 (when (null opstack) (return))
55 (let ((head (car opstack)))
56 (ecase (operator-push-action head operator)
58 (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~
59 operators aren't associative"
61 (:apply (apply-operator head state)
62 (setf opstack (cdr opstack))))))
63 (push operator opstack)))
65 (defgeneric apply-pending-operators (state)
67 "Apply all of the pending operators to their arguments.
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
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))))
79 ;;;--------------------------------------------------------------------------
80 ;;; Basic operator implementation.
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~))"
94 (or lassoc "none") (or rassoc "none"))
97 (cerror* "Parse error: ... ~A ... ~A ...: ~
98 operators are not associative"
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))))))))
107 (defmethod print-object ((operator simple-operator) stream)
108 (maybe-print-unreadable-object (operator stream :type t)
109 (princ (operator-name operator) stream)))
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))))
117 (defmethod push-operator
118 ((operator prefix-operator) (state expression-parse-state))
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)))
126 (defmethod apply-operator
127 ((operator simple-unary-operator) (state expression-parse-state))
128 (with-slots ((function %function)) operator
129 (with-slots (valstack) state
130 (assert (not (null valstack)))
131 (push (funcall function (pop valstack)) valstack))))
133 (defmethod apply-operator
134 ((operator simple-binary-operator) (state expression-parse-state))
135 (with-slots ((function %function)) operator
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)))))
143 ;;;--------------------------------------------------------------------------
144 ;;; Parenthesis protocol implementation.
146 (defmethod push-operator :after
147 ((paren open-parenthesis) (state expression-parse-state))
148 (with-slots (nesting) state
151 (defmethod push-operator
152 ((paren close-parenthesis) (state expression-parse-state))
153 (with-slots (opstack nesting) state
154 (with-slots (tag) paren
156 (cerror* "Parse error: spurious `~A'" tag)
157 (return-from push-operator)))
159 (when (null opstack) (fail))
160 (let ((head (car opstack)))
161 (cond ((not (typep head 'open-parenthesis))
162 (apply-operator head state))
163 ((not (eql (slot-value head 'tag) tag))
167 (setf opstack (cdr opstack))))
168 (setf opstack (cdr opstack))
171 (defmethod apply-operator
172 ((paren open-parenthesis) (state expression-parse-state))
173 (with-slots (tag) paren
174 (cerror* "Parse error: missing `~A'" tag)))
176 (defmethod operator-push-action (left (right open-parenthesis))
177 (declare (ignore left))
180 (defmethod operator-push-action ((left open-parenthesis) right)
181 (declare (ignore right))
184 ;;;--------------------------------------------------------------------------
185 ;;; Main expression parser implementation.
187 (defun parse-expression (p-operand p-binop p-preop p-postop)
188 "Parse an expression consisting of operands and various kinds of operators.
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."
194 (let ((state (make-instance 'expression-parse-state))
195 (consumed-any-p nil))
197 (labels ((fail (expected)
198 (return-from parse-expression
199 (values expected nil consumed-any-p)))
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)))
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))
216 (push value (slot-value state 'valstack)))
217 (loop (multiple-value-bind (value winp) (parse p-postop)
218 (unless winp (return))
219 (push-operator value state)))))
223 (multiple-value-bind (value winp) (parse p-binop)
224 (unless winp (return))
225 (push-operator value state))
228 (values (apply-pending-operators state) t consumed-any-p))))
230 ;;;----- That's all, folks --------------------------------------------------