X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/25ffaef064be85cad56848252cd46f202ddf31c4..7469d31e1a189759e6c32a5116b1b8e9da750da1:/src/pset-parse.lisp

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index b0e22be..4dec565 100644
--- 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.