chiark - git - mdw - sod/blob - src/parser/impl-parser-expr.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 Sensble 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) 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) 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 (eq (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   :push)
 169
 170 (defmethod operator-push-action ((left open-parenthesis) right)
 171   :push)
 172
 173 ;;;--------------------------------------------------------------------------
 174 ;;; Main expression parser implementation.
 175
 176 (defun parse-expression (p-operand p-binop p-preop p-postop)
 177   "Parse an expression consisting of operands and various kinds of operators.
 178
 179    The arguments are all parser functions: they will be called with one
 180    argument NESTEDP, which indicates whether the parse has encountered an
 181    unmatched parenthesis."
 182
 183   (let ((state (make-instance 'expression-parse-state))
 184         (consumed-any-p nil))
 185
 186     (labels ((fail (expected)
 187                (return-from parse-expression
 188                  (values expected nil consumed-any-p)))
 189
 190              (parse (parser)
 191                (unless parser
 192                  (return-from parse (values nil nil)))
 193                (multiple-value-bind (value winp consumedp)
 194                    (funcall parser (plusp (slot-value state 'nesting)))
 195                  (when consumedp (setf consumed-any-p t))
 196                  (unless (or winp (not consumedp)) (fail value))
 197                  (values value winp)))
 198
 199              (get-operand ()
 200                (loop (multiple-value-bind (value winp) (parse p-preop)
 201                        (unless winp (return))
 202                        (push-operator value state)))
 203                (multiple-value-bind (value winp) (parse p-operand)
 204                  (unless winp (fail value))
 205                  (push-value value state))
 206                (loop (multiple-value-bind (value winp) (parse p-postop)
 207                        (unless winp (return))
 208                        (push-operator value state)))))
 209
 210       (get-operand)
 211       (loop
 212         (multiple-value-bind (value winp) (parse p-binop)
 213           (unless winp (return))
 214           (push-operator value state))
 215         (get-operand))
 216
 217       (values (apply-pending-operators state) t consumed-any-p))))
 218
 219 ;;;----- That's all, folks --------------------------------------------------