An actual running implementation, which makes code that compiles.

[sod] / src / parser / floc-proto.lisp

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 1a50841..ca5aaee 100644 (file)
--- 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)