X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdebug.lisp;h=f7acf9a01463d4ab7a754e76f77649442fc8b987;hb=bb756e3d4b19c30d4a9cd4250b606c5969613ad9;hp=b20dc7ee737c0e5a3bff25ed7c394f0a55d6b018;hpb=64f013aaf9d09edb2d82cb7eed6cb098bbbc169a;p=sbcl.git

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index b20dc7e..f7acf9a 100644
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -270,29 +270,44 @@ is how many frames to show."
 (legal-fun-name-p '(lambda ()))
 (defvar *show-entry-point-details* nil)
 
+(defun clean-xep (name args)
+  (values (second name)
+	  (if (consp args)
+	      (let ((count (first args))
+		    (real-args (rest args)))
+		(if (fixnump count)
+		    (subseq real-args 0 
+			    (min count (length real-args)))
+		    real-args))
+	      args)))
+
+(defun clean-&more-processor (name args)
+  (values (second name)
+	  (if (consp args)
+	      (let* ((more (last args 2))
+		     (context (first more))
+		     (count (second more)))		
+		(append
+		 (butlast args 2)
+		 (if (fixnump count)
+		     (multiple-value-list 
+		      (sb!c:%more-arg-values context 0 count))
+		     (list
+		      (make-unprintable-object "more unavailable arguments")))))
+	      args)))
+
 (defun frame-call (frame)
   (labels ((clean-name-and-args (name args)
              (if (and (consp name) (not *show-entry-point-details*))
+		 ;; FIXME: do we need to deal with
+		 ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
+		 ;; &AUX-BINDINGS appear in backtraces, so they are
+		 ;; left alone for now. --NS 2005-02-28
                  (case (first name)
                    ((sb!c::xep sb!c::tl-xep)
-                    (clean-name-and-args 
-                     (second name)
-                     (let ((count (first args))
-                           (real-args (rest args)))
-                       (subseq real-args 0 (min count (length real-args))))))
+		    (clean-xep name args))
                    ((sb!c::&more-processor)
-                    (clean-name-and-args
-                     (second name)
-                     (let* ((more (last args 2))
-                            (context (first more))
-                            (count (second more)))
-                       (append (butlast args 2)
-                               (multiple-value-list 
-                                (sb!c:%more-arg-values context 0 count))))))
-                   ;; FIXME: do we need to deal with
-                   ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
-                   ;; &AUX-BINDINGS appear in backtraces, so they are
-                   ;; left alone for now. --NS 2005-02-28
+		    (clean-&more-processor name args))
                    ((sb!c::hairy-arg-processor 
                      sb!c::varargs-entry sb!c::&optional-processor)
                     (clean-name-and-args (second name) args))
@@ -363,7 +378,7 @@ is how many frames to show."
 	(sb!di:debug-condition (ignore) 
           ignore)
 	(error (c) 
-          (format stream "error finding source: ~A" c))))))
+          (format stream "~&error finding source: ~A" c))))))
 
 ;;;; INVOKE-DEBUGGER
 
@@ -512,10 +527,11 @@ reset to ~S."
 	;; 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: ~
+		"~2&~@<debugger invoked on a ~S~@[ in thread ~A~]: ~
                     ~2I~_~A~:>~%"
 		(type-of *debug-condition*)
-		(sb!thread:current-thread-id)
+                #!+sb-thread sb!thread:*current-thread*
+                #!-sb-thread nil
 		*debug-condition*)
       (error (condition)
 	(setf *nested-debug-condition* condition)
@@ -589,9 +605,10 @@ reset to ~S."
     (handler-case
 	(progn
 	  (format *error-output*
-		  "~&~@<unhandled ~S in thread ~S: ~2I~_~A~:>~2%"
+		  "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
 		  (type-of condition)
-		  (sb!thread:current-thread-id)
+                  #!+sb-thread sb!thread:*current-thread*
+                  #!-sb-thread nil
 		  condition)
 	  ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
 	  ;; even if we hit an error within BACKTRACE (e.g. a bug in
@@ -638,7 +655,8 @@ reset to ~S."
 
 (defun enable-debugger ()
   (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
-    (setf *invoke-debugger-hook* nil)))
+    (setf *debug-io* *query-io*
+          *invoke-debugger-hook* nil)))
 
 (setf *debug-io* *query-io*)