detect cpl-protocol-violations early

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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index d5025a5..be8c319 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -19,12 +19,13 @@
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 
 ;;; 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)
 (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))
                        (muffle-warning warning)))))))
 
 (defvar *handler-clusters* (initial-handler-clusters))

@@ -41,6 +42,8 @@
         (prin1 (restart-name restart) stream))
       (restart-report restart stream)))
 
         (prin1 (restart-name restart) stream))
       (restart-report restart stream)))
 

+(defvar *restart-test-stack* nil)
+

 (defun compute-restarts (&optional condition)
   #!+sb-doc
   "Return a list of all the currently active restarts ordered from most recently
 (defun compute-restarts (&optional condition)
   #!+sb-doc
   "Return a list of all the currently active restarts ordered from most recently

@@ -53,13 +56,22 @@ restarts associated with CONDITION (or with no condition) will be returned."
           (setq associated (cdr alist))
           (setq other (append (cdr alist) other))))
     (collect ((res))
           (setq associated (cdr alist))
           (setq other (append (cdr alist) other))))
     (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) condition))
-            (res restart))))
+      (let ((stack *restart-test-stack*))
+        (dolist (restart-cluster *restart-clusters*)
+          (dolist (restart restart-cluster)
+            (when (and (or (not condition)
+                           (memq restart associated)
+                           (not (memq restart other)))
+                       ;; A call to COMPUTE-RESTARTS -- from an error, from
+                       ;; user code, whatever -- inside the test function
+                       ;; would cause infinite recursion here, so we disable
+                       ;; each restart using *restart-test-stack* for the
+                       ;; duraction of the test call.
+                       (not (memq restart stack))
+                       (let ((*restart-test-stack* (cons restart stack)))
+                         (declare (truly-dynamic-extent *restart-test-stack*))
+                         (funcall (restart-test-function restart) condition)))
+             (res restart)))))

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

@@ -119,33 +131,35 @@ with that condition (or with no condition) will be returned."
          (args (interactive-restart-arguments real-restart)))
     (apply (restart-function real-restart) args)))
 \f
          (args (interactive-restart-arguments real-restart)))
     (apply (restart-function real-restart) args)))
 \f

-(defun assert-error (assertion places datum &rest arguments)
+(defun assert-error (assertion args-and-values places datum &rest arguments)

   (let ((cond (if datum
   (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~:[.~:; ~
+                                    with ~:*~{~{~S = ~S~}~^, ~}.~]~:@>"
+                   :format-arguments (list assertion args-and-values)))))

     (restart-case
         (error cond)
       (continue ()
     (restart-case
         (error cond)
       (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
 ;;; and by CHECK-TYPE.
 
 ;;; 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)
+  (finish-output *query-io*)

   (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)

@@ -164,6 +178,15 @@ with that condition (or with no condition) will be returned."
         :interactive read-evaluated-form
         value))))
 
         :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
 (defun case-body-error (name keyform keyform-value expected-type keys)
   (restart-case
       (error 'case-failure