Major effort to plug slot-name leaks.

[sod] / src / parser / parser-expr-proto.lisp

;;; -*-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 --------------------------------------------------