;;; -*-lisp-*- ;;; ;;; Parsers for expressions with binary operators ;;; ;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; ;;; This file is part of the Sensible 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 '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.) Alternatively, the BINOP, PREOP, and POSTOP parsers may be /lists/ of parsers (distinguished because the head of a parser form is expected to be an atom). These are implicitly `or'red together. Within such a list, a parser form beginning `:op' is given special interpretation. The syntax is expected to be (:op MAKE-OP RECOG &rest ARGS) which has the following effects: * around the expression parser, the expression (MAKE-OP . ARGS) is evaluated once and the result stashed away; and * a parser of the form (seq (RECOG) OP) is added as one of the alternatives of the disjunction, where OP is the cached operator built in the first step." (flet ((wrap (parser) `(parser (,nestedp) (declare (ignorable ,nestedp)) ,parser)) (hack-oplist (oplist) (if (or (atom oplist) (atom (car oplist))) (values nil oplist) (let ((binds nil) (ops nil)) (dolist (op oplist) (if (and (consp op) (eq (car op) :op)) (destructuring-bind (recog make-op &rest args) (cdr op) (with-gensyms (var) (push `(,var (,make-op ,@args)) binds) (push `(seq ((nil ,recog)) ,var) ops))) (push op ops))) (values (nreverse binds) `(or ,@(nreverse ops))))))) (multiple-value-bind (binvars binops) (hack-oplist binop) (multiple-value-bind (prevars preops) (hack-oplist preop) (multiple-value-bind (postvars postops) (hack-oplist postop) `(let (,@binvars ,@prevars ,@postvars) (parse-expression ,(wrap operand) ,(wrap binops) ,(wrap preops) ,(wrap postops)))))))) ;;;-------------------------------------------------------------------------- ;;; Numerical precedence. (export '(operator-left-precedence operator-right-precedence operator-associativity)) (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.")) (export 'simple-operator) (defclass simple-operator () ((%function :initarg :function :reader operator-function) (name :initarg :name :initform "" :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 --------------------------------------------------