X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=cad19af2e25e0d2de3a7ba0d4c7d87cd7bc2cdb1;hb=68ea71d0f020f2726e3c56c1ec491d0af734b3a4;hp=14f2525a10c865a019ca8cc5f8fde06cf1b91ab0;hpb=75ae7b7af9433418836b65cde48713ab5b8cd2fd;p=sbcl.git

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 14f2525..cad19af 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -223,17 +223,6 @@ is how many frames to show."
 
 ) ; EVAL-WHEN
 
-;;; This is used in constructing arg lists for debugger printing when
-;;; the arg list is unavailable, some arg is unavailable or unused, etc.
-(defstruct (unprintable-object
-            (:constructor make-unprintable-object (string))
-            (:print-object (lambda (x s)
-                             (print-unreadable-object (x s)
-                               (write-string (unprintable-object-string x)
-                                             s))))
-            (:copier nil))
-  string)
-
 ;;; Extract the function argument values for a debug frame.
 (defun frame-args-as-list (frame)
   (let ((debug-fun (sb!di:frame-debug-fun frame))
@@ -507,6 +496,21 @@ reset to ~S."
 
   (funcall-with-debug-io-syntax #'%invoke-debugger condition))
 
+(defun %print-debugger-invocation-reason (condition stream)
+  (format stream "~2&")
+  ;; Note: Ordinarily it's only a matter of taste whether to use
+  ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
+  ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
+  ;; definitely preferred, because the FORMAT alternative was acting odd.
+  (pprint-logical-block (stream nil)
+    (format stream
+            "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A"
+            (type-of condition)
+            #!+sb-thread sb!thread:*current-thread*
+            #!-sb-thread nil
+            condition))
+  (terpri stream))
+
 (defun %invoke-debugger (condition)
 
   (let ((*debug-condition* condition)
@@ -518,13 +522,7 @@ reset to ~S."
         ;; when people redirect *ERROR-OUTPUT*, they could reasonably
         ;; expect to see error messages logged there, regardless of what
         ;; the debugger does afterwards.)
-        (format *error-output*
-                "~2&~@<debugger invoked on a ~S~@[ in thread ~A~]: ~
-                    ~2I~_~A~:>~%"
-                (type-of *debug-condition*)
-                #!+sb-thread sb!thread:*current-thread*
-                #!-sb-thread nil
-                *debug-condition*)
+        (%print-debugger-invocation-reason condition *error-output*)
       (error (condition)
         (setf *nested-debug-condition* condition)
         (let ((ndc-type (type-of *nested-debug-condition*)))
@@ -536,12 +534,12 @@ reset to ~S."
                   '*debug-condition*
                   ndc-type
                   '*nested-debug-condition*))
-        (when (typep condition 'cell-error)
+        (when (typep *nested-debug-condition* 'cell-error)
           ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
           (format *error-output*
                   "~&(CELL-ERROR-NAME ~S) = ~S~%"
-                  '*debug-condition*
-                  (cell-error-name *debug-condition*)))))
+                  '*nested-debug-condition*
+                  (cell-error-name *nested-debug-condition*)))))
 
     (let ((background-p (sb!thread::debugger-wait-until-foreground-thread
                          *debug-io*)))
@@ -638,19 +636,30 @@ reset to ~S."
                      "Argh! error within --disable-debugger error handling"))
         (failure-quit :recklessly-p t)))))
 
+(defvar *old-debugger-hook* nil)
+
 ;;; halt-on-failures and prompt-on-failures modes, suitable for
 ;;; noninteractive and interactive use respectively
 (defun disable-debugger ()
-  (when (eql *invoke-debugger-hook* nil)
-    ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
-    ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
-    ;; to set it to a suitable value again and be very careful,
-    ;; especially if the user has also set it. -- MG 2005-07-15
-    (setf *invoke-debugger-hook* 'debugger-disabled-hook)))
+  ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
+  ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
+  ;; to set it to a suitable value again and be very careful,
+  ;; especially if the user has also set it. -- MG 2005-07-15
+  (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook)
+    (setf *old-debugger-hook* *invoke-debugger-hook*
+          *invoke-debugger-hook* 'debugger-disabled-hook))
+  ;; This is not inside the UNLESS to ensure that LDB is disabled
+  ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
+  ;; This might matter for example when restoring a core.
+  (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler"
+                                                 (function sb!alien:void))))
 
 (defun enable-debugger ()
   (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
-    (setf *invoke-debugger-hook* nil)))
+    (setf *invoke-debugger-hook* *old-debugger-hook*
+          *old-debugger-hook* nil))
+  (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler"
+                                                 (function sb!alien:void))))
 
 (defun show-restarts (restarts s)
   (cond ((null restarts)