src/pset-parse.lisp: Add a little vertical space and commentary.

[sod] / src / pset-parse.lisp

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index d2bcc70..e86be27 100644 (file)
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -28,53 +28,12 @@
 ;;;--------------------------------------------------------------------------
 ;;; The expression parser.
 
 ;;;--------------------------------------------------------------------------
 ;;; The expression parser.
 

-(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)))))
-  (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 +45,137 @@
      | `<' 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."

+
+  ;; 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)
+            ;; Evaluate the ARGS to determine their types and values.  Find
+            ;; the first SPEC, of the form (RETTY OP ARGTY*), where the
+            ;; ARGTYs match the argument types, in order, and apply OP to
+            ;; the argument values, return this as a result of type RETTY.
+            ;; If no SPEC matches, then report an error.
+
+            (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)
       (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)))
-                             (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))))))))
+       (when-parse ()
+
+           ;; Parse the expression, producing a thunk.
+           (expr (:nestedp nestedp)
+
+             (lisp (case (token-type scanner)
+
+                     ((:int :id :char :string)
+                      ;; A simple literal.
+                      (let ((type (token-type scanner))
+                            (value (token-value scanner)))
+                        (scanner-step scanner)
+                        (values (lambda () (values type value)) t t)))
+
+                     (#\?
+                      ;; A Lisp s-expression.  Catch and report reader-
+                      ;; errors (though the main parser will probably
+                      ;; end up /very/ confused); delay evaluation for
+                      ;; later.
+                      (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))))
+
+                     (#\{
+                      ;; A code fragment.
+                      (let ((fragment (parse-delimited-fragment scanner
+                                                                #\{ #\})))
+                        (values (lambda () (values :fragment fragment))
+                                t t)))
+
+                     (#\<
+                      ;; A C type.
+                      (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
+                      ;; Anything else is an error.
+                      (values (list :int :id :char :string #\? #\{ #\<)
+                              nil nil))))
+
+             ;; Binary operators.
+             ((: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))))
+
+             ;; Prefix operators.
+             ((:op #\+ preop "+" (x 9)
+                   (dispatch "+" (list x) (list :int #'+ :int)))
+              (:op #\- preop "-" (x 9)
+                   (dispatch "-" (list x) (list :int #'- :int)))
+              (:op #\( lparen #\)))
+
+             ;; Postfix operators.
+             ((: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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing property sets.