X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1d8cc67a3f4ded443f5efc673a616883cbae9c50..9ec578d9fe450b7e7f9030dc9d930185593aa991:/src/parser/floc-proto.lisp

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 1a50841..ca5aaee 100644
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -32,7 +32,7 @@
 	  file-location-filename file-location-line file-location-column))
 (defstruct (file-location
 	     (:constructor make-file-location
-			   (%filename line column
+			   (%filename &optional line column
 			    &aux (filename
 				  (etypecase %filename
 				    ((or string null) %filename)
@@ -184,17 +184,30 @@
 	       'simple-warning-with-location
 	       floc datum arguments)))
 
+(defun my-cerror (continue-string datum &rest arguments)
+  "Like standard `cerror', but robust against sneaky changes of conditions.
+
+   It seems that `cerror' (well, at least the version in SBCL) is careful
+   to limit its restart to the specific condition it signalled.  But that's
+   annoying, because `with-default-error-location' substitutes different
+   conditions carrying the error-location information."
+  (restart-case (apply #'error datum arguments)
+    (continue ()
+      :report (lambda (stream)
+		(apply #'format stream continue-string datum arguments))
+      nil)))
+
 (export 'cerror-with-location)
 (defun cerror-with-location (floc continue-string datum &rest arguments)
   "Report a continuable error with attached location information."
-  (cerror continue-string
-	  (apply #'make-condition-with-location
-		 'simple-error-with-location
-		 floc datum arguments)))
+  (my-cerror continue-string
+	     (apply #'make-condition-with-location
+		    'simple-error-with-location
+		    floc datum arguments)))
 
 (export 'cerror*)
 (defun cerror* (datum &rest arguments)
-  (apply #'cerror "Continue" datum arguments))
+  (apply #'my-cerror "Continue" datum arguments))
 
 (export 'cerror*-with-location)
 (defun cerror*-with-location (floc datum &rest arguments)
@@ -256,31 +269,38 @@
 (defun count-and-report-errors* (thunk)
   "Invoke THUNK in a dynamic environment which traps and reports errors.
 
-   See the `count-and-report-errors' macro for more detais."
+   See the `count-and-report-errors' macro for more details."
 
   (let ((errors 0)
 	(warnings 0))
-    (handler-bind
-	((error (lambda (error)
-		  (let ((fatal (not (find-restart 'continue error))))
-		    (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
-			    (file-location error)
-			    fatal
-			    error)
-		    (incf errors)
-		    (if fatal
-			(return-from count-and-report-errors*
-			  (values nil errors warnings))
-			(invoke-restart 'continue)))))
-	 (warning (lambda (warning)
-		    (format *error-output* "~&~A: Warning: ~A~%"
-			  (file-location warning)
-			  warning)
-		    (incf warnings)
-		    (invoke-restart 'muffle-warning))))
-      (values (funcall thunk)
-	      errors
-	      warnings))))
+    (restart-case
+	(let ((our-continue-restart (find-restart 'continue)))
+	  (handler-bind
+	      ((error (lambda (error)
+			(let ((fatal (eq (find-restart 'continue error)
+					 our-continue-restart)))
+			  (format *error-output*
+				  "~&~A: ~:[~;Fatal error: ~]~A~%"
+				  (file-location error)
+				  fatal
+				  error)
+			  (incf errors)
+			  (if fatal
+			      (return-from count-and-report-errors*
+				(values nil errors warnings))
+			      (invoke-restart 'continue)))))
+	       (warning (lambda (warning)
+			  (format *error-output* "~&~A: Warning: ~A~%"
+				  (file-location warning)
+				  warning)
+			  (incf warnings)
+			  (invoke-restart 'muffle-warning))))
+	    (values (funcall thunk)
+		    errors
+		    warnings)))
+      (continue ()
+	:report (lambda (stream) (write-string "Exit to top-level" stream))
+	(values nil errors warnings)))))
 
 (export 'count-and-report-errors)
 (defmacro count-and-report-errors (() &body body)