src/pset-parse.lisp: Replace `dispatch' by some more elementary functions.

[sod] / src / pset-parse.lisp

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index 4dec565..cfd2b4a 100644 (file)
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -63,31 +63,42 @@
                      (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)))))))
+    (labels ((want (type thunk)
+              ;; Evaluate THUNK and convert its result to the given TYPE.
+              (multiple-value-bind (ty val) (funcall thunk)
+                (coerce-property-value val ty type)))
+
+            (int-unop (intop x)
+              ;; Evaluate X to an integer, and apply INTOP to the result,
+              ;; giving another integer.
+              (oplambda (values :int (funcall intop (want :int x)))))
+
+            (int-binop (intop x y)
+              ;; Evaluate X and Y to integers, and apply INTOP to the
+              ;; results, giving another integer.
+              (oplambda
+                (values :int (funcall intop (want :int x) (want :int y))))))
 
       (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)
+                      ;; 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)))
@@ -100,12 +111,16 @@
                                                  "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
@@ -116,34 +131,28 @@
                                    #\>)
                                (values (lambda () (values :type (car dc)))
                                        t t))))
+
                      (t
+                      ;; Anything else is an error.
                       (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)))
+             ;; Binary operators.
+             ((:op #\* binop "*" (x y 70) (int-binop #'* x y))
+              (:op #\/ binop "/" (x y 70)
+                   (oplambda
+                     (let ((x (want :int x)) (y (want :int y)))
+                       (when (zerop y) (error "Division by zero"))
+                       (values :int (floor x y)))))
+              (:op #\+ binop "+" (x y 60) (int-binop #'+ x y))
+              (:op #\- binop "-" (x y 60) (int-binop #'- x y)))
+
+             ;; Prefix operators.
+             ((:op #\+ preop "+" (x 90) (int-unop #'identity x))
+              (:op #\- preop "-" (x 90) (int-unop #'- x))
               (:op #\( lparen #\)))
 
+             ;; Postfix operators.
              ((:op (when nestedp #\)) rparen #\))))
 
          ;; Do the delayed evaluation.  Establish a restart so that we can