;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
;;; whatever. But we do know the general structure that a correct
;;; answer should have, so we can safely do a lot of checks.)
-(destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
- (assert (symbolp object-sym))
- (assert (eql &optional-sym '&optional))
- (assert (symbolp stream-sym)))
-(destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
- (get-arglist #'format)
- (assert (symbolp dest-sym))
- (assert (symbolp control-sym))
- (assert (eql &rest-sym '&rest))
- (assert (symbolp format-args-sym)))
+(with-test (:name :predefined-functions-1)
+ (destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
+ (assert (symbolp object-sym))
+ (assert (eql &optional-sym '&optional))
+ (assert (symbolp stream-sym))))
+(with-test (:name :predefined-functions-2)
+ (destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
+ (get-arglist #'format)
+ (assert (symbolp dest-sym))
+ (assert (symbolp control-sym))
+ (assert (eql &rest-sym '&rest))
+ (assert (symbolp format-args-sym))))
;;; Check for backtraces generally being correct. Ensure that the
;;; actual backtrace finishes (doesn't signal any errors on its own),
(caar frame-specs)
full-backtrace)
(setf result nil))
-
;; check that we have all the frames we wanted
(mapcar
(lambda (spec frame)
(and (equal (car spec) (car frame))
(args-equal (cdr spec)
(cdr frame))))
- (print (list :mismatch spec frame))
+ (print (list :wanted spec :got frame))
(setf result nil)))
frame-specs
backtrace)
;; any way. (Depends on running in the main
;; thread.) FIXME: On Windows we get two
;; extra foreign frames below regular frames.
- (let ((end (last backtrace #-win32 2 #+win32 4)))
- (unless (equal (caar end)
- 'sb-impl::toplevel-init)
- (print (list :backtrace-stunted (caar end)))
- (setf result nil)))
+ (unless (find '(sb-impl::toplevel-init) backtrace
+ :test #'equal)
+ (print (list :backtrace-stunted backtrace))
+ (setf result nil))
(return-from outer-handler)))))
(funcall test-function)))
result)))
(list '(flet not-optimized))
(list '(flet test) #'not-optimized))))))
+(with-test (:name :backtrace-interrupted-condition-wait
+ :skipped-on '(not :sb-thread)
+ ;; For some unfathomable reason the backtrace becomes
+ ;; stunted on Darwin, 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 :darwin)
+ (let ((m (sb-thread:make-mutex))
+ (q (sb-thread:make-waitqueue)))
+ (assert (verify-backtrace
+ (lambda ()
+ (sb-thread:with-mutex (m)
+ (handler-bind ((timeout (lambda (c)
+ (error "foo"))))
+ (with-timeout 0.1
+ (sb-thread:condition-wait q m)))))
+ `((sb-thread:condition-wait ,q ,m :timeout nil))))))
+
;;; Division by zero was a common error on PPC. It depended on the
;;; return function either being before INTEGER-/-INTEGER in memory,
;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
(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)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :tl-xep))
(with-details t
(assert (verify-backtrace #'namestring
'(((sb-c::tl-xep namestring) 0 ?)))))
(assert (verify-backtrace #'namestring
'((namestring))))))
-(with-test (:name (:backtrace :more-processor)
- :fails-on '(and :x86 (or :sunos)))
+(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.3 :key))
'((bt.1.3 &rest))))))
-(with-test (:name (:backtrace :xep)
- :fails-on '(and :x86 (or :sunos)))
+(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.3
'((bt.2.3 &rest))))))
-(with-test (:name (:backtrace :varargs-entry)
- :fails-on '(and :x86 (or :sunos)))
+(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.3
'((bt.3.3 &rest))))))
-(with-test (:name (:backtrace :hairy-args-processor)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :hairy-args-processor))
(with-details t
(assert (verify-backtrace #'bt.4.1
'(((sb-c::hairy-arg-processor bt.4.1) ?))))
'((bt.4.3 &rest))))))
-(with-test (:name (:backtrace :optional-processor)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :optional-processor))
(with-details t
(assert (verify-backtrace #'bt.5.1
'(((sb-c::&optional-processor bt.5.1)))))
(write-line "//compile nil")
(defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil))))
(defvar *compile-nil-non-tc* (compile nil '(lambda (y) (cons (funcall *compile-nil-error* y) nil))))
-(assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
- '(((lambda (x)) 13)
- ((lambda (y)) 13))))
+(with-test (:name (:compile nil))
+ (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
+ '(((lambda (x)) 13)
+ ((lambda (y)) 13)))))
(with-test (:name :clos-slot-typecheckfun-named)
(assert
1
(* n (trace-fact (1- n)))))
-(let ((out (with-output-to-string (*trace-output*)
- (trace trace-this)
- (assert (eq 'ok (trace-this)))
- (untrace))))
- (assert (search "TRACE-THIS" out))
- (assert (search "returned OK" out)))
+(with-test (:name (trace :simple))
+ (let ((out (with-output-to-string (*trace-output*)
+ (trace trace-this)
+ (assert (eq 'ok (trace-this)))
+ (untrace))))
+ (assert (search "TRACE-THIS" out))
+ (assert (search "returned OK" out))))
;;; bug 379
;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
;;; suspicions that the breakpoint trace might corrupt the whole image
;;; on that platform.
-#-(and (or ppc x86 x86-64) (or darwin sunos))
(with-test (:name (trace :encapsulate nil)
- :fails-on '(or (and :ppc (not :linux)) :sparc :mips))
+ :fails-on '(or (and :ppc (not :linux)) :sparc :mips)
+ :broken-on '(or :darwin :sunos))
(let ((out (with-output-to-string (*trace-output*)
(trace trace-this :encapsulate nil)
(assert (eq 'ok (trace-this)))
(assert (search "TRACE-THIS" out))
(assert (search "returned OK" out))))
-#-(and (or ppc x86 x86-64) darwin)
(with-test (:name (trace-recursive :encapsulate nil)
- :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos))
+ :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*)
(trace trace-fact :encapsulate nil)
(assert (= 120 (trace-fact 5)))
(load (compile-file "bug-414.lisp"))
(disassemble 'bug-414)))
-(with-test (:name :bug-310175)
- (let ((dx-arg (cons t t)))
+(with-test (:name :bug-310175 :fails-on '(not :stack-allocatable-lists))
+ ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
+ ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS. Therefore,
+ ;; use two-arg-LIST, which should get through to VOP LIST, and thus
+ ;; stack-allocate on a predictable set of machines.
+ (let ((dx-arg (list t t)))
(declare (dynamic-extent dx-arg))
(flet ((dx-arg-backtrace (x)
(declare (optimize (debug 2)))
(notany #'sb-debug::stack-allocated-p (cdr frame))))
(dx-arg-backtrace dx-arg))))))
+(with-test (:name :bug-795245)
+ (assert
+ (eq :ok
+ (catch 'done
+ (handler-bind
+ ((error (lambda (e)
+ (declare (ignore e))
+ (handler-case
+ (sb-debug:backtrace 100 (make-broadcast-stream))
+ (error ()
+ (throw 'done :error))
+ (:no-error ()
+ (throw 'done :ok))))))
+ (apply '/= nil 1 2 nil))))))
+
;;;; test infinite error protection
(defmacro nest-errors (n-levels error-form)
:normal-exit)))))))
(write-line "--END OF H-B-A-B--"))
-(enable-debugger)
-
-(test-inifinite-error-protection)
+(with-test (:name infinite-error-protection)
+ (enable-debugger)
+ (test-inifinite-error-protection))
-#+sb-thread
-(let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
- (loop while (sb-thread:thread-alive-p 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)))
+ (loop while (sb-thread:thread-alive-p thread))))
+;; unconditional, in case either previous left it enabled
(disable-debugger)
(write-line "/debug.impure.lisp done")
projects / sbcl.git / blobdiff