lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.

[sod] / src / parser / parser-expr-proto.lisp

diff --git a/src/parser/parser-expr-proto.lisp b/src/parser/parser-expr-proto.lisp
index 7fc2609fc7a60f5b14d78f4653ae0454ea580461..c4b433fbb6b4c1b402657a846fe34229e5159c70 100644 (file)
--- a/src/parser/parser-expr-proto.lisp
+++ b/src/parser/parser-expr-proto.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; 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
@@ -28,29 +28,6 @@ (cl:in-package #:sod-parser)
 ;;;--------------------------------------------------------------------------
 ;;; Basic protocol.
 
-(export 'push-operator)
-(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."))
-
-(export 'push-value)
-(defgeneric push-value (value state)
-  (:documentation
-   "Push VALUE onto the STATE's value stack.
-
-   The default message just does that without any fuss.  It's unlikely that
-   this will need changing unless you invent some really weird values."))
-
-(export 'apply-operator)
-(defgeneric apply-operator (operator state)
-  (:documentation
-   "Apply the OPERATOR to argument on the STATE's value stack.
-
-   This should pop any necessary arguments, and push the result."))
-
 (export 'operator-push-action)
 (defgeneric operator-push-action (left right)
   (:documentation
@@ -87,21 +64,61 @@ (defparse expr ((&key (nestedp (gensym "NESTEDP-")))
    protocol.  The final output of the `expr' parse is the result of
    evaluating the parsed expression.  (Of course, the definition of
    `evaluation' here is determined entirely by the methods on
-   `apply-operator', so the final value may be a parse tree, for example.)"
+   `apply-operator', so the final value may be a parse tree, for example.)
+
+   Alternatively, the BINOP, PREOP, and POSTOP parsers may be /lists/ of
+   parsers (distinguished because the head of a parser form is expected to be
+   an atom).  These are implicitly `or'red together.  Within such a list, a
+   parser form beginning `:op' is given special interpretation.  The syntax
+   is expected to be
+
+       (:op MAKE-OP RECOG &rest ARGS)
+
+   which has the following effects:
+
+     * around the expression parser, the expression
+
+       (MAKE-OP . ARGS)
+
+      is evaluated once and the result stashed away; and
+
+    * a parser of the form
+
+       (seq (RECOG) OP)
+
+      is added as one of the alternatives of the disjunction, where OP is the
+      cached operator built in the first step."
 
   (flet ((wrap (parser)
           `(parser (,nestedp)
              (declare (ignorable ,nestedp))
-             ,parser)))
-    `(parse-expression ,(wrap operand)
-                      ,(wrap binop)
-                      ,(wrap preop)
-                      ,(wrap postop))))
+             ,parser))
+        (hack-oplist (oplist)
+          (if (or (atom oplist) (atom (car oplist))) (values nil oplist)
+              (let ((binds nil) (ops nil))
+                (dolist (op oplist)
+                  (if (and (consp op) (eq (car op) :op))
+                      (destructuring-bind
+                          (recog make-op &rest args) (cdr op)
+                        (with-gensyms (var)
+                          (push `(,var (,make-op ,@args)) binds)
+                          (push `(seq ((nil ,recog)) ,var) ops)))
+                      (push op ops)))
+                (values (nreverse binds) `(or ,@(nreverse ops)))))))
+    (multiple-value-bind (binvars binops) (hack-oplist binop)
+      (multiple-value-bind (prevars preops) (hack-oplist preop)
+       (multiple-value-bind (postvars postops) (hack-oplist postop)
+         `(let (,@binvars ,@prevars ,@postvars)
+            (parse-expression ,(wrap operand)
+                              ,(wrap binops)
+                              ,(wrap preops)
+                              ,(wrap postops))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Numerical precedence.
 
-(export '(operator-left-precedence operator-right-precedence))
+(export '(operator-left-precedence operator-right-precedence
+         operator-associativity))
 (defgeneric operator-left-precedence (operator)
   (:documentation
    "Return the OPERATOR's left-precedence.
@@ -148,13 +165,11 @@ (defclass prefix-operator ()
    Prefix operators are special because they are pushed at a time when the
    existing topmost operator on the stack may not have its operand
    available.  It is therefore incorrect to attempt to apply any existing
-   operators without careful checking.  This class provides a method on
-   `push-operator' which immediately pushes the new operator without
-   inspecting the existing stack."))
+   operators without careful checking."))
 
 (export 'simple-operator)
 (defclass simple-operator ()
-  ((function :initarg :function :reader operator-function)
+  ((%function :initarg :function :reader operator-function)
    (name :initarg :name :initform "<unnamed operator>"
         :reader operator-name))
   (:documentation