0.7.0.6:

[sbcl.git] / src / code / debug.lisp

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index ba7e75b..fc9c8b2 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -491,37 +491,51 @@ Function and macro commands:
 ;;; lambda-list variables since any other arguments will be in the
 ;;; &REST arg's list of values.
 (defun print-frame-call-1 (frame)
-  (let* ((d-fun (sb!di:frame-debug-fun frame))
-        (loc (sb!di:frame-code-location frame))
-        (results (list (sb!di:debug-fun-name d-fun))))
+  (let ((debug-fun (sb!di:frame-debug-fun frame))
+       (loc (sb!di:frame-code-location frame))
+       (reversed-args nil))
+
+    ;; Construct function arguments in REVERSED-ARGS.
     (handler-case
-       (dolist (ele (sb!di:debug-fun-lambda-list d-fun))
+       (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
          (lambda-list-element-dispatch ele
-           :required ((push (frame-call-arg ele loc frame) results))
-           :optional ((push (frame-call-arg (second ele) loc frame) results))
-           :keyword ((push (second ele) results)
-                     (push (frame-call-arg (third ele) loc frame) results))
-           :deleted ((push (frame-call-arg ele loc frame) results))
+           :required ((push (frame-call-arg ele loc frame) reversed-args))
+           :optional ((push (frame-call-arg (second ele) loc frame)
+                            reversed-args))
+           :keyword ((push (second ele) reversed-args)
+                     (push (frame-call-arg (third ele) loc frame)
+                           reversed-args))
+           :deleted ((push (frame-call-arg ele loc frame) reversed-args))
            :rest ((lambda-var-dispatch (second ele) loc
                     nil
                     (progn
-                      (setf results
+                      (setf reversed-args
                             (append (reverse (sb!di:debug-var-value
                                               (second ele) frame))
-                                    results))
+                                    reversed-args))
                       (return))
                     (push (make-unprintable-object
                            "unavailable &REST argument")
-                          results)))))
+                          reversed-args)))))
       (sb!di:lambda-list-unavailable
        ()
-       (push (make-unprintable-object "lambda list unavailable") results)))
-    (pprint-logical-block (*standard-output* nil)
-      (let ((x (nreverse (mapcar #'ensure-printable-object results))))
-       (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x))))
-    (when (sb!di:debug-fun-kind d-fun)
+       (push (make-unprintable-object "lambda list unavailable")
+            reversed-args)))
+
+    (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
+      (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args))))
+       ;; Since we go to some trouble to make nice informative function
+       ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
+       ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
+       (let ((*print-length* nil)
+             (*print-level* nil))
+         (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
+       ;; For the function arguments, we can just print normally.
+       (format t "~{ ~_~S~}" args)))
+
+    (when (sb!di:debug-fun-kind debug-fun)
       (write-char #\[)
-      (prin1 (sb!di:debug-fun-kind d-fun))
+      (prin1 (sb!di:debug-fun-kind debug-fun))
       (write-char #\]))))
 
 (defun ensure-printable-object (object)
@@ -607,7 +621,7 @@ reset to ~S."
            ;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
            ;; but
            ;;   1. It doesn't affect our internal special variables 
-           ;;      like *CURRENT-LEVEL*.
+           ;;      like *CURRENT-LEVEL-IN-PRINT*.
            ;;   2. It isn't customizable.
            ;;   3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY* 
            ;;      to the same value as the toplevel default.
@@ -615,7 +629,7 @@ reset to ~S."
            ;;      helpful behavior for a debugger.
            ;; We try to remedy all these problems with explicit 
            ;; rebindings here.
-           (sb!kernel:*current-level* 0)
+           (sb!kernel:*current-level-in-print* 0)
            (*print-length* *debug-print-length*)
            (*print-level* *debug-print-level*)
            (*readtable* *debug-readtable*)
@@ -644,7 +658,12 @@ reset to ~S."
           (format *error-output*
                   "~&(caught ~S trying to print ~S when entering debugger)~%"
                   (type-of condition)
-                  '*debug-condition*)))
+                  '*debug-condition*)
+          (when (typep condition 'cell-error)
+            ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
+            (format *error-output*
+                    "~&(CELL-ERROR-NAME = ~S)~%)"
+                    (cell-error-name *debug-condition*)))))
 
        ;; After the initial error/condition/whatever announcement to
        ;; *ERROR-OUTPUT*, we become interactive, and should talk on
@@ -828,7 +847,7 @@ reset to ~S."
 
 (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
   `(let* ((temp (etypecase name
-                 (symbol (sb!di:debug-fun-symbol-variables
+                 (symbol (sb!di:debug-fun-symbol-vars
                           (sb!di:frame-debug-fun *current-frame*)
                           name))
                  (simple-string (sb!di:ambiguous-debug-vars