src/parser/parser-expr-proto.lisp: Get `expr' to cache operators.

Add a new feature to `expr': if you write the operator parsers in a
special way, it will cache the operator objects around the whole
parser.  Use this in the property-set expression parser.  (Admittedly,
it previously cached the operators at load time, but there's an upcoming
change which will prevent this anyway.)

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

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index a2199b69e50513562e46b199fa9f84b3f0344703..7091016b9c34ce590d840c1b6032bab6b4faf995 100644 (file)
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -45,36 +45,13 @@ (flet ((dispatch (name args &rest spec)
                          name
                          (mapcar #'car args))
                 (cons :invalid nil)))))
                          name
                          (mapcar #'car args))
                 (cons :invalid nil)))))

-  (let ((add (binop "+" (x y 5)
-              (dispatch "+" (list x y) (list :int #'+ :int :int))))
-       (sub (binop "-" (x y 5)
-              (dispatch "-" (list x y) (list :int #'- :int :int))))
-       (mul (binop "*" (x y 7)
-              (dispatch "*" (list x y) (list :int #'* :int :int))))
-       (div (binop "/" (x y 7)
-              (dispatch "/" (list x y)
-                        (list :int
-                              (lambda (x y)
-                                (cond ((zerop y)
-                                       (cerror*
-                                        "Division by zero")
-                                       (cons :invalid nil))
-                                      (t
-                                       (floor x y))))
-                              :int :int))))
-       (nop (preop "+" (x 9)
-              (dispatch "+" (list x) (list :int #'+ :int))))
-       (neg (preop "-" (x 9)
-              (dispatch "-" (list x) (list :int #'- :int))))
-       (lp (lparen #\)))
-       (rp (rparen #\))))
-
-    (defun parse-expression (scanner)
-      "Parse and evaluate a simple expression.
+
+  (defun parse-expression (scanner)
+    "Parse and evaluate a simple expression.

 
    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',
 
    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',

-   `:int', `:string', `:char', `:fragment', `:type'.  If an error prevented a sane value from
-   being produced, the type `:invalid' is returned.
+   `:int', `:string', `:char', `:fragment', `:type'.  If an error prevented a
+   sane value from being produced, the type `:invalid' is returned.

 
    The syntax of expressions is rather limited at the moment, but more may be
    added later.
 
    The syntax of expressions is rather limited at the moment, but more may be
    added later.


@@ -86,50 +63,68 @@     (defun parse-expression (scanner)
      | `<' declspec+ declarator[empty] `>' | `?' lisp-expression
 
    Only operators for dealing with integers are provided."
      | `<' declspec+ declarator[empty] `>' | `?' lisp-expression
 
    Only operators for dealing with integers are provided."

-      (with-parser-context (token-scanner-context :scanner scanner)
-       (parse (expr (:nestedp nestedp)
-                (lisp (flet ((prop (type value)
-                               (scanner-step scanner)
-                               (values (cons type value) t t)))
-                        (case (token-type scanner)
-                          ((:int :id :char :string)
-                           (prop (token-type scanner)
-                                 (token-value scanner)))
-                          (#\?
-                           (let* ((stream (make-scanner-stream scanner))
-                                  (sexp (read stream t)))
+    (with-parser-context (token-scanner-context :scanner scanner)
+      (parse (expr (:nestedp nestedp)
+              (lisp (flet ((prop (type value)

                              (scanner-step scanner)
                              (scanner-step scanner)

-                             (multiple-value-bind (type value)
-                                 (restart-case (decode-property (eval sexp))
-                                   (continue () (values :invalid nil)))
-                               (values (cons type value) t t))))
-                          (#\{
-                           (values (cons :fragment
-                                         (parse-delimited-fragment scanner
-                                                                   #\{ #\}))
-                                         t t))
-                          (#\<
-                           (parse (seq (#\<
-                                        (ds (parse-c-type scanner))
-                                        (dc (parse-declarator
-                                             scanner ds
-                                             :kernel (lambda ()
-                                                       (values nil t nil))
-                                             :abstractp t))
-                                        #\>)
-                                    (values (cons :type (car dc))
-                                            t t))))
-                          (t
-                           (values (list :int :id :char :string #\? #\{ #\<)
-                                   nil nil)))))
-                (or (seq (#\+) add)
-                    (seq (#\-) sub)
-                    (seq (#\*) mul)
-                    (seq (#\/) div))
-                (or (seq (#\() lp)
-                    (seq (#\+) nop)
-                    (seq (#\-) neg))
-                (when nestedp (seq (#\)) rp))))))))
+                             (values (cons type value) t t)))
+                      (case (token-type scanner)
+                        ((:int :id :char :string)
+                         (prop (token-type scanner)
+                               (token-value scanner)))
+                        (#\?
+                         (let* ((stream (make-scanner-stream scanner))
+                                (sexp (read stream t)))
+                           (scanner-step scanner)
+                           (multiple-value-bind (type value)
+                               (restart-case (decode-property (eval sexp))
+                                 (continue () (values :invalid nil)))
+                             (values (cons type value) t t))))
+                        (#\{
+                         (values (cons :fragment
+                                       (parse-delimited-fragment scanner
+                                                                 #\{ #\}))
+                                       t t))
+                        (#\<
+                         (parse (seq (#\<
+                                      (ds (parse-c-type scanner))
+                                      (dc (parse-declarator
+                                           scanner ds
+                                           :kernel (lambda ()
+                                                     (values nil t nil))
+                                           :abstractp t))
+                                      #\>)
+                                  (values (cons :type (car dc))
+                                          t t))))
+                        (t
+                         (values (list :int :id :char :string #\? #\{ #\<)
+                                 nil nil)))))
+
+              ((:op #\* binop "*" (x y 7)
+                    (dispatch "*" (list x y) (list :int #'* :int :int)))
+               (:op #\/ binop "/" (x y 7)
+                    (dispatch "/" (list x y)
+                              (list :int
+                                    (lambda (x y)
+                                      (cond ((zerop y)
+                                             (cerror*
+                                              "Division by zero")
+                                             (cons :invalid nil))
+                                            (t
+                                             (floor x y))))
+                                    :int :int)))
+               (:op #\+ binop "+" (x y 5)
+                    (dispatch "+" (list x y) (list :int #'+ :int :int)))
+               (:op #\- binop "-" (x y 5)
+                    (dispatch "-" (list x y) (list :int #'- :int :int))))
+
+              ((:op #\+ preop "+" (x 9)
+                    (dispatch "+" (list x) (list :int #'+ :int)))
+               (:op #\- preop "-" (x 9)
+                    (dispatch "-" (list x) (list :int #'- :int)))
+               (:op #\( lparen #\)))
+
+              ((:op (when nestedp #\)) rparen #\))))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing property sets.
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing property sets.