Massive reorganization in progress.

[sod] / src / parser / impl-parser-expr.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 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 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)
  (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 --------------------------------------------------