From: Attila Lendvai <attila.lendvai@gmail.com>
Date: Wed, 27 Oct 2010 12:03:34 +0000 (+0200)
Subject: Wrap the body of sb-debug:backtrace with with-debug-io-syntax.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a5e4dbccec61eec3dcce99b7ad82d09ada64dab3;p=sbcl.git

Wrap the body of sb-debug:backtrace with with-debug-io-syntax.

 Added with-debug-io-syntax macro.

 Some whitespace changes as well.
---

diff --git a/NEWS b/NEWS
index 6ac9c92..9f0015e 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,8 @@ changes relative to sbcl-1.1.8:
   * enhancement: clean.sh now also cleans doc/internals.
   * enhancement: SB-EXT:PRINT-SYMBOL-WITH-PREFIX can be used within ~// to
     print a symbol with a package prefix.
+  * enhancement: The debugger and backtracing are more robust against buggy
+    PRINT-OBJECT methods.
   * optimization: calls to static functions on x86-64 use less instructions.
   * optimization: compute encode-universal-time at compile time when possible.
   * optimization: when referencing internal functions as #'x, don't go through
diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 98594c3..588419a 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -152,6 +152,11 @@ Other commands:
     useful when the debugger was invoked to handle an error in
     deeply nested input syntax, and now the reader is confused.)")
 
+(defmacro with-debug-io-syntax (() &body body)
+  (let ((thunk (gensym "THUNK")))
+    `(dx-flet ((,thunk ()
+                       ,@body))
+       (funcall-with-debug-io-syntax #',thunk))))
 
 ;;; If LOC is an unknown location, then try to find the block start
 ;;; location. Used by source printing to some information instead of
@@ -328,15 +333,16 @@ METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
 corresponding to method functions are printed. Possible values
 are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
 information."
-  (fresh-line stream)
-  (when print-thread
-    (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
-  (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
-                                     *suppress-print-errors*
-                                     'serious-condition))
-        (*print-circle* t)
-        (n start))
-    (handler-bind ((print-not-readable #'print-unreadably))
+  (with-debug-io-syntax ()
+    (fresh-line stream)
+    (when print-thread
+      (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
+    (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
+                                       *suppress-print-errors*
+                                       'serious-condition))
+          (*print-circle* t)
+          (n start))
+      (handler-bind ((print-not-readable #'print-unreadably))
         (map-backtrace (lambda (frame)
                          (print-frame-call frame stream
                                            :number n
@@ -346,8 +352,8 @@ information."
                        :from (backtrace-start-frame from)
                        :start start
                        :count count)))
-  (fresh-line stream)
-  (values))
+    (fresh-line stream)
+    (values)))
 
 (defun list-backtrace (&key
                        (count *backtrace-frame-count*)
@@ -829,8 +835,8 @@ the current thread are replaced with dummy objects which can safely escape."
                  (package-name *package*))
       (setf *package* (find-package :cl-user))
       (format *error-output*
-              "The value of ~S was not an undeleted PACKAGE. It has been
-reset to ~S."
+              "The value of ~S was not an undeleted PACKAGE. It has been ~
+               reset to ~S."
               '*package* *package*))
 
     ;; Before we start our own output, finish any pending output.