From: William H. N. <wn...@us...> - 2004-05-02 15:39:02
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2892/src/code Modified Files: cold-error.lisp Log Message: 0.8.10.6: merged "Debugger/*break-on-signals* sanity" patch (Nikodemus Siivola, sbcl-devel 2004-04-22) Index: cold-error.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cold-error.lisp,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- cold-error.lisp 30 Jul 2003 16:07:45 -0000 1.17 +++ cold-error.lisp 2 May 2004 15:38:54 -0000 1.18 @@ -22,32 +22,57 @@ 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 shared idiom in ERROR, CERROR, and BREAK: The user probably |