doc/Makefile.am: Preserve `~' correctly in the version string.

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

diff --git a/src/parser/parser-expr-proto.lisp b/src/parser/parser-expr-proto.lisp
index 9052e54..c4b433f 100644 (file)
--- a/src/parser/parser-expr-proto.lisp
+++ b/src/parser/parser-expr-proto.lisp
@@ -64,16 +64,55 @@
    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.