src/parser/floc-proto.lisp: Restore missing argument.

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

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 1a50841902e83dcb99deca80d3af616331f3d47a..484fce05c044e69e8aa1c8cd6c6a71b228701cc0 100644 (file)
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -32,7 +32,7 @@ (export '(file-location make-file-location file-location-p
          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)
@@ -58,8 +58,8 @@ (defgeneric file-location (thing)
 
 (export '(enclosing-condition enclosed-condition))
 (define-condition enclosing-condition (condition)
-  ((enclosed-condition :initarg :condition :type condition
-                      :reader enclosed-condition))
+  ((%enclosed-condition :initarg :condition :type condition
+                       :reader enclosed-condition))
   (:documentation
    "A condition which encloses another condition
 
@@ -165,7 +165,7 @@ (defun make-condition-with-location (default-type floc datum &rest arguments)
     (etypecase datum
       (condition-with-location datum)
       (condition (wrap datum))
-      (symbol (apply #'make arguments))
+      (symbol (apply #'make datum arguments))
       ((or string function) (make default-type
                                  :format-control datum
                                  :format-arguments arguments)))))
@@ -184,17 +184,30 @@ (defun warn-with-location (floc datum &rest arguments)
               '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 @@ (defmacro with-default-error-location ((floc) &body body)
 (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)