--- /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 implementation.
+
+(defclass expression-parse-state ()
+ ((opstack :initform nil :type list)
+ (valstack :initform nil :type list)
+ (nesting :initform 0 :type fixnum))
+ (:documentation
+ "State for the expression parser. Largely passive."))
+
+(defmethod push-value (value (state expression-parse-state))
+ (with-slots (valstack) state
+ (push value valstack)))
+
+(defmethod push-operator (operator (state expression-parse-state))
+ (with-slots (opstack) state
+ (loop
+ (when (null opstack) (return))
+ (let ((head (car opstack)))
+ (ecase (operator-push-action head operator)
+ (:push (return))
+ (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~
+ operators aren't associative"
+ head operator))
+ (:apply (apply-operator head state)
+ (setf opstack (cdr opstack))))))
+ (push operator opstack)))
+
+(defgeneric apply-pending-operators (state)
+ (:documentation
+ "Apply all of the pending operators to their arguments.
+
+ The return value is the final result of the parse. By the time all of the
+ operators have been applied, of course, there ought to be exactly one
+ operand remaining.")
+ (:method ((state expression-parse-state))
+ (with-slots (opstack valstack) state
+ (dolist (operator opstack)
+ (apply-operator operator state))
+ (assert (and (consp valstack) (null (cdr valstack))))
+ (pop valstack))))
+
+;;;--------------------------------------------------------------------------
+;;; Basic operator implementation.
+
+(defmethod operator-push-action (left right)
+ (let ((lprec (operator-right-precedence left))
+ (rprec (operator-left-precedence right)))
+ (cond ((< lprec rprec) :push)
+ ((> lprec rprec) :apply)
+ (t (let ((lassoc (operator-associativity left))
+ (rassoc (operator-associativity right)))
+ (cond ((not (eq lassoc rassoc))
+ (cerror* "Parse error: ... ~A ... ~A ...: ~
+ inconsistent associativity: ~
+ ~(~A~) versus ~(~A~))"
+ left right
+ (or lassoc "none") (or rassoc "none"))
+ :apply)
+ ((not lassoc)
+ (cerror* "Parse error: ... ~A ... ~A ...: ~
+ operators are not associative"
+ left right)
+ :apply)
+ ((eq lassoc :left) :apply)
+ ((eq lassoc :right) :push)
+ (t (error "Invalid associativity ~S ~
+ for operators ~A and ~A"
+ lassoc left right))))))))
+
+(defmethod print-object ((operator simple-operator) stream)
+ (maybe-print-unreadable-object (operator stream :type t)
+ (princ (operator-name operator) stream)))
+
+(defmethod shared-initialize :after
+ ((operator simple-binary-operator) slot-names &key)
+ (when (slot-boundp operator 'lprec)
+ (default-slot (operator 'rprec slot-names)
+ (slot-value operator 'lprec))))
+
+(defmethod push-operator
+ ((operator prefix-operator) (state expression-parse-state))
+
+ ;; It's not safe to apply stacked operators here. Already-stacked prefix
+ ;; operators won't have their operands yet, so we'll end up in an
+ ;; inconsistent state.
+ (with-slots (opstack) state
+ (push operator opstack)))
+
+(defmethod apply-operator
+ ((operator simple-unary-operator) (state expression-parse-state))
+ (with-slots (function) operator
+ (with-slots (valstack) state
+ (assert (not (null valstack)))
+ (push (funcall function (pop valstack)) valstack))))
+
+(defmethod apply-operator
+ ((operator simple-binary-operator) (state expression-parse-state))
+ (with-slots (function) operator
+ (with-slots (valstack) state
+ (assert (not (or (null valstack)
+ (null (cdr valstack)))))
+ (let ((second (pop valstack))
+ (first (pop valstack)))
+ (push (funcall function first second) valstack)))))
+
+;;;--------------------------------------------------------------------------
+;;; Parenthesis protocol implementation.
+
+(defmethod push-operator :after
+ ((paren open-parenthesis) (state expression-parse-state))
+ (with-slots (nesting) state
+ (incf nesting)))
+
+(defmethod push-operator
+ ((paren close-parenthesis) (state expression-parse-state))
+ (with-slots (opstack nesting) state
+ (with-slots (tag) paren
+ (flet ((fail ()
+ (cerror* "Parse error: spurious `~A'" tag)
+ (return-from push-operator)))
+ (loop
+ (when (null opstack) (fail))
+ (let ((head (car opstack)))
+ (cond ((not (typep head 'open-parenthesis))
+ (apply-operator head state))
+ ((not (eq (slot-value head 'tag) tag))
+ (fail))
+ (t
+ (return)))
+ (setf opstack (cdr opstack))))
+ (setf opstack (cdr opstack))
+ (decf nesting)))))
+
+(defmethod apply-operator
+ ((paren open-parenthesis) (state expression-parse-state))
+ (with-slots (tag) paren
+ (cerror* "Parse error: missing `~A'" tag)))
+
+(defmethod operator-push-action (left (right open-parenthesis))
+ :push)
+
+(defmethod operator-push-action ((left open-parenthesis) right)
+ :push)
+
+;;;--------------------------------------------------------------------------
+;;; Main expression parser implementation.
+
+(defun parse-expression (p-operand p-binop p-preop p-postop)
+ "Parse an expression consisting of operands and various kinds of operators.
+
+ The arguments are all parser functions: they will be called with one
+ argument NESTEDP, which indicates whether the parse has encountered an
+ unmatched parenthesis."
+
+ (let ((state (make-instance 'expression-parse-state))
+ (consumed-any-p nil))
+
+ (labels ((fail (expected)
+ (return-from parse-expression
+ (values expected nil consumed-any-p)))
+
+ (parse (parser)
+ (unless parser
+ (return-from parse (values nil nil)))
+ (multiple-value-bind (value winp consumedp)
+ (funcall parser (plusp (slot-value state 'nesting)))
+ (when consumedp (setf consumed-any-p t))
+ (unless (or winp (not consumedp)) (fail value))
+ (values value winp)))
+
+ (get-operand ()
+ (loop (multiple-value-bind (value winp) (parse p-preop)
+ (unless winp (return))
+ (push-operator value state)))
+ (multiple-value-bind (value winp) (parse p-operand)
+ (unless winp (fail value))
+ (push-value value state))
+ (loop (multiple-value-bind (value winp) (parse p-postop)
+ (unless winp (return))
+ (push-operator value state)))))
+
+ (get-operand)
+ (loop
+ (multiple-value-bind (value winp) (parse p-binop)
+ (unless winp (return))
+ (push-operator value state))
+ (get-operand))
+
+ (values (apply-pending-operators state) t consumed-any-p))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff