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

(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."))

(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."))

(defgeneric apply-operator (operator state)
  (:documentation
   "Apply the OPERATOR to arguments on the STATE's value stack.

   This should pop any necessary arguments, and push the result."))

(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 %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 %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 (eql (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))
  (declare (ignore left))
  :push)

(defmethod operator-push-action ((left open-parenthesis) right)
  (declare (ignore 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 (slot-value state 'valstack)))
	       (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 --------------------------------------------------