src/pset-parse.lisp: Parse and evaluate expressions in two separate steps.

Previously, we'd parse and evaluate expressions in an interleaved
fashion: the items on the parser's value stack were (TYPE . VALUE)
pairs, fully evaluated.

This causes a couple of problems.

  * Firstly, and most obviously, it means that we can't have operators
    which perform short-circuit evaluation -- sometimes failing to
    evaluate their operands.  This doesn't seem like such a big deal:
    after all, we don't have any assignment operators.  But we /do/ have
    an escape to Lisp's `eval' function via the `?' SEXP primary, and
    evaluating Lisp can have arbitrary side-effects.

  * Secondly, it makes error handling more annoying.  There's logic
    throughout for reporting continuable errors and then returning a
    `:invalid' marker.  This logic is currently concentrated in the
    internal `dispatch' function, but continuing to maintain this
    convention if and when we crack open `dispatch' to implement more
    complex operators would be messy.  (I know: I've tried it.)

Deferring evaluation to a second pass solves both problems.  Control-
flow operators can just decide not to evaluate operands they're not
interested in.  And errors can be caught and turned into an immediate
return from the `parse-expression' toplevel.  (The `:invalid' convention
is still part of the external interface, for good reason, but it we can
just use Lisp's non-local control flow forms inside.)

The way this works is unsurprising.  The `value' stack now holds thunks
which will calculate and return their values when invoked.  Operators
close over the thunks for their operands and produce a new thunk which
will call the operand thunks as required to calculate their result.  The
handling of `:invalid' in `dispatch' can be eliminated in favour of a
`restart-case' form around invoking the final value thunk.

The only remaining clever footwork is in `?' SEXP: if there's a read-
time error then we yields a thunk which immediately escapes and returns
`:invalid' from the toplevel.  (We do this using `continue' on the
grounds that the read error has already been reported -- along,
probably, with a lot of knock-on parse errors while we try to
resynchronize with the source.)

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index b0e22be..4dec565 100644 (file)
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -46,85 +46,113 @@
 
    Only operators for dealing with integers are provided."
 
-  (flet ((dispatch (name args &rest spec)
-          (acond ((find :invalid args :key #'car)
-                  (cons :invalid nil))
-                 ((find-if (lambda (item)
-                             (every (lambda (type arg)
-                                      (eql type (car arg)))
-                                    (cddr item)
-                                    args))
-                           spec)
-                  (cons (car it) (apply (cadr it)
-                                        (mapcar #'cdr args))))
-                 (t
-                  (cerror* "Type mismatch: operator `~A' applied to ~
-                                types ~{~(~A~)~#[~; and ~;, ~]~}"
-                           name
-                           (mapcar #'car args))
-                  (cons :invalid nil)))))
-
-    (with-parser-context (token-scanner-context :scanner scanner)
-      (parse (expr (:nestedp nestedp)
-              (lisp (case (token-type scanner)
-                      ((:int :id :char :string)
-                       (scanner-step scanner)
-                       (values (cons (token-type scanner)
-                                     (token-value scanner))
-                               t t))
-                      (#\?
-                       (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 #\))))))))
+  ;; The expression parser works in two stages.  First, the parser proper
+  ;; builds a thunk as its `value'.  If this is successful, then the thunk is
+  ;; invoked to return a property type and value.  Primitive expressions
+  ;; produce thunks which just return their values; operators combine their
+  ;; argument thunks together, evaluating them (or not) on demand.
+
+  (macrolet ((oplambda (&body body)
+              ;; Like `lambda', but (a) always produces a function with no
+              ;; arguments, and (b) captures the current location so that
+              ;; errors are attributed correctly.
+
+              (with-gensyms (floc)
+                `(let ((,floc (file-location scanner)))
+                   (lambda ()
+                     (with-default-error-location (,floc)
+                       ,@body))))))
+
+    (flet ((dispatch (name args &rest spec)
+            (oplambda
+              (let ((args (mapcar (compose #'funcall #'cons) args)))
+                (aif (find-if (lambda (item)
+                                (every (lambda (type arg)
+                                         (eql type (car arg)))
+                                       (cddr item) args))
+                              spec)
+                     (values (car it) (apply (cadr it) (mapcar #'cdr args)))
+                     (error "Type mismatch: operator `~A' applied to ~
+                             types ~{~(~A~)~#[~; and ~;, ~]~}"
+                            name (mapcar #'car args)))))))
+
+      (with-parser-context (token-scanner-context :scanner scanner)
+       (when-parse ()
+
+           ;; Parse the expression, producing a thunk.
+           (expr (:nestedp nestedp)
+             (lisp (case (token-type scanner)
+                     ((:int :id :char :string)
+                      (let ((type (token-type scanner))
+                            (value (token-value scanner)))
+                        (scanner-step scanner)
+                        (values (lambda () (values type value)) t t)))
+                     (#\?
+                      (handler-case
+                          (let* ((stream (make-scanner-stream scanner))
+                                 (sexp (read stream t)))
+                            (scanner-step scanner)
+                            (values (oplambda (decode-property (eval sexp)))
+                                    t t))
+                        (error (cond)
+                          (scanner-step scanner)
+                          (cerror*-with-location scanner
+                                                 "Lisp `read' error: ~A"
+                                                 cond)
+                          (values #'continue t t))))
+                     (#\{
+                      (let ((fragment (parse-delimited-fragment scanner
+                                                                #\{ #\})))
+                        (values (lambda () (values :fragment fragment))
+                                t t)))
+                     (#\<
+                      (parse (seq (#\<
+                                   (ds (parse-c-type scanner))
+                                   (dc (parse-declarator
+                                        scanner ds
+                                        :kernel (lambda ()
+                                                  (values nil t nil))
+                                        :abstractp t))
+                                   #\>)
+                               (values (lambda () (values :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 #\))))
+
+         ;; Do the delayed evaluation.  Establish a restart so that we can
+         ;; continue if evaluation fails for some reason.  (The value thunk
+         ;; is expected to report the correct error locations, if it signals
+         ;; conditions.)
+         (restart-case (multiple-value-bind (type value) (funcall it)
+                         (values (cons type value) t t))
+           (continue () (values (cons :invalid nil) t t))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing property sets.