X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdebug.impure.lisp;h=cfa16d64397a9350b2381c73ebcd7da91c771117;hb=e57446ab7db28aca5599d8a2c62cfc3b4b9bbffa;hp=24112560ae55956a1555f55ae3e10105c9c9ef8b;hpb=2fb47966f49dd426130862dc7a96a7ffdea42bbb;p=sbcl.git diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 2411256..cfa16d6 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -81,7 +81,7 @@ ;;; and that it contains the frames we expect, doesn't contain any ;;; "bogus stack frame"s, and contains the appropriate toplevel call ;;; and hasn't been cut off anywhere. -(defun verify-backtrace (test-function frame-specs &key (allow-stunted nil)) +(defun verify-backtrace (test-function frame-specs &key (allow-stunted nil) details) (labels ((args-equal (want real) (cond ((eq '&rest (car want)) t) @@ -96,39 +96,66 @@ (handler-bind ((error (lambda (condition) ;; find the part of the backtrace we're interested in - (let* ((full-backtrace (sb-debug:backtrace-as-list)) - (backtrace (member (caar frame-specs) full-backtrace - :key #'car - :test #'equal))) - - (setf result condition) - - (unless backtrace - (format t "~&//~S not in backtrace:~% ~S~%" - (caar frame-specs) - full-backtrace) - (setf result nil)) - ;; check that we have all the frames we wanted - (mapcar - (lambda (spec frame) - (unless (or (not spec) - (and (equal (car spec) (car frame)) - (args-equal (cdr spec) - (cdr frame)))) - (print (list :wanted spec :got frame)) - (setf result nil))) - frame-specs - backtrace) - - ;; Make sure the backtrace isn't stunted in - ;; any way. (Depends on running in the main - ;; thread.) FIXME: On Windows we get two - ;; extra foreign frames below regular frames. - (unless (find '(sb-impl::toplevel-init) backtrace - :test #'equal) - (print (list :backtrace-stunted backtrace)) - (setf result nil)) - (return-from outer-handler))))) + (let (full-backtrace) + (sb-debug::map-backtrace + (lambda (frame) + (multiple-value-bind (name args info) + (sb-debug::frame-call frame #+nil #+nil + :replace-dynamic-extent-objects t) + (if details + (push (list (cons name args) info) full-backtrace) + (push (cons name args) full-backtrace))))) + + (setf full-backtrace (nreverse full-backtrace)) + (let ((backtrace (if details + (member (caaar frame-specs) + full-backtrace + :key #'caar + :test #'equal) + (member (caar frame-specs) + full-backtrace + :key #'car + :test #'equal)))) + + (setf result condition) + + (unless backtrace + (format t "~&//~S not in backtrace:~% ~S~%" + (caar frame-specs) + full-backtrace) + (setf result nil)) + ;; check that we have all the frames we wanted + (mapcar + (lambda (spec frame) + (unless (or (not spec) + (if details + (handler-case + (and (args-equal (car spec) + (car frame)) + (equal (cdr spec) (cdr frame))) + (error (e) + (print (list :spec spec :frame frame)) + (error e))) + (and (equal (car spec) (car frame)) + (args-equal (cdr spec) + (cdr frame))))) + (print (list :wanted spec :got frame)) + (setf result nil))) + frame-specs + backtrace) + + ;; Make sure the backtrace isn't stunted in + ;; any way. (Depends on running in the main + ;; thread.) FIXME: On Windows we get two + ;; extra foreign frames below regular frames. + (unless (find (if details + '((sb-impl::toplevel-init) ()) + '(sb-impl::toplevel-init)) + backtrace + :test #'equal) + (print (list :backtrace-stunted backtrace)) + (setf result nil)) + (return-from outer-handler)))))) (funcall test-function))) result))) @@ -177,11 +204,12 @@ ;; stunted, ending at _sigtramp, when we add :TIMEOUT NIL to ;; the frame we expect. If we leave it out, the backtrace is ;; fine -- but the test fails. I can only boggle right now. - :fails-on '(and :x86 (or :linux :darwin))) + :fails-on `(or (and :x86 :linux) + :win32)) (let ((m (sb-thread:make-mutex)) (q (sb-thread:make-waitqueue))) (assert (verify-backtrace - (lambda () + (lambda () (sb-thread:with-mutex (m) (handler-bind ((timeout (lambda (c) (error "foo")))) @@ -291,109 +319,108 @@ (defbt 5 (&optional (opt (oops))) (list opt)) -(defmacro with-details (bool &body body) - `(let ((sb-debug:*show-entry-point-details* ,bool)) - ,@body)) - (defun bug-354 (x) (error "XEPs in backtraces: ~S" x)) (with-test (:name :bug-354) - (with-details t - (assert (not (verify-backtrace (lambda () (bug-354 354)) - '((bug-354 &rest) - ((sb-c::tl-xep bug-354) &rest)))))) + (assert (not (verify-backtrace (lambda () (bug-354 354)) + '((bug-354 354) + (((bug-354 &rest) (:tl :external)) 354))))) (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354))))) ;;; FIXME: This test really should be broken into smaller pieces (with-test (:name (:backtrace :tl-xep)) - (with-details t - (assert (verify-backtrace #'namestring - '(((sb-c::tl-xep namestring) 0 ?))))) - (with-details nil - (assert (verify-backtrace #'namestring - '((namestring)))))) + (assert (verify-backtrace #'namestring + '(((namestring) (:tl :external))) + :details t)) + (assert (verify-backtrace #'namestring + '((namestring))))) (with-test (:name (:backtrace :more-processor)) - (with-details t - (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 (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)))))) + (assert (verify-backtrace (lambda () (bt.1.1 :key)) + '(((bt.1.1 :key) (:more :optional))) + :details t)) + (assert (verify-backtrace (lambda () (bt.1.2 :key)) + '(((bt.1.2 ?) (:more :optional))) + :details t)) + (assert (verify-backtrace (lambda () (bt.1.3 :key)) + '(((bt.1.3 &rest) (:more :optional))) + :details t)) + (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))))) (with-test (:name (:backtrace :xep)) - (with-details t - (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 #'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)))))) - + (assert (verify-backtrace #'bt.2.1 + '(((bt.2.1) (:external))) + :details t)) + (assert (verify-backtrace #'bt.2.2 + '(((bt.2.2 &rest) (:external))) + :details t)) + (assert (verify-backtrace #'bt.2.3 + '(((bt.2.3 &rest) (:external))) + :details t)) + (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))))) + +;;; This test is somewhat deceptively named. Due to confusion in debug naming +;;; these functions used to have sb-c::varargs-entry debug names for their +;;; main lambda. (with-test (:name (:backtrace :varargs-entry)) - (with-details t - (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.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)))))) - + (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)))) + (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))))) + +;;; This test is somewhat deceptively named. Due to confusion in debug naming +;;; these functions used to have sb-c::hairy-args-processor debug names for +;;; their main lambda. (with-test (:name (:backtrace :hairy-args-processor)) - (with-details t - (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.1 - '((bt.4.1 ?)))) - (assert (verify-backtrace #'bt.4.2 - '((bt.4.2 ?)))) - (assert (verify-backtrace #'bt.4.3 - '((bt.4.3 &rest)))))) + (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)))) + (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))))) (with-test (:name (:backtrace :optional-processor)) - (with-details t - (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.1 - '((bt.5.1)))) - (assert (verify-backtrace #'bt.5.2 - '((bt.5.2 &rest)))) - (assert (verify-backtrace #'bt.5.3 - '((bt.5.3 &rest)))))) + (assert (verify-backtrace #'bt.5.1 + '(((bt.5.1) (:optional))) + :details t)) + (assert (verify-backtrace #'bt.5.2 + '(((bt.5.2 &rest) (:optional))) + :details t)) + (assert (verify-backtrace #'bt.5.3 + '(((bt.5.3 &rest) (:optional))) + :details t)) + (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))))) (write-line "//compile nil") (defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil)))) @@ -516,7 +543,7 @@ (declare (dynamic-extent dx-arg)) (flet ((dx-arg-backtrace (x) (declare (optimize (debug 2))) - (prog1 (sb-debug:backtrace-as-list 10) + (prog1 (sb-debug:list-backtrace :count 10) (assert (sb-debug::stack-allocated-p x))))) (declare (notinline dx-arg-backtrace)) (assert (member-if (lambda (frame) @@ -534,7 +561,8 @@ ((error (lambda (e) (declare (ignore e)) (handler-case - (sb-debug:backtrace 100 (make-broadcast-stream)) + (sb-debug:print-backtrace :count 100 + :stream (make-broadcast-stream)) (error () (throw 'done :error)) (:no-error () @@ -650,6 +678,8 @@ (if (eq '* match) ;; Whatever, till the next line matches. (let ((text (pop targets))) + #+nil + (format *error-output* "Looking for: ~A~%" text) (unless (search text line) (push text targets) (push match targets))) @@ -694,7 +724,7 @@ (let ((f #'(lambda (x cont) (print x (make-broadcast-stream)) (if (zerop x) - (error "foo") + (error "~%foo") (funcall cont (1- x) cont))))) (funcall f 10 f))) '* @@ -702,7 +732,7 @@ '* "foo" '* - "source: (ERROR \"foo\")" + "source: (ERROR \"~%foo\")" '* "(LAMBDA (X CONT)" '* @@ -742,4 +772,17 @@ (unless (zerop (length problems)) (error problems))))) +(defgeneric gf-dispatch-test/gf (x y) + (:method (x y) + (+ x y))) +(defun gf-dispatch-test/f (z) + (gf-dispatch-test/gf z)) + +(with-test (:name :gf-dispatch-backtrace) + ;; Fill the cache + (gf-dispatch-test/gf 1 1) + ;; Wrong argument count + (assert (verify-backtrace (lambda () (gf-dispatch-test/f 42)) + '(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42))))) + (write-line "/debug.impure.lisp done")