mdw@git.distorted.org.uk Git - sod/blob - src/parser/parser-expr-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Parsers for expressions with binary operators
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod-parser)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Basic protocol implementation.
  30
  31 (defclass expression-parse-state ()
  32   ((opstack :initform nil :type list)
  33    (valstack :initform nil :type list)
  34    (nesting :initform 0 :type fixnum))
  35   (:documentation
  36    "State for the expression parser.  Largely passive."))
  37
  38 (defmethod push-value (value (state expression-parse-state))
  39   (with-slots (valstack) state
  40     (push value valstack)))
  41
  42 (defmethod push-operator (operator (state expression-parse-state))
  43   (with-slots (opstack) state
  44     (loop
  45       (when (null opstack) (return))
  46       (let ((head (car opstack)))
  47         (ecase (operator-push-action head operator)
  48           (:push (return))
  49           (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~
  50                             operators aren't associative"
  51                            head operator))
  52           (:apply (apply-operator head state)
  53                   (setf opstack (cdr opstack))))))
  54     (push operator opstack)))
  55
  56 (defgeneric apply-pending-operators (state)
  57   (:documentation
  58    "Apply all of the pending operators to their arguments.
  59
  60    The return value is the final result of the parse.  By the time all of the
  61    operators have been applied, of course, there ought to be exactly one
  62    operand remaining.")
  63   (:method ((state expression-parse-state))
  64     (with-slots (opstack valstack) state
  65       (dolist (operator opstack)
  66         (apply-operator operator state))
  67       (assert (and (consp valstack) (null (cdr valstack))))
  68       (pop valstack))))
  69
  70 ;;;--------------------------------------------------------------------------
  71 ;;; Basic operator implementation.
  72
  73 (defmethod operator-push-action (left right)
  74   (let ((lprec (operator-right-precedence left))
  75         (rprec (operator-left-precedence right)))
  76     (cond ((< lprec rprec) :push)
  77           ((> lprec rprec) :apply)
  78           (t (let ((lassoc (operator-associativity left))
  79                    (rassoc (operator-associativity right)))
  80                (cond ((not (eq lassoc rassoc))
  81                       (cerror* "Parse error: ... ~A ... ~A ...: ~
  82                                 inconsistent associativity: ~
  83                                 ~(~A~) versus ~(~A~))"
  84                                left right
  85                                (or lassoc "none") (or rassoc "none"))
  86                       :apply)
  87                      ((not lassoc)
  88                       (cerror* "Parse error: ... ~A ... ~A ...: ~
  89                                 operators are not associative"
  90                                left right)
  91                       :apply)
  92                      ((eq lassoc :left) :apply)
  93                      ((eq lassoc :right) :push)
  94                      (t (error "Invalid associativity ~S ~
  95                                 for operators ~A and ~A"
  96                                lassoc left right))))))))
  97
  98 (defmethod print-object ((operator simple-operator) stream)
  99   (maybe-print-unreadable-object (operator stream :type t)
 100     (princ (operator-name operator) stream)))
 101
 102 (defmethod shared-initialize :after
 103     ((operator simple-binary-operator) slot-names &key)
 104   (when (slot-boundp operator 'lprec)
 105     (default-slot (operator 'rprec slot-names)
 106       (slot-value operator 'lprec))))
 107
 108 (defmethod push-operator
 109     ((operator prefix-operator) (state expression-parse-state))
 110
 111   ;; It's not safe to apply stacked operators here.  Already-stacked prefix
 112   ;; operators won't have their operands yet, so we'll end up in an
 113   ;; inconsistent state.
 114   (with-slots (opstack) state
 115     (push operator opstack)))
 116
 117 (defmethod apply-operator
 118     ((operator simple-unary-operator) (state expression-parse-state))
 119   (with-slots ((function %function)) operator
 120     (with-slots (valstack) state
 121       (assert (not (null valstack)))
 122       (push (funcall function (pop valstack)) valstack))))
 123
 124 (defmethod apply-operator
 125     ((operator simple-binary-operator) (state expression-parse-state))
 126   (with-slots ((function %function)) operator
 127     (with-slots (valstack) state
 128       (assert (not (or (null valstack)
 129                        (null (cdr valstack)))))
 130       (let ((second (pop valstack))
 131             (first (pop valstack)))
 132         (push (funcall function first second) valstack)))))
 133
 134 ;;;--------------------------------------------------------------------------
 135 ;;; Parenthesis protocol implementation.
 136
 137 (defmethod push-operator :after
 138     ((paren open-parenthesis) (state expression-parse-state))
 139   (with-slots (nesting) state
 140     (incf nesting)))
 141
 142 (defmethod push-operator
 143     ((paren close-parenthesis) (state expression-parse-state))
 144   (with-slots (opstack nesting) state
 145     (with-slots (tag) paren
 146       (flet ((fail ()
 147                (cerror* "Parse error: spurious `~A'" tag)
 148                (return-from push-operator)))
 149         (loop
 150           (when (null opstack) (fail))
 151           (let ((head (car opstack)))
 152             (cond ((not (typep head 'open-parenthesis))
 153                    (apply-operator head state))
 154                   ((not (eql (slot-value head 'tag) tag))
 155                    (fail))
 156                   (t
 157                    (return)))
 158             (setf opstack (cdr opstack))))
 159         (setf opstack (cdr opstack))
 160         (decf nesting)))))
 161
 162 (defmethod apply-operator
 163     ((paren open-parenthesis) (state expression-parse-state))
 164   (with-slots (tag) paren
 165     (cerror* "Parse error: missing `~A'" tag)))
 166
 167 (defmethod operator-push-action (left (right open-parenthesis))
 168   (declare (ignore left))
 169   :push)
 170
 171 (defmethod operator-push-action ((left open-parenthesis) right)
 172   (declare (ignore right))
 173   :push)
 174
 175 ;;;--------------------------------------------------------------------------
 176 ;;; Main expression parser implementation.
 177
 178 (defun parse-expression (p-operand p-binop p-preop p-postop)
 179   "Parse an expression consisting of operands and various kinds of operators.
 180
 181    The arguments are all parser functions: they will be called with one
 182    argument NESTEDP, which indicates whether the parse has encountered an
 183    unmatched parenthesis."
 184
 185   (let ((state (make-instance 'expression-parse-state))
 186         (consumed-any-p nil))
 187
 188     (labels ((fail (expected)
 189                (return-from parse-expression
 190                  (values expected nil consumed-any-p)))
 191
 192              (parse (parser)
 193                (unless parser
 194                  (return-from parse (values nil nil)))
 195                (multiple-value-bind (value winp consumedp)
 196                    (funcall parser (plusp (slot-value state 'nesting)))
 197                  (when consumedp (setf consumed-any-p t))
 198                  (unless (or winp (not consumedp)) (fail value))
 199                  (values value winp)))
 200
 201              (get-operand ()
 202                (loop (multiple-value-bind (value winp) (parse p-preop)
 203                        (unless winp (return))
 204                        (push-operator value state)))
 205                (multiple-value-bind (value winp) (parse p-operand)
 206                  (unless winp (fail value))
 207                  (push-value value state))
 208                (loop (multiple-value-bind (value winp) (parse p-postop)
 209                        (unless winp (return))
 210                        (push-operator value state)))))
 211
 212       (get-operand)
 213       (loop
 214         (multiple-value-bind (value winp) (parse p-binop)
 215           (unless winp (return))
 216           (push-operator value state))
 217         (get-operand))
 218
 219       (values (apply-pending-operators state) t consumed-any-p))))
 220
 221 ;;;----- That's all, folks --------------------------------------------------