From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 20 Aug 2019 01:31:25 +0000 (+0100)
Subject: src/pset-parse.lisp: Replace `dispatch' by some more elementary functions.
X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/4979de888ad699695849a884e0ab8faedd3544f1?ds=sidebyside

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

This turns out to be an overall saving in terms of lines of code, as
well as being more versatile.  The price is that we've lost the specific
per-operator type mismatch error, but I think that's worth paying.

Somewhat sneakily, I've also fiddled with the operator precedence
numbers, so as to leave more space for other operators, though the
relative precedences are unchanged.
---

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index e86be27..cfd2b4a 100644
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -63,24 +63,21 @@
 		      (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)))))))
+    (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 ()
@@ -141,29 +138,18 @@
 			       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))))
+	      ((: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 9)
-		    (dispatch "+" (list x) (list :int #'+ :int)))
-	       (:op #\- preop "-" (x 9)
-		    (dispatch "-" (list x) (list :int #'- :int)))
+	      ((:op #\+ preop "+" (x 90) (int-unop #'identity x))
+	       (:op #\- preop "-" (x 90) (int-unop #'- x))
 	       (:op #\( lparen #\)))
 
 	      ;; Postfix operators.