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 (export 'operator-push-action)
32 (defgeneric operator-push-action (left right)
34 "Determine relative precedence between LEFT and RIGHT operators.
36 Returns one of three possible values:
38 * `:push' means to push the RIGHT operator onto the stack, above the
39 LEFT operator -- i.e., RIGHT has higher precedence than LEFT.
41 * `:apply' means to apply the LEFT operator to arguments immediately
42 and try again, comparing RIGHT to the new topmost operator -- i.e.,
43 LEFT has higher precedence than RIGHT.
45 * `:error' means that the situation is erroneous: a continuable error is
46 signalled and the situation resolved by applying the LEFT operator and
47 then pushing the RIGHT one -- i.e., treating them as having similar
48 precedence and left associativity).
50 There is a default method which decides between `:push' and `:apply' by
51 comparing numerical precedence values."))
54 (defparse expr ((&key (nestedp (gensym "NESTEDP-")))
55 operand binop preop postop)
56 "Parse an expression involving unary and binary operators.
58 Within the parsers for operands and operators, the variable NESTEDP is
59 bound to a generalized boolean which is true if an unmatched open-
60 parenthesis has been seen.
62 The OPERAND parser should produce a value; the various operator parsers
63 (BINOP, PREOP, and POSTOP) should produce objects obeying the `operator'
64 protocol. The final output of the `expr' parse is the result of
65 evaluating the parsed expression. (Of course, the definition of
66 `evaluation' here is determined entirely by the methods on
67 `apply-operator', so the final value may be a parse tree, for example.)
69 Alternatively, the BINOP, PREOP, and POSTOP parsers may be /lists/ of
70 parsers (distinguished because the head of a parser form is expected to be
71 an atom). These are implicitly `or'red together. Within such a list, a
72 parser form beginning `:op' is given special interpretation. The syntax
75 (:op MAKE-OP RECOG &rest ARGS)
77 which has the following effects:
79 * around the expression parser, the expression
83 is evaluated once and the result stashed away; and
85 * a parser of the form
89 is added as one of the alternatives of the disjunction, where OP is the
90 cached operator built in the first step."
94 (declare (ignorable ,nestedp))
97 (if (or (atom oplist) (atom (car oplist))) (values nil oplist)
98 (let ((binds nil) (ops nil))
100 (if (and (consp op) (eq (car op) :op))
102 (recog make-op &rest args) (cdr op)
104 (push `(,var (,make-op ,@args)) binds)
105 (push `(seq ((nil ,recog)) ,var) ops)))
107 (values (nreverse binds) `(or ,@(nreverse ops)))))))
108 (multiple-value-bind (binvars binops) (hack-oplist binop)
109 (multiple-value-bind (prevars preops) (hack-oplist preop)
110 (multiple-value-bind (postvars postops) (hack-oplist postop)
111 `(let (,@binvars ,@prevars ,@postvars)
112 (parse-expression ,(wrap operand)
115 ,(wrap postops))))))))
117 ;;;--------------------------------------------------------------------------
118 ;;; Numerical precedence.
120 (export '(operator-left-precedence operator-right-precedence
121 operator-associativity))
122 (defgeneric operator-left-precedence (operator)
124 "Return the OPERATOR's left-precedence.
126 Higher precedence numbers indicate tighter leftward binding. Under the
127 default method for `operator-push-action', the OPERATOR's left precedence
128 is compared to the existing operators' right precedences to determine the
129 parser's behaviour: if it is higher, then the OPERATOR is pushed;
130 otherwise the existing operator is applied. Thus, equal precedences cause
131 left-associative parsing."))
132 (defgeneric operator-right-precedence (operator)
134 "Return the OPERATOR's right-precedence.
136 Higher precedence numbers indicate tighter rightward binding. Under the
137 default method for `operator-push-action', a new operator's left
138 precedence may be compared to the existing OPERATOR's right precedences to
139 determine the parser's behaviour: if it is higher, then the new operator
140 is pushed; otherwise the existing OPERATOR is applied. Thus, equal
141 precedences cause left-associative parsing."))
143 (defgeneric operator-associativity (operator)
145 "Returns an OPERATOR's associativity, as a symbol.
147 The return value is one of `:left', `:right' or `nil'. If two adjacent
148 operators have the same precedence, their associativities are compared.
149 If both associativities are `:left' then the left-hand operator is
150 considered to have higher precedence; if both are `:right' then the
151 right-hand operator is considered to have higher precedence. If they're
152 inconsistent or `nil', then an error is reported and the behaviour is as
153 if both were `:left'.")
154 (:method (operator) :left))
156 ;;;--------------------------------------------------------------------------
157 ;;; Basic operator protocol.
159 (export 'prefix-operator)
160 (defclass prefix-operator ()
163 "Prefix operator base class.
165 Prefix operators are special because they are pushed at a time when the
166 existing topmost operator on the stack may not have its operand
167 available. It is therefore incorrect to attempt to apply any existing
168 operators without careful checking."))
170 (export 'simple-operator)
171 (defclass simple-operator ()
172 ((%function :initarg :function :reader operator-function)
173 (name :initarg :name :initform "<unnamed operator>"
174 :reader operator-name))
176 "A simple operator applies a FUNCTION to arguments when it is applied.
178 The precise details of the function are left to subclasses to sort out."))
180 (export 'simple-unary-operator)
181 (defclass simple-unary-operator (simple-operator)
184 "A unary operator works on the topmost value on the value stack.
186 The topmost item is popped, the FUNCTION is applied to it, and the result
187 is pushed back on."))
189 (export 'simple-binary-operator)
190 (defclass simple-binary-operator (simple-operator)
191 ((lprec :initarg :left-precedence :initarg :precedence
192 :reader operator-left-precedence)
193 (rprec :initarg :right-precedence :reader operator-right-precedence)
194 (associativity :initarg :associative :initform :left
195 :reader operator-associativity))
197 "A binary operator works on the two topmost values on the value stack.
199 The function's arguments are the two topmost items in /reverse/ order --
200 so the topmost item is second. This is usually what you want.
202 The left and right precedences are settable independently. Usually (and
203 this is the default) you will set them equal, and use the `:associativity'
204 initarg to determine associativity; however, right-associativity can also
205 be obtained by setting the right-precedence lower than the left. Special
206 effects can be obtained by setting them in other ways. Use your
209 (export 'simple-postfix-operator)
210 (defclass simple-postfix-operator (simple-unary-operator)
211 ((lprec :initarg :left-precedence :initarg :precedence
212 :reader operator-left-precedence)
213 (rprec :initarg :right-precedence :reader operator-right-precedence))
215 "A postfix operator is applied to a single operand.
217 The left and right precedences are settable independently. Usually you
218 will want to set them equal (this is the default) and quite high. Special
219 effects can be obtained by doing other things instead; but note that you
220 will get an incorrect parse if the right precedence is lower than the left
221 precedence of a binary operator because the postfix operator will be
222 applied to the result of the binary operator."))
224 (export 'simple-prefix-operator)
225 (defclass simple-prefix-operator (prefix-operator simple-unary-operator)
226 ((rprec :initarg :precedence :reader operator-right-precedence))
228 "A prefix operator is applied to a single operand.
230 There is only one precedence value for a prefix operator: the
231 `prefix-operator' superclass arranges that the left precedence is
232 effectively minus infinity."))
235 (defmacro preop (name (x prec) &body body)
236 "Define a prefix operator.
238 The operator will be called NAME in error messages, and have right
239 precedence PREC. To apply the operator, BODY is evaluated with X bound to
242 `(make-instance 'simple-prefix-operator
245 :function (lambda (,x) ,@body)))
248 (defmacro postop (name (x prec &key rprec) &body body)
249 "Define a postfix operator.
251 The operator will be called NAME in error messages, and have left
252 precedence PREC and right precendence RPREC (defaulting to PREC). To
253 apply the operator, BODY is evaluated with X bound to the operand."
255 (once-only (name prec rprec)
256 `(make-instance 'simple-postfix-operator
258 :left-precedence ,prec
259 :right-precedence ,(or rprec prec)
260 :function (lambda (,x) ,@body))))
263 (defmacro binop (name (x y prec &key rprec (assoc :left)) &body body)
264 "Define a binary operator.
266 The operator will be called NAME in error messages, and have left
267 precedence PREC and right precedence RPREC (defaulting to PREC, implying
268 left associativity under the default `operator-push-action'
269 implementation. To apply the operator, BODY is evaluated with X and Y
270 bound to the operands in the order they were parsed"
272 (once-only (name prec rprec assoc)
273 `(make-instance 'simple-binary-operator
275 :left-precedence ,prec
276 :right-precedence ,(or rprec prec)
278 :function (lambda (,x ,y) ,@body))))
280 ;;;--------------------------------------------------------------------------
283 (defclass parenthesis ()
284 ((tag :initarg :tag :initform nil))
286 "Base class for parenthesis operators."))
288 (export 'open-parenthesis)
289 (defclass open-parenthesis (parenthesis prefix-operator) ())
291 (export 'close-parenthesis)
292 (defclass close-parenthesis (parenthesis) ())
294 (export '(lparen rparen))
296 (make-instance 'open-parenthesis :tag tag))
298 (make-instance 'close-parenthesis :tag tag))
300 ;;;----- That's all, folks --------------------------------------------------