X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/48f119ec8afb83d7116449ff6a5e616b77ebaa74..5eeb83d2b620e77000ab77269faa974007c9ff28:/src/pset-parse.lisp

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index d2bcc70..e86be27 100644
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -28,53 +28,12 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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',
-   `: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.
@@ -86,50 +45,137 @@
      | `<' 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)
-	(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.