X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=5dbdf5fd1046c40d7efd91db6e113b6539ad389a;hb=380ea897e2c12a01547f918f73e8a1db0a3a0373;hp=32f71adc1bcdb98d55a505c49c070bf17162d36c;hpb=835e0272eaedd4764be992fe2d1cde078d581ce1;p=sbcl.git

diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index 32f71ad..5dbdf5f 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -22,61 +22,59 @@
    ARGUMENTS. If the condition is not handled, NIL is returned. If
    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
    before any signalling is done."
-  (/noshow0 "entering SIGNAL")
   (let ((condition (coerce-to-condition datum
 					arguments
 					'simple-condition
 					'signal))
-	(*handler-clusters* *handler-clusters*))
-    (let ((old-bos *break-on-signals*)
-	  (*break-on-signals* nil))
-      (when (typep condition old-bos)
-	(/noshow0 "doing BREAK in because of *BREAK-ON-SIGNALS*")
-	(break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now rebound to NIL)."
-	       condition)))
+	(*handler-clusters* *handler-clusters*)
+	(old-bos *break-on-signals*))
+    (restart-case
+	(when (typep condition *break-on-signals*)
+	  (let ((*break-on-signals* nil))
+	    (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
+                    (now rebound to NIL)."
+		   condition)))
+      ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
+      ;; way out.
+      ;; 
+      ;; (e.g.: Consider a long compilation. After a failed compile
+      ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
+      ;; RECOMPILE restart. Once the user diagnoses and fixes the
+      ;; problem, he selects RECOMPILE again... and discovers that
+      ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
+      ;; unless we provide this restart.)
+      (reassign (new-value)
+	:report
+	"Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*."
+	:interactive
+	(lambda ()
+	  (let (new-value)
+	    (loop
+	     (format *query-io*
+		     "Enter new value for *BREAK-ON-SIGNALS*. ~
+                      Current value is ~S.~%~
+                      > "
+		     old-bos)
+	     (force-output *query-io*)
+	     (let ((*break-on-signals* nil))
+	       (setf new-value (eval (read *query-io*)))
+	       (if (typep new-value 'type-specifier)
+		   (return)
+		   (format *query-io*
+			   "~S is not a valid value for *BREAK-ON-SIGNALS* ~
+                            (must be a type-specifier).~%"
+			   new-value))))
+	    (list new-value)))
+	(setf *break-on-signals* new-value)))
     (loop
       (unless *handler-clusters*
-	(/noshow0 "leaving LOOP because of unbound *HANDLER-CLUSTERS*")
 	(return))
       (let ((cluster (pop *handler-clusters*)))
-	(/noshow0 "got CLUSTER=..")
-	(/nohexstr cluster)
 	(dolist (handler cluster)
-	  (/noshow0 "looking at HANDLER=..")
-	  (/nohexstr handler)
 	  (when (typep condition (car handler))
 	    (funcall (cdr handler) condition)))))
-    
-    (/noshow0 "returning from SIGNAL")
     nil))
 
-;;; a utility for SIGNAL, ERROR, CERROR, WARN, and INVOKE-DEBUGGER:
-;;; Parse the hairy argument conventions into a single argument that's
-;;; directly usable by all the other routines.
-(defun coerce-to-condition (datum arguments default-type fun-name)
-  (cond ((typep datum 'condition)
-	 (if arguments
-	     (cerror "Ignore the additional arguments."
-		     'simple-type-error
-		     :datum arguments
-		     :expected-type 'null
-		     :format-control "You may not supply additional arguments ~
-				     when giving ~S to ~S."
-		     :format-arguments (list datum fun-name)))
-	 datum)
-	((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
-	 (apply #'make-condition datum arguments))
-	((or (stringp datum) (functionp datum))
-	 (make-condition default-type
-			 :format-control datum
-			 :format-arguments arguments))
-	(t
-	 (error 'simple-type-error
-		:datum datum
-		:expected-type '(or symbol string)
-		:format-control "bad argument to ~S: ~S"
-		:format-arguments (list fun-name datum)))))
-
 ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
 ;;; doesn't want to hear that the error "occurred in" one of these
 ;;; functions, so we try to point the top of the stack to our caller
@@ -116,7 +114,7 @@
       (let ((condition (coerce-to-condition datum
 					    arguments
 					    'simple-error
-					    'error))
+					    'cerror))
 	    (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 	(with-condition-restarts condition (list (find-restart 'continue))
 	  (let ((sb!debug:*stack-top-hint* nil))