[Sbcl-commits] CVS: sbcl/src/code debug.lisp,1.84,1.85

[William H. N. <wn...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv2675/src/code

Modified Files:
	debug.lisp 
Log Message:
0.9.13.35:
	logged bug 403
	added workaround for bug 403 when printing *DEBUG-CONDITION*


Index: debug.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug.lisp,v
retrieving revision 1.84
retrieving revision 1.85
diff -u -d -r1.84 -r1.85
--- debug.lisp	7 Jun 2006 16:25:10 -0000	1.84
+++ debug.lisp	9 Jun 2006 17:07:38 -0000	1.85
@@ -507,6 +507,21 @@
 
   (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 +533,7 @@
         ;; 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*)))