--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parsers for expressions with binary operators
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol.
+
+(export 'push-operator)
+(defgeneric push-operator (operator state)
+ (:documentation
+ "Push an OPERATOR onto the STATE's operator stack.
+
+ This should apply existing stacked operators as necessary to obey the
+ language's precedence rules."))
+
+(export 'push-value)
+(defgeneric push-value (value state)
+ (:documentation
+ "Push VALUE onto the STATE's value stack.
+
+ The default message just does that without any fuss. It's unlikely that
+ this will need changing unless you invent some really weird values."))
+
+(export 'apply-operator)
+(defgeneric apply-operator (operator state)
+ (:documentation
+ "Apply the OPERATOR to argument on the STATE's value stack.
+
+ This should pop any necessary arguments, and push the result."))
+
+(export 'operator-push-action)
+(defgeneric operator-push-action (left right)
+ (:documentation
+ "Determine relative precedence between LEFT and RIGHT operators.
+
+ Returns one of three possible values:
+
+ * `:push' means to push the RIGHT operator onto the stack, above the
+ LEFT operator -- i.e., RIGHT has higher precedence than LEFT.
+
+ * `:apply' means to apply the LEFT operator to arguments immediately
+ and try again, comparing RIGHT to the new topmost operator -- i.e.,
+ LEFT has higher precedence than RIGHT.
+
+ * `:error' means that the situation is erroneous: a continuable error is
+ signalled and the situation resolved by applying the LEFT operator and
+ then pushing the RIGHT one -- i.e., treating them as having similar
+ precedence and left associativity).
+
+ There is a default method which decides between `:push' and `:apply' by
+ comparing numerical precedence values."))
+
+(export 'expr)
+(defparse expr ((&key (nestedp (gensym "NESTEDP-")))
+ operand binop preop postop)
+ "Parse an expression involving unary and binary operators.
+
+ Within the parsers for operands and operators, the variable NESTEDP is
+ bound to a generalized boolean which is true if an unmatched open-
+ parenthesis has been seen.
+
+ The OPERAND parser should produce a value; the various operator parsers
+ (BINOP, PREOP, and POSTOP) should produce objects obeying the `operator'
+ protocol. The final output of the `expr' parse is the result of
+ evaluating the parsed expression. (Of course, the definition of
+ `evaluation' here is determined entirely by the methods on
+ `apply-operator', so the final value may be a parse tree, for example.)"
+
+ (flet ((wrap (parser)
+ `(parser (,nestedp)
+ (declare (ignorable ,nestedp))
+ ,parser)))
+ `(parse-expression ,(wrap operand)
+ ,(wrap binop)
+ ,(wrap preop)
+ ,(wrap postop))))
+
+;;;--------------------------------------------------------------------------
+;;; Numerical precedence.
+
+(export '(operator-left-precedence operator-right-precedence))
+(defgeneric operator-left-precedence (operator)
+ (:documentation
+ "Return the OPERATOR's left-precedence.
+
+ Higher precedence numbers indicate tighter leftward binding. Under the
+ default method for `operator-push-action', the OPERATOR's left precedence
+ is compared to the existing operators' right precedences to determine the
+ parser's behaviour: if it is higher, then the OPERATOR is pushed;
+ otherwise the existing operator is applied. Thus, equal precedences cause
+ left-associative parsing."))
+(defgeneric operator-right-precedence (operator)
+ (:documentation
+ "Return the OPERATOR's right-precedence.
+
+ Higher precedence numbers indicate tighter rightward binding. Under the
+ default method for `operator-push-action', a new operator's left
+ precedence may be compared to the existing OPERATOR's right precedences to
+ determine the parser's behaviour: if it is higher, then the new operator
+ is pushed; otherwise the existing OPERATOR is applied. Thus, equal
+ precedences cause left-associative parsing."))
+
+(defgeneric operator-associativity (operator)
+ (:documentation
+ "Returns an OPERATOR's associativity, as a symbol.
+
+ The return value is one of `:left', `:right' or `nil'. If two adjacent
+ operators have the same precedence, their associativities are compared.
+ If both associativities are `:left' then the left-hand operator is
+ considered to have higher precedence; if both are `:right' then the
+ right-hand operator is considered to have higher precedence. If they're
+ inconsistent or `nil', then an error is reported and the behaviour is as
+ if both were `:left'.")
+ (:method (operator) :left))
+
+;;;--------------------------------------------------------------------------
+;;; Basic operator protocol.
+
+(export 'prefix-operator)
+(defclass prefix-operator ()
+ ()
+ (:documentation
+ "Prefix operator base class.
+
+ Prefix operators are special because they are pushed at a time when the
+ existing topmost operator on the stack may not have its operand
+ available. It is therefore incorrect to attempt to apply any existing
+ operators without careful checking. This class provides a method on
+ `push-operator' which immediately pushes the new operator without
+ inspecting the existing stack."))
+
+(export 'simple-operator)
+(defclass simple-operator ()
+ ((function :initarg :function :reader operator-function)
+ (name :initarg :name :initform "<unnamed operator>"
+ :reader operator-name))
+ (:documentation
+ "A simple operator applies a FUNCTION to arguments when it is applied.
+
+ The precise details of the function are left to subclasses to sort out."))
+
+(export 'simple-unary-operator)
+(defclass simple-unary-operator (simple-operator)
+ ()
+ (:documentation
+ "A unary operator works on the topmost value on the value stack.
+
+ The topmost item is popped, the FUNCTION is applied to it, and the result
+ is pushed back on."))
+
+(export 'simple-binary-operator)
+(defclass simple-binary-operator (simple-operator)
+ ((lprec :initarg :left-precedence :initarg :precedence
+ :reader operator-left-precedence)
+ (rprec :initarg :right-precedence :reader operator-right-precedence)
+ (associativity :initarg :associative :initform :left
+ :reader operator-associativity))
+ (:documentation
+ "A binary operator works on the two topmost values on the value stack.
+
+ The function's arguments are the two topmost items in /reverse/ order --
+ so the topmost item is second. This is usually what you want.
+
+ The left and right precedences are settable independently. Usually (and
+ this is the default) you will set them equal, and use the `:associativity'
+ initarg to determine associativity; however, right-associativity can also
+ be obtained by setting the right-precedence lower than the left. Special
+ effects can be obtained by setting them in other ways. Use your
+ imagination."))
+
+(export 'simple-postfix-operator)
+(defclass simple-postfix-operator (simple-unary-operator)
+ ((lprec :initarg :left-precedence :initarg :precedence
+ :reader operator-left-precedence)
+ (rprec :initarg :right-precedence :reader operator-right-precedence))
+ (:documentation
+ "A postfix operator is applied to a single operand.
+
+ The left and right precedences are settable independently. Usually you
+ will want to set them equal (this is the default) and quite high. Special
+ effects can be obtained by doing other things instead; but note that you
+ will get an incorrect parse if the right precedence is lower than the left
+ precedence of a binary operator because the postfix operator will be
+ applied to the result of the binary operator."))
+
+(export 'simple-prefix-operator)
+(defclass simple-prefix-operator (prefix-operator simple-unary-operator)
+ ((rprec :initarg :precedence :reader operator-right-precedence))
+ (:documentation
+ "A prefix operator is applied to a single operand.
+
+ There is only one precedence value for a prefix operator: the
+ `prefix-operator' superclass arranges that the left precedence is
+ effectively minus infinity."))
+
+(export 'preop)
+(defmacro preop (name (x prec) &body body)
+ "Define a prefix operator.
+
+ The operator will be called NAME in error messages, and have right
+ precedence PREC. To apply the operator, BODY is evaluated with X bound to
+ the operand."
+
+ `(make-instance 'simple-prefix-operator
+ :name ,name
+ :precedence ,prec
+ :function (lambda (,x) ,@body)))
+
+(export 'postop)
+(defmacro postop (name (x prec &key rprec) &body body)
+ "Define a postfix operator.
+
+ The operator will be called NAME in error messages, and have left
+ precedence PREC and right precendence RPREC (defaulting to PREC). To
+ apply the operator, BODY is evaluated with X bound to the operand."
+
+ (once-only (name prec rprec)
+ `(make-instance 'simple-postfix-operator
+ :name ,name
+ :left-precedence ,prec
+ :right-precedence ,(or rprec prec)
+ :function (lambda (,x) ,@body))))
+
+(export 'binop)
+(defmacro binop (name (x y prec &key rprec (assoc :left)) &body body)
+ "Define a binary operator.
+
+ The operator will be called NAME in error messages, and have left
+ precedence PREC and right precedence RPREC (defaulting to PREC, implying
+ left associativity under the default `operator-push-action'
+ implementation. To apply the operator, BODY is evaluated with X and Y
+ bound to the operands in the order they were parsed"
+
+ (once-only (name prec rprec assoc)
+ `(make-instance 'simple-binary-operator
+ :name ,name
+ :left-precedence ,prec
+ :right-precedence ,(or rprec prec)
+ :associative ,assoc
+ :function (lambda (,x ,y) ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Parentheses.
+
+(defclass parenthesis ()
+ ((tag :initarg :tag :initform nil))
+ (:documentation
+ "Base class for parenthesis operators."))
+
+(export 'open-parenthesis)
+(defclass open-parenthesis (parenthesis prefix-operator) ())
+
+(export 'close-parenthesis)
+(defclass close-parenthesis (parenthesis) ())
+
+(export '(lparen rparen))
+(defun lparen (tag)
+ (make-instance 'open-parenthesis :tag tag))
+(defun rparen (tag)
+ (make-instance 'close-parenthesis :tag tag))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff