;; 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 `(or (and :x86 :linux)
- :darwin
:win32))
(let ((m (sb-thread:make-mutex))
(q (sb-thread:make-waitqueue)))
'(((flet bar :in bug-308926) 13)
(bug-308926 &rest t)))))
+;;; Test backtrace through assembly routines
+;;; :bug-800343
+(macrolet ((test (predicate fun
+ &optional (two-arg
+ (find-symbol (format nil "TWO-ARG-~A" fun)
+ "SB-KERNEL")))
+ (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
+ `(flet ((,test-name (x y)
+ ;; make sure it's not in tail position
+ (list (,fun x y))))
+ (with-test (:name (:bug-800343 ,fun))
+ (assert (verify-backtrace
+ (lambda ()
+ (eval `(funcall ,#',test-name 42 t)))
+ '((,two-arg 42 t)
+ #+(or x86 x86-64)
+ ,@(and predicate
+ '(("no debug information for frame")))
+ ((flet ,test-name :in ,*p*) 42 t))))))))
+ (test-predicates (&rest functions)
+ `(progn ,@(mapcar (lambda (function)
+ (if (consp function)
+ `(test t ,@function)
+ `(test t ,function)))
+ functions)))
+ (test-functions (&rest functions)
+ `(progn ,@(mapcar (lambda (function)
+ (if (consp function)
+ `(test nil ,@function)
+ `(test nil ,function)))
+ functions))))
+ (test-predicates = < >)
+ (test-functions + - * /
+ gcd lcm
+ (logand sb-kernel:two-arg-and)
+ (logior sb-kernel:two-arg-ior)
+ (logxor sb-kernel:two-arg-xor)))
+
;;; test entry point handling in backtraces
(defun oops ()
(assert (search "TRACE-THIS" out))
(assert (search "returned OK" out))))
-(with-test (:name (trace-recursive :encapsulate nil)
+(with-test (:name (:trace-recursive :encapsulate nil)
:fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos)
:broken-on '(or :darwin (and :x86 :sunos)))
(let ((out (with-output-to-string (*trace-output*)
(format t "recursive condition: ~A~%" condition) (force-output)
(error "recursive condition: ~A" condition)))
-(defun test-inifinite-error-protection ()
+(defun test-infinite-error-protection ()
;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
;; to halt, it produces so much garbage that's hard to suppress that
;; it is tested only once
:normal-exit)))))))
(write-line "--END OF H-B-A-B--"))
-(with-test (:name infinite-error-protection)
+(with-test (:name :infinite-error-protection)
(enable-debugger)
- (test-inifinite-error-protection))
+ (test-infinite-error-protection))
-(with-test (:name (infinite-error-protection :thread)
+(with-test (:name (:infinite-error-protection :thread)
:skipped-on '(not :sb-thread))
(enable-debugger)
- (let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
+ (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
(loop while (sb-thread:thread-alive-p thread))))
;; unconditional, in case either previous left it enabled
;;; Older GENCGC systems had a bug in the pointer validation used by
;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
;;; validate.
-(with-test (:name (make-lisp-obj :simple-funs))
+(with-test (:name (:make-lisp-obj :simple-funs))
(sb-sys:without-gcing
(assert (eq #'identity
(sb-kernel:make-lisp-obj
;;; Older CHENEYGC systems didn't perform any real pointer validity
;;; checks beyond "is this pointer to somewhere in heap space".
-(with-test (:name (make-lisp-obj :pointer-validation))
+(with-test (:name (:make-lisp-obj :pointer-validation))
;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
;; address, but we also need the GC to not pitch a fit if it sees an
;; object with said bogus address. Thus, construct our known-bogus
(assert (verify-backtrace (lambda () (gf-dispatch-test/f 42))
'(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42)))))
+(with-test (:name (:xep-arglist-clean-up :bug-1192929))
+ (assert
+ (block nil
+ (handler-bind ((error (lambda (e)
+ (declare (ignore e))
+ (return (< (length (car (sb-debug:backtrace-as-list 1))) 10)))))
+ (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
+
(write-line "/debug.impure.lisp done")