X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=85b2215fb2867bfaafdd3064e8aacedc8e9f9876;hb=20db73fc9412b7d9bd92f93239d7f34a261d5402;hp=9bb1506d45e6b0a562c5a9737f981aa0d5b37a82;hpb=dcc18b4ddb40e9c63229d9bc37e0132f0123e817;p=sbcl.git

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 9bb1506..85b2215 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -19,12 +19,13 @@
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 
+(defun muffle-warning-p (warning)
+  (declare (special *muffled-warnings*))
+  (typep warning *muffled-warnings*))
+
 (defun initial-handler-clusters ()
   `(((warning . ,#'(lambda (warning)
-                     (when (typep warning
-                                  (locally
-                                      (declare (special sb!ext:*muffled-warnings*))
-                                    sb!ext:*muffled-warnings*))
+                     (when (muffle-warning-p warning)
                        (muffle-warning warning)))))))
 
 (defvar *handler-clusters* (initial-handler-clusters))
@@ -56,7 +57,6 @@ restarts associated with CONDITION (or with no condition) will be returned."
           (setq other (append (cdr alist) other))))
     (collect ((res))
       (let ((stack *restart-test-stack*))
-        (declare (optimize sb!c::stack-allocate-dynamic-extent))
         (dolist (restart-cluster *restart-clusters*)
           (dolist (restart restart-cluster)
             (when (and (or (not condition)
@@ -69,7 +69,7 @@ restarts associated with CONDITION (or with no condition) will be returned."
                        ;; duraction of the test call.
                        (not (memq restart stack))
                        (let ((*restart-test-stack* (cons restart stack)))
-                         (declare (dynamic-extent *restart-test-stack*))
+                         (declare (truly-dynamic-extent *restart-test-stack*))
                          (funcall (restart-test-function restart) condition)))
              (res restart)))))
       (res))))
@@ -156,8 +156,11 @@ with that condition (or with no condition) will be returned."
 ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
 ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
 ;;; and by CHECK-TYPE.
-(defun read-evaluated-form ()
-  (format *query-io* "~&Type a form to be evaluated:~%")
+(defun read-evaluated-form (&optional (prompt-control nil promptp)
+                            &rest prompt-args)
+  (apply #'format *query-io*
+         (if promptp prompt-control "~&Type a form to be evaluated: ")
+         prompt-args)
   (list (eval (read *query-io*))))
 
 (defun check-type-error (place place-value type type-string)
@@ -176,6 +179,15 @@ with that condition (or with no condition) will be returned."
         :interactive read-evaluated-form
         value))))
 
+(defun case-failure (name value keys)
+  (error 'case-failure
+         :name name
+         :datum value
+         :expected-type (if (eq name 'ecase)
+                            `(member ,@keys)
+                            `(or ,@keys))
+         :possibilities keys))
+
 (defun case-body-error (name keyform keyform-value expected-type keys)
   (restart-case
       (error 'case-failure