New toplevel options --quit and --non-interactive

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

diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 2f6d3fc..85b2215 100644 (file)
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -19,7 +19,16 @@
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 
 ;;; associated with Condition
 (defvar *condition-restarts* ())
 

-(defvar *handler-clusters* nil)
+(defun muffle-warning-p (warning)
+  (declare (special *muffled-warnings*))
+  (typep warning *muffled-warnings*))
+
+(defun initial-handler-clusters ()
+  `(((warning . ,#'(lambda (warning)
+                     (when (muffle-warning-p warning)
+                       (muffle-warning warning)))))))
+
+(defvar *handler-clusters* (initial-handler-clusters))

 
 (defstruct (restart (:copier nil) (:predicate nil))
   (name (missing-arg) :type symbol :read-only t)
 
 (defstruct (restart (:copier nil) (:predicate nil))
   (name (missing-arg) :type symbol :read-only t)

@@ -33,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

@@ -45,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

@@ -136,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.
 ;;; 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)
   (list (eval (read *query-io*))))
 
 (defun check-type-error (place place-value type type-string)

@@ -156,6 +179,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