+++ /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