;;; 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),
(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)))
(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
(defclass clos-typecheck-test ()
((slot :type fixnum)))
(setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
- '(((sb-pcl::slot-typecheck clos-typecheck-test slot) t)))))
+ '(((sb-pcl::slot-typecheck fixnum) t)))))
(with-test (:name :clos-emf-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))
+ :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)))
(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")