0.8.20.28 pretty backtraces with unavailable arguments & lambda-lists

             * fix issue reported by Juho Snellman on sbcl-devel 2005-03-18,
                and some related problems.
             * minor combinatorial explosion in debug.impure.lisp; most
                tests still skipped on x86/linux :/

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index b20dc7e..7ce7153 100644 (file)
--- 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))))))
 \f
 ;;;; INVOKE-DEBUGGER
 

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 1b31eb1..96bd754 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -68,10 +68,10 @@
 ;;; and hasn't been cut off anywhere.
 (defun verify-backtrace (test-function frame-specs &key (allow-stunted nil))
   (labels ((args-equal (want real)
-             (cond ((endp want)
-                    (endp real))
-                   ((eq '&rest (car want))
+             (cond ((eq '&rest (car want))
                     t)
+                   ((endp want)
+                    (endp real))
                    ((or (eq '? (car want)) (equal (car want) (car real)))
                     (args-equal (cdr want) (cdr real)))
                    (t
@@ -195,20 +195,34 @@
 (defun oops ()
   (error "oops"))
 
-(defun bt.1 (&key key)
+(defmacro defbt (n ll &body body)
+  `(progn
+     ;; normal debug info
+     (defun ,(intern (format nil "BT.~A.1" n)) ,ll 
+       ,@body)
+     ;; no arguments saved
+     (defun ,(intern (format nil "BT.~A.2" n)) ,ll 
+       (declare (optimize (debug 1) (speed 3)))
+       ,@body)
+     ;; no lambda-list saved
+     (defun ,(intern (format nil "BT.~A.3" n)) ,ll 
+       (declare (optimize (debug 0)))
+       ,@body)))
+
+(defbt 1 (&key key)
   (list key))
 
-(defun bt.2 (x)
+(defbt 2 (x)
   (list x))
 
-(defun bt.3 (&key (key (oops)))
+(defbt 3 (&key (key (oops)))
   (list key))
 
 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
-(defun bt.4 (&optional opt)
+(defbt 4 (&optional opt)
   (list (error "error")))
 
-(defun bt.5 (&optional (opt (oops)))
+(defbt 5 (&optional (opt (oops)))
   (list opt))
 
 #-(and x86 linux)
@@ -216,53 +230,99 @@
              `(let ((sb-debug:*show-entry-point-details* ,bool))
                 ,@body)))
 
-  ;; &MORE-PROCESSOR
+  ;; TL-XEP
+  (print :tl-xep)
   (with-details t
-    (assert (verify-backtrace (lambda () (bt.1 :key))
-                              '(((sb-c::&more-processor bt.1) &rest)))))
+    (assert (verify-backtrace #'namestring
+                              '(((sb-c::tl-xep namestring) 0 ?)))))
   (with-details nil
-    (assert (verify-backtrace (lambda () (bt.1 :key))
-                              '((bt.1 :key)))))
+    (assert (verify-backtrace #'namestring
+                              '((namestring)))))
 
-  ;; XEP
+
+  ;; &MORE-PROCESSOR
   (with-details t
-    (assert (verify-backtrace #'bt.2
-                              '(((sb-c::xep bt.2) 0 ?)))))
+    (assert (verify-backtrace (lambda () (bt.1.1 :key))
+                              '(((sb-c::&more-processor bt.1.1) &rest))))
+    (assert (verify-backtrace (lambda () (bt.1.2 :key))
+                              '(((sb-c::&more-processor bt.1.2) &rest))))
+    (assert (verify-backtrace (lambda () (bt.1.3 :key))
+                              '(((sb-c::&more-processor bt.1.3) &rest)))))
   (with-details nil
-    (assert (verify-backtrace #'bt.2
-                              '((bt.2)))))
+    (assert (verify-backtrace (lambda () (bt.1.1 :key))
+                              '((bt.1.1 :key))))
+    (assert (verify-backtrace (lambda () (bt.1.2 :key))
+                              '((bt.1.2 &rest))))
+    (assert (verify-backtrace (lambda () (bt.1.3 :key))
+                              '((bt.1.3 &rest)))))
 
-  ;; TL-XEP
+  ;; XEP
+  (print :xep)
   (with-details t
-    (assert (verify-backtrace #'namestring
-                              '(((sb-c::tl-xep namestring) 0 ?)))))
+    (assert (verify-backtrace #'bt.2.1
+                              '(((sb-c::xep bt.2.1) 0 ?))))
+    (assert (verify-backtrace #'bt.2.2
+                              '(((sb-c::xep bt.2.2) &rest))))
+    (assert (verify-backtrace #'bt.2.3
+                              '(((sb-c::xep bt.2.3) &rest)))))
   (with-details nil
-    (assert (verify-backtrace #'namestring
-                              '((namestring)))))
+    (assert (verify-backtrace #'bt.2.1
+                              '((bt.2.1))))
+    (assert (verify-backtrace #'bt.2.2
+                              '((bt.2.2 &rest))))
+    (assert (verify-backtrace #'bt.2.3
+                              '((bt.2.3 &rest)))))
 
   ;; VARARGS-ENTRY
+  (print :varargs-entry)
   (with-details t
-    (assert (verify-backtrace #'bt.3
-                             '(((sb-c::varargs-entry bt.3) :key nil)))))
+    (assert (verify-backtrace #'bt.3.1
+                             '(((sb-c::varargs-entry bt.3.1) :key nil))))
+    (assert (verify-backtrace #'bt.3.2
+                             '(((sb-c::varargs-entry bt.3.2) :key ?))))
+    (assert (verify-backtrace #'bt.3.3
+                             '(((sb-c::varargs-entry bt.3.3) &rest)))))
   (with-details nil
-    (assert (verify-backtrace #'bt.3
-                              '((bt.3 :key nil)))))
+    (assert (verify-backtrace #'bt.3.1
+                              '((bt.3.1 :key nil))))
+    (assert (verify-backtrace #'bt.3.2
+                              '((bt.3.2 :key ?))))
+    (assert (verify-backtrace #'bt.3.3
+                              '((bt.3.3 &rest)))))
 
   ;; HAIRY-ARG-PROCESSOR
+  (print :hairy-args-processor)
   (with-details t
-    (assert (verify-backtrace #'bt.4
-                              '(((sb-c::hairy-arg-processor bt.4) ?)))))
+    (assert (verify-backtrace #'bt.4.1
+                              '(((sb-c::hairy-arg-processor bt.4.1) ?))))
+    (assert (verify-backtrace #'bt.4.2
+                              '(((sb-c::hairy-arg-processor bt.4.2) ?))))
+    (assert (verify-backtrace #'bt.4.3
+                              '(((sb-c::hairy-arg-processor bt.4.3) &rest)))))
   (with-details nil
-    (assert (verify-backtrace #'bt.4
-                              '((bt.4 ?)))))
+    (assert (verify-backtrace #'bt.4.1
+                              '((bt.4.1 ?))))
+    (assert (verify-backtrace #'bt.4.2
+                              '((bt.4.2 ?))))
+    (assert (verify-backtrace #'bt.4.3
+                              '((bt.4.3 &rest)))))
 
   ;; &OPTIONAL-PROCESSOR
+  (print :optional-processor)
   (with-details t
-    (assert (verify-backtrace #'bt.5
-                              '(((sb-c::&optional-processor bt.5))))))
+    (assert (verify-backtrace #'bt.5.1
+                              '(((sb-c::&optional-processor bt.5.1)))))
+    (assert (verify-backtrace #'bt.5.2
+                              '(((sb-c::&optional-processor bt.5.2) &rest))))
+    (assert (verify-backtrace #'bt.5.3
+                              '(((sb-c::&optional-processor bt.5.3) &rest)))))
   (with-details nil
-    (assert (verify-backtrace #'bt.5
-                              '((bt.5))))))
+    (assert (verify-backtrace #'bt.5.1
+                              '((bt.5.1))))
+    (assert (verify-backtrace #'bt.5.2
+                              '((bt.5.2 &rest))))
+    (assert (verify-backtrace #'bt.5.3
+                              '((bt.5.3 &rest))))))
 
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 50ff475..1a0c3d7 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.20.27"
+"0.8.20.28"