0.9.2.49:

[sbcl.git] / src / code / target-error.lisp

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index f4093cc..2406d7b 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -30,7 +30,7 @@
 (def!method print-object ((restart restart) stream)
   (if *print-escape*
       (print-unreadable-object (restart stream :type t :identity t)
 (def!method print-object ((restart restart) stream)
   (if *print-escape*
       (print-unreadable-object (restart stream :type t :identity t)

-       (prin1 (restart-name restart) stream))
+        (prin1 (restart-name restart) stream))

       (restart-report restart stream)))
 
 (defun compute-restarts (&optional condition)
       (restart-report restart stream)))
 
 (defun compute-restarts (&optional condition)

@@ -40,20 +40,20 @@
    specified, then only restarts associated with CONDITION (or with no
    condition) will be returned."
   (let ((associated ())
    specified, then only restarts associated with CONDITION (or with no
    condition) will be returned."
   (let ((associated ())

-       (other ()))
+        (other ()))

     (dolist (alist *condition-restarts*)
       (if (eq (car alist) condition)
     (dolist (alist *condition-restarts*)
       (if (eq (car alist) condition)

-         (setq associated (cdr alist))
-         (setq other (append (cdr alist) other))))
+          (setq associated (cdr alist))
+          (setq other (append (cdr alist) other))))

     (collect ((res))
       (dolist (restart-cluster *restart-clusters*)
     (collect ((res))
       (dolist (restart-cluster *restart-clusters*)

-       (dolist (restart restart-cluster)
-         (when (and (or (not condition)
-                        (member restart associated)
-                        (not (member restart other)))
-                    (funcall (restart-test-function restart)
+        (dolist (restart restart-cluster)
+          (when (and (or (not condition)
+                         (member restart associated)
+                         (not (member restart other)))
+                     (funcall (restart-test-function restart)

                               condition))
                               condition))

-           (res restart))))
+            (res restart))))

       (res))))
 
 #!+sb-doc
       (res))))
 
 #!+sb-doc

@@ -62,11 +62,11 @@
 
 (defun restart-report (restart stream)
   (funcall (or (restart-report-function restart)
 
 (defun restart-report (restart stream)
   (funcall (or (restart-report-function restart)

-              (let ((name (restart-name restart)))
-                (lambda (stream)
-                  (if name (format stream "~S" name)
-                      (format stream "~S" restart)))))
-          stream))
+               (let ((name (restart-name restart)))
+                 (lambda (stream)
+                   (if name (format stream "~S" name)
+                       (format stream "~S" restart)))))
+           stream))

 
 (defun find-restart (name &optional condition)
   #!+sb-doc
 
 (defun find-restart (name &optional condition)
   #!+sb-doc

@@ -82,66 +82,59 @@
                    (eq (restart-name x) name)))
              restarts)))
 
                    (eq (restart-name x) name)))
              restarts)))
 

-(defun find-restart-or-lose (restart-designator)
-  (let ((real-restart (find-restart restart-designator)))
-    (unless real-restart
+;;; helper for the various functions which are ANSI-spec'ed to do
+;;; something with a restart or signal CONTROL-ERROR if there is none
+(defun find-restart-or-control-error (identifier &optional condition)
+  (or (find-restart identifier condition)

       (error 'simple-control-error
       (error 'simple-control-error

-            :format-control "Restart ~S is not active."
-            :format-arguments (list restart-designator)))
-    real-restart))
+             :format-control "No restart ~S is active~@[ for ~S~]."
+             :format-arguments (list identifier condition))))

 
 (defun invoke-restart (restart &rest values)
   #!+sb-doc
   "Calls the function associated with the given restart, passing any given
    arguments. If the argument restart is not a restart or a currently active
 
 (defun invoke-restart (restart &rest values)
   #!+sb-doc
   "Calls the function associated with the given restart, passing any given
    arguments. If the argument restart is not a restart or a currently active

-   non-nil restart name, then a control-error is signalled."
+   non-nil restart name, then a CONTROL-ERROR is signalled."

   (/show "entering INVOKE-RESTART" restart)
   (/show "entering INVOKE-RESTART" restart)

-  (let ((real-restart (find-restart-or-lose restart)))
+  (let ((real-restart (find-restart-or-control-error restart)))

     (apply (restart-function real-restart) values)))
 
 (defun interactive-restart-arguments (real-restart)
   (let ((interactive-function (restart-interactive-function real-restart)))
     (if interactive-function
     (apply (restart-function real-restart) values)))
 
 (defun interactive-restart-arguments (real-restart)
   (let ((interactive-function (restart-interactive-function real-restart)))
     (if interactive-function

-       (funcall interactive-function)
-       '())))
+        (funcall interactive-function)
+        '())))

 
 (defun invoke-restart-interactively (restart)
   #!+sb-doc
   "Calls the function associated with the given restart, prompting for any
    necessary arguments. If the argument restart is not a restart or a
 
 (defun invoke-restart-interactively (restart)
   #!+sb-doc
   "Calls the function associated with the given restart, prompting for any
    necessary arguments. If the argument restart is not a restart or a

-   currently active non-nil restart name, then a control-error is signalled."
-  (let* ((real-restart (find-restart-or-lose restart))
-        (args (interactive-restart-arguments real-restart)))
+   currently active non-NIL restart name, then a CONTROL-ERROR is signalled."
+  (let* ((real-restart (find-restart-or-control-error restart))
+         (args (interactive-restart-arguments real-restart)))

     (apply (restart-function real-restart) args)))
 \f
     (apply (restart-function real-restart) args)))
 \f

-\f
-
-
-
-;;;; helper functions for restartable error handling which couldn't be
-;;;; defined 'til now 'cause they use the RESTART-CASE macro
-

 (defun assert-error (assertion places datum &rest arguments)
   (let ((cond (if datum
 (defun assert-error (assertion places datum &rest arguments)
   (let ((cond (if datum

-               (coerce-to-condition datum
-                                                   arguments
-                                                   'simple-error
-                                                   'error)
-               (make-condition 'simple-error
-                               :format-control "The assertion ~S failed."
-                               :format-arguments (list assertion)))))
+                (coerce-to-condition datum
+                                                    arguments
+                                                    'simple-error
+                                                    'error)
+                (make-condition 'simple-error
+                                :format-control "The assertion ~S failed."
+                                :format-arguments (list assertion)))))

     (restart-case
     (restart-case

-       (error cond)
+        (error cond)

       (continue ()
       (continue ()

-               :report (lambda (stream)
-                         (format stream "Retry assertion")
-                         (if places
-                             (format stream
-                                     " with new value~P for ~{~S~^, ~}."
-                                     (length places)
-                                     places)
-                             (format stream ".")))
-               nil))))
+                :report (lambda (stream)
+                          (format stream "Retry assertion")
+                          (if places
+                              (format stream
+                                      " with new value~P for ~{~S~^, ~}."
+                                      (length places)
+                                      places)
+                              (format stream ".")))
+                nil))))

 
 ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
 ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
 
 ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
 ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros

@@ -151,39 +144,30 @@
   (list (eval (read *query-io*))))
 
 (defun check-type-error (place place-value type type-string)
   (list (eval (read *query-io*))))
 
 (defun check-type-error (place place-value type type-string)

-  (let ((cond (if type-string
-                 (make-condition 'simple-type-error
-                                 :datum place
-                                 :expected-type type
-                                 :format-control
-                                 "The value of ~S is ~S, which is not ~A."
-                                 :format-arguments (list place
-                                                         place-value
-                                                         type-string))
-                 (make-condition 'simple-type-error
-                                 :datum place
-                                 :expected-type type
-                                 :format-control
-                         "The value of ~S is ~S, which is not of type ~S."
-                                 :format-arguments (list place
-                                                         place-value
-                                                         type)))))
-    (restart-case (error cond)
+  (let ((condition
+         (make-condition
+          'simple-type-error
+          :datum place-value
+          :expected-type type
+          :format-control
+          "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]."
+          :format-arguments (list place place-value type-string type))))
+    (restart-case (error condition)

       (store-value (value)
       (store-value (value)

-       :report (lambda (stream)
-                 (format stream "Supply a new value for ~S." place))
-       :interactive read-evaluated-form
-       value))))
+        :report (lambda (stream)
+                  (format stream "Supply a new value for ~S." place))
+        :interactive read-evaluated-form
+        value))))

 
 (defun case-body-error (name keyform keyform-value expected-type keys)
   (restart-case
       (error 'case-failure
 
 (defun case-body-error (name keyform keyform-value expected-type keys)
   (restart-case
       (error 'case-failure

-            :name name
-            :datum keyform-value
-            :expected-type expected-type
-            :possibilities keys)
+             :name name
+             :datum keyform-value
+             :expected-type expected-type
+             :possibilities keys)

     (store-value (value)
       :report (lambda (stream)
     (store-value (value)
       :report (lambda (stream)

-               (format stream "Supply a new value for ~S." keyform))
+                (format stream "Supply a new value for ~S." keyform))

       :interactive read-evaluated-form
       value)))
       :interactive read-evaluated-form
       value)))