X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=193667513b86ae9caa17ffb479e8fc8491246d5f;hb=7dd568fb64927be78556ac27f1f0dc60e79cf942;hp=ba5a7f0b400afb4f800a9bb02d09100148fd3a1d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index ba5a7f0..1936675 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -10,7 +10,7 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
-(in-package "SB!CONDITIONS")
+(in-package "SB!KERNEL")
 
 (defvar *break-on-signals* nil
   #!+sb-doc
@@ -68,29 +68,28 @@
 		:format-control "bad argument to ~S: ~S"
 		:format-arguments (list function-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
+;;; instead.
+(eval-when (:compile-toplevel :execute)
+  (defmacro-mundanely maybe-find-stack-top-hint ()
+    `(or sb!debug:*stack-top-hint*
+	 (nth-value 1 (sb!kernel:find-caller-name-and-frame)))))
+
 (defun error (datum &rest arguments)
   #!+sb-doc
   "Invoke the signal facility on a condition formed from datum and arguments.
    If the condition is not handled, the debugger is invoked."
-  (/show0 "entering ERROR")
-  #!+sb-show
-  (unless *cold-init-complete-p*
-    (/show0 "ERROR in cold init, arguments=..")
-    #!+sb-show (dolist (argument arguments)
-		 (sb!impl::cold-print argument)))
+  (/show0 "entering ERROR, argument list=..")
+  (/hexstr arguments)
+  (/show0 "printing ERROR arguments one by one..")
+  #!+sb-show (dolist (argument arguments)
+	       (sb!impl::cold-print argument))
   (sb!kernel:infinite-error-protect
     (let ((condition (coerce-to-condition datum arguments
 					  'simple-error 'error))
-	  ;; FIXME: Why is *STACK-TOP-HINT* in SB-DEBUG instead of SB-DI?
-	  ;; SB-DEBUG should probably be only for true interface stuff.
-	  (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
-      (unless (and (condition-function-name condition)
-		   sb!debug:*stack-top-hint*)
-	(multiple-value-bind (name frame) (sb!kernel:find-caller-name)
-	  (unless (condition-function-name condition)
-	    (setf (condition-function-name condition) name))
-	  (unless sb!debug:*stack-top-hint*
-	    (setf sb!debug:*stack-top-hint* frame))))
+	  (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
       (let ((sb!debug:*stack-top-hint* nil))
 	(signal condition))
       (invoke-debugger condition))))
@@ -105,33 +104,33 @@
 						arguments
 						'simple-error
 						'error)))
-	    (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
-	(unless (and (condition-function-name condition)
-		     sb!debug:*stack-top-hint*)
-	  (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
-	    (unless (condition-function-name condition)
-	      (setf (condition-function-name condition) name))
-	    (unless sb!debug:*stack-top-hint*
-	      (setf sb!debug:*stack-top-hint* frame))))
+	    (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))
 	    (signal condition))
 	  (invoke-debugger condition)))))
   nil)
 
-(defun break (&optional (datum "break") &rest arguments)
-  #!+sb-doc
-  "Print a message and invoke the debugger without allowing any possibility
-   of condition handling occurring."
+;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
+;;; we can use it in system code (e.g. in SIGINT handling) without
+;;; messing up --noprogrammer mode (which works by setting
+;;; *DEBUGGER-HOOK*)
+(defun %break (what &optional (datum "break") &rest arguments)
+  ;; FIXME: Do we really want INFINITE-ERROR-PROTECT in BREAKish stuff?
   (sb!kernel:infinite-error-protect
-    (with-simple-restart (continue "Return from BREAK.")
-      (let ((sb!debug:*stack-top-hint*
-	     (or sb!debug:*stack-top-hint*
-		 (nth-value 1 (sb!kernel:find-caller-name)))))
+    (with-simple-restart (continue "Return from ~S." what)
+      (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 	(invoke-debugger
-	 (coerce-to-condition datum arguments 'simple-condition 'break)))))
+	 (coerce-to-condition datum arguments 'simple-condition what)))))
   nil)
 
+(defun break (&optional (datum "break") &rest arguments)
+  #!+sb-doc
+  "Print a message and invoke the debugger without allowing any possibility
+   of condition handling occurring."
+  (let ((*debugger-hook* nil)) ; as specifically required by ANSI
+    (apply #'%break 'break datum arguments)))
+	    
 (defun warn (datum &rest arguments)
   #!+sb-doc
   "Warn about a situation by signalling a condition formed by DATUM and
@@ -151,7 +150,7 @@
       (sb!kernel:infinite-error-protect
        (let ((condition (coerce-to-condition datum arguments
 					     'simple-warning 'warn)))
-	 (check-type condition warning "a warning condition")
+	 (enforce-type condition warning)
 	 (restart-case (signal condition)
 	   (muffle-warning ()
 	     :report "Skip warning."