| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Parsers for expressions with binary operators |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensble Object Design, an object system for C. |
| 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. |
| 30 | |
| 31 | (export 'push-operator) |
| 32 | (defgeneric push-operator (operator state) |
| 33 | (:documentation |
| 34 | "Push an OPERATOR onto the STATE's operator stack. |
| 35 | |
| 36 | This should apply existing stacked operators as necessary to obey the |
| 37 | language's precedence rules.")) |
| 38 | |
| 39 | (export 'push-value) |
| 40 | (defgeneric push-value (value state) |
| 41 | (:documentation |
| 42 | "Push VALUE onto the STATE's value stack. |
| 43 | |
| 44 | The default message just does that without any fuss. It's unlikely that |
| 45 | this will need changing unless you invent some really weird values.")) |
| 46 | |
| 47 | (export 'apply-operator) |
| 48 | (defgeneric apply-operator (operator state) |
| 49 | (:documentation |
| 50 | "Apply the OPERATOR to argument on the STATE's value stack. |
| 51 | |
| 52 | This should pop any necessary arguments, and push the result.")) |
| 53 | |
| 54 | (export 'operator-push-action) |
| 55 | (defgeneric operator-push-action (left right) |
| 56 | (:documentation |
| 57 | "Determine relative precedence between LEFT and RIGHT operators. |
| 58 | |
| 59 | Returns one of three possible values: |
| 60 | |
| 61 | * `:push' means to push the RIGHT operator onto the stack, above the |
| 62 | LEFT operator -- i.e., RIGHT has higher precedence than LEFT. |
| 63 | |
| 64 | * `:apply' means to apply the LEFT operator to arguments immediately |
| 65 | and try again, comparing RIGHT to the new topmost operator -- i.e., |
| 66 | LEFT has higher precedence than RIGHT. |
| 67 | |
| 68 | * `:error' means that the situation is erroneous: a continuable error is |
| 69 | signalled and the situation resolved by applying the LEFT operator and |
| 70 | then pushing the RIGHT one -- i.e., treating them as having similar |
| 71 | precedence and left associativity). |
| 72 | |
| 73 | There is a default method which decides between `:push' and `:apply' by |
| 74 | comparing numerical precedence values.")) |
| 75 | |
| 76 | (export 'expr) |
| 77 | (defparse expr ((&key (nestedp (gensym "NESTEDP-"))) |
| 78 | operand binop preop postop) |
| 79 | "Parse an expression involving unary and binary operators. |
| 80 | |
| 81 | Within the parsers for operands and operators, the variable NESTEDP is |
| 82 | bound to a generalized boolean which is true if an unmatched open- |
| 83 | parenthesis has been seen. |
| 84 | |
| 85 | The OPERAND parser should produce a value; the various operator parsers |
| 86 | (BINOP, PREOP, and POSTOP) should produce objects obeying the `operator' |
| 87 | protocol. The final output of the `expr' parse is the result of |
| 88 | evaluating the parsed expression. (Of course, the definition of |
| 89 | `evaluation' here is determined entirely by the methods on |
| 90 | `apply-operator', so the final value may be a parse tree, for example.)" |
| 91 | |
| 92 | (flet ((wrap (parser) |
| 93 | `(parser (,nestedp) |
| 94 | (declare (ignorable ,nestedp)) |
| 95 | ,parser))) |
| 96 | `(parse-expression ,(wrap operand) |
| 97 | ,(wrap binop) |
| 98 | ,(wrap preop) |
| 99 | ,(wrap postop)))) |
| 100 | |
| 101 | ;;;-------------------------------------------------------------------------- |
| 102 | ;;; Numerical precedence. |
| 103 | |
| 104 | (export '(operator-left-precedence operator-right-precedence)) |
| 105 | (defgeneric operator-left-precedence (operator) |
| 106 | (:documentation |
| 107 | "Return the OPERATOR's left-precedence. |
| 108 | |
| 109 | Higher precedence numbers indicate tighter leftward binding. Under the |
| 110 | default method for `operator-push-action', the OPERATOR's left precedence |
| 111 | is compared to the existing operators' right precedences to determine the |
| 112 | parser's behaviour: if it is higher, then the OPERATOR is pushed; |
| 113 | otherwise the existing operator is applied. Thus, equal precedences cause |
| 114 | left-associative parsing.")) |
| 115 | (defgeneric operator-right-precedence (operator) |
| 116 | (:documentation |
| 117 | "Return the OPERATOR's right-precedence. |
| 118 | |
| 119 | Higher precedence numbers indicate tighter rightward binding. Under the |
| 120 | default method for `operator-push-action', a new operator's left |
| 121 | precedence may be compared to the existing OPERATOR's right precedences to |
| 122 | determine the parser's behaviour: if it is higher, then the new operator |
| 123 | is pushed; otherwise the existing OPERATOR is applied. Thus, equal |
| 124 | precedences cause left-associative parsing.")) |
| 125 | |
| 126 | (defgeneric operator-associativity (operator) |
| 127 | (:documentation |
| 128 | "Returns an OPERATOR's associativity, as a symbol. |
| 129 | |
| 130 | The return value is one of `:left', `:right' or `nil'. If two adjacent |
| 131 | operators have the same precedence, their associativities are compared. |
| 132 | If both associativities are `:left' then the left-hand operator is |
| 133 | considered to have higher precedence; if both are `:right' then the |
| 134 | right-hand operator is considered to have higher precedence. If they're |
| 135 | inconsistent or `nil', then an error is reported and the behaviour is as |
| 136 | if both were `:left'.") |
| 137 | (:method (operator) :left)) |
| 138 | |
| 139 | ;;;-------------------------------------------------------------------------- |
| 140 | ;;; Basic operator protocol. |
| 141 | |
| 142 | (export 'prefix-operator) |
| 143 | (defclass prefix-operator () |
| 144 | () |
| 145 | (:documentation |
| 146 | "Prefix operator base class. |
| 147 | |
| 148 | Prefix operators are special because they are pushed at a time when the |
| 149 | existing topmost operator on the stack may not have its operand |
| 150 | available. It is therefore incorrect to attempt to apply any existing |
| 151 | operators without careful checking. This class provides a method on |
| 152 | `push-operator' which immediately pushes the new operator without |
| 153 | inspecting the existing stack.")) |
| 154 | |
| 155 | (export 'simple-operator) |
| 156 | (defclass simple-operator () |
| 157 | ((%function :initarg :function :reader operator-function) |
| 158 | (name :initarg :name :initform "<unnamed operator>" |
| 159 | :reader operator-name)) |
| 160 | (:documentation |
| 161 | "A simple operator applies a FUNCTION to arguments when it is applied. |
| 162 | |
| 163 | The precise details of the function are left to subclasses to sort out.")) |
| 164 | |
| 165 | (export 'simple-unary-operator) |
| 166 | (defclass simple-unary-operator (simple-operator) |
| 167 | () |
| 168 | (:documentation |
| 169 | "A unary operator works on the topmost value on the value stack. |
| 170 | |
| 171 | The topmost item is popped, the FUNCTION is applied to it, and the result |
| 172 | is pushed back on.")) |
| 173 | |
| 174 | (export 'simple-binary-operator) |
| 175 | (defclass simple-binary-operator (simple-operator) |
| 176 | ((lprec :initarg :left-precedence :initarg :precedence |
| 177 | :reader operator-left-precedence) |
| 178 | (rprec :initarg :right-precedence :reader operator-right-precedence) |
| 179 | (associativity :initarg :associative :initform :left |
| 180 | :reader operator-associativity)) |
| 181 | (:documentation |
| 182 | "A binary operator works on the two topmost values on the value stack. |
| 183 | |
| 184 | The function's arguments are the two topmost items in /reverse/ order -- |
| 185 | so the topmost item is second. This is usually what you want. |
| 186 | |
| 187 | The left and right precedences are settable independently. Usually (and |
| 188 | this is the default) you will set them equal, and use the `:associativity' |
| 189 | initarg to determine associativity; however, right-associativity can also |
| 190 | be obtained by setting the right-precedence lower than the left. Special |
| 191 | effects can be obtained by setting them in other ways. Use your |
| 192 | imagination.")) |
| 193 | |
| 194 | (export 'simple-postfix-operator) |
| 195 | (defclass simple-postfix-operator (simple-unary-operator) |
| 196 | ((lprec :initarg :left-precedence :initarg :precedence |
| 197 | :reader operator-left-precedence) |
| 198 | (rprec :initarg :right-precedence :reader operator-right-precedence)) |
| 199 | (:documentation |
| 200 | "A postfix operator is applied to a single operand. |
| 201 | |
| 202 | The left and right precedences are settable independently. Usually you |
| 203 | will want to set them equal (this is the default) and quite high. Special |
| 204 | effects can be obtained by doing other things instead; but note that you |
| 205 | will get an incorrect parse if the right precedence is lower than the left |
| 206 | precedence of a binary operator because the postfix operator will be |
| 207 | applied to the result of the binary operator.")) |
| 208 | |
| 209 | (export 'simple-prefix-operator) |
| 210 | (defclass simple-prefix-operator (prefix-operator simple-unary-operator) |
| 211 | ((rprec :initarg :precedence :reader operator-right-precedence)) |
| 212 | (:documentation |
| 213 | "A prefix operator is applied to a single operand. |
| 214 | |
| 215 | There is only one precedence value for a prefix operator: the |
| 216 | `prefix-operator' superclass arranges that the left precedence is |
| 217 | effectively minus infinity.")) |
| 218 | |
| 219 | (export 'preop) |
| 220 | (defmacro preop (name (x prec) &body body) |
| 221 | "Define a prefix operator. |
| 222 | |
| 223 | The operator will be called NAME in error messages, and have right |
| 224 | precedence PREC. To apply the operator, BODY is evaluated with X bound to |
| 225 | the operand." |
| 226 | |
| 227 | `(make-instance 'simple-prefix-operator |
| 228 | :name ,name |
| 229 | :precedence ,prec |
| 230 | :function (lambda (,x) ,@body))) |
| 231 | |
| 232 | (export 'postop) |
| 233 | (defmacro postop (name (x prec &key rprec) &body body) |
| 234 | "Define a postfix operator. |
| 235 | |
| 236 | The operator will be called NAME in error messages, and have left |
| 237 | precedence PREC and right precendence RPREC (defaulting to PREC). To |
| 238 | apply the operator, BODY is evaluated with X bound to the operand." |
| 239 | |
| 240 | (once-only (name prec rprec) |
| 241 | `(make-instance 'simple-postfix-operator |
| 242 | :name ,name |
| 243 | :left-precedence ,prec |
| 244 | :right-precedence ,(or rprec prec) |
| 245 | :function (lambda (,x) ,@body)))) |
| 246 | |
| 247 | (export 'binop) |
| 248 | (defmacro binop (name (x y prec &key rprec (assoc :left)) &body body) |
| 249 | "Define a binary operator. |
| 250 | |
| 251 | The operator will be called NAME in error messages, and have left |
| 252 | precedence PREC and right precedence RPREC (defaulting to PREC, implying |
| 253 | left associativity under the default `operator-push-action' |
| 254 | implementation. To apply the operator, BODY is evaluated with X and Y |
| 255 | bound to the operands in the order they were parsed" |
| 256 | |
| 257 | (once-only (name prec rprec assoc) |
| 258 | `(make-instance 'simple-binary-operator |
| 259 | :name ,name |
| 260 | :left-precedence ,prec |
| 261 | :right-precedence ,(or rprec prec) |
| 262 | :associative ,assoc |
| 263 | :function (lambda (,x ,y) ,@body)))) |
| 264 | |
| 265 | ;;;-------------------------------------------------------------------------- |
| 266 | ;;; Parentheses. |
| 267 | |
| 268 | (defclass parenthesis () |
| 269 | ((tag :initarg :tag :initform nil)) |
| 270 | (:documentation |
| 271 | "Base class for parenthesis operators.")) |
| 272 | |
| 273 | (export 'open-parenthesis) |
| 274 | (defclass open-parenthesis (parenthesis prefix-operator) ()) |
| 275 | |
| 276 | (export 'close-parenthesis) |
| 277 | (defclass close-parenthesis (parenthesis) ()) |
| 278 | |
| 279 | (export '(lparen rparen)) |
| 280 | (defun lparen (tag) |
| 281 | (make-instance 'open-parenthesis :tag tag)) |
| 282 | (defun rparen (tag) |
| 283 | (make-instance 'close-parenthesis :tag tag)) |
| 284 | |
| 285 | ;;;----- That's all, folks -------------------------------------------------- |