((foo (unsigned 32)))
foo)
-#+(or x86-64 x86)
-(with-test (:name bug-316325)
+(with-test (:name bug-316325 :skipped-on '(not (or :x86-64 :x86)))
;; This test works by defining a callback function that provides an
;; identity transform over a full-width machine word, then calling
;; it as if it returned a narrower type and checking to see if any
(assert (= n 1))
(assert (not final))))
-#+(and sb-thread (not sb-lutex))
-(progn
-
- (with-test (:name (:deadline :get-mutex))
- (assert-timeout
- (let ((lock (sb-thread:make-mutex))
- (waitp t))
- (sb-thread:make-thread (lambda ()
- (sb-thread:get-mutex lock)
- (setf waitp nil)
- (sleep 5)))
- (loop while waitp do (sleep 0.01))
- (sb-sys:with-deadline (:seconds 1)
- (sb-thread:get-mutex lock)))))
-
- (with-test (:name (:deadline :wait-on-semaphore))
- (assert-timeout
- (let ((sem (sb-thread::make-semaphore :count 0)))
- (sb-sys:with-deadline (:seconds 1)
- (sb-thread::wait-on-semaphore sem)))))
+(with-test (:name (:deadline :get-mutex) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (assert-timeout
+ (let ((lock (sb-thread:make-mutex))
+ (waitp t))
+ (sb-thread:make-thread (lambda ()
+ (sb-thread:get-mutex lock)
+ (setf waitp nil)
+ (sleep 5)))
+ (loop while waitp do (sleep 0.01))
+ (sb-sys:with-deadline (:seconds 1)
+ (sb-thread:get-mutex lock)))))
- (with-test (:name (:deadline :join-thread))
- (assert-timeout
+(with-test (:name (:deadline :wait-on-semaphore) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (assert-timeout
+ (let ((sem (sb-thread::make-semaphore :count 0)))
(sb-sys:with-deadline (:seconds 1)
- (sb-thread:join-thread
- (sb-thread:make-thread (lambda () (loop (sleep 1))))))))
+ (sb-thread::wait-on-semaphore sem)))))
+
+(with-test (:name (:deadline :join-thread) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (assert-timeout
+ (sb-sys:with-deadline (:seconds 1)
+ (sb-thread:join-thread
+ (sb-thread:make-thread (lambda () (loop (sleep 1))))))))
- (with-test (:name (:deadline :futex-wait-eintr))
- (let ((lock (sb-thread:make-mutex))
- (waitp t))
- (sb-thread:make-thread (lambda ()
- (sb-thread:get-mutex lock)
- (setf waitp nil)
- (sleep 5)))
- (loop while waitp do (sleep 0.01))
- (let ((thread (sb-thread:make-thread
- (lambda ()
- (let ((start (get-internal-real-time)))
- (handler-case
- (sb-sys:with-deadline (:seconds 1)
- (sb-thread:get-mutex lock))
- (sb-sys:deadline-timeout (x)
- (declare (ignore x))
- (let ((end (get-internal-real-time)))
- (float (/ (- end start)
- internal-time-units-per-second)
- 0.0)))))))))
- (sleep 0.3)
- (sb-thread:interrupt-thread thread (lambda () 42))
- (let ((seconds-passed (sb-thread:join-thread thread)))
- (format t "Deadline in ~S~%" seconds-passed)
- (assert (< seconds-passed 1.2)))))))
\ No newline at end of file
+(with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (let ((lock (sb-thread:make-mutex))
+ (waitp t))
+ (sb-thread:make-thread (lambda ()
+ (sb-thread:get-mutex lock)
+ (setf waitp nil)
+ (sleep 5)))
+ (loop while waitp do (sleep 0.01))
+ (let ((thread (sb-thread:make-thread
+ (lambda ()
+ (let ((start (get-internal-real-time)))
+ (handler-case
+ (sb-sys:with-deadline (:seconds 1)
+ (sb-thread:get-mutex lock))
+ (sb-sys:deadline-timeout (x)
+ (declare (ignore x))
+ (let ((end (get-internal-real-time)))
+ (float (/ (- end start)
+ internal-time-units-per-second)
+ 0.0)))))))))
+ (sleep 0.3)
+ (sb-thread:interrupt-thread thread (lambda () 42))
+ (let ((seconds-passed (sb-thread:join-thread thread)))
+ (format t "Deadline in ~S~%" seconds-passed)
+ (assert (< seconds-passed 1.2))))))
(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)))))
;;; 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)))
(defvar *a-cons* (cons nil nil))
-#+stack-allocatable-closures
-(with-test (:name (:no-consing :dx-closures))
+(with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures))
(assert-no-consing (dxclosure 42)))
-#+stack-allocatable-lists
-(with-test (:name (:no-consing :dx-lists))
+(with-test (:name (:no-consing :dx-lists) :skipped-on '(not :stack-allocatable-lists))
(assert-no-consing (dxlength 1 2 3))
(assert-no-consing (dxlength t t t t t t))
(assert-no-consing (dxlength))
(with-test (:name (:no-consing :dx-value-cell))
(assert-no-consing (dx-value-cell 13)))
-#+stack-allocatable-fixed-objects
-(with-test (:name (:no-consing :dx-fixed-objects))
+(with-test (:name (:no-consing :dx-fixed-objects) :skipped-on '(not :stack-allocatable-fixed-objects))
(assert-no-consing (cons-on-stack 42))
(assert-no-consing (make-foo1-on-stack 123))
(assert-no-consing (nested-good 42))
(assert-no-consing (dx-handler-bind 2))
(assert-no-consing (dx-handler-case 2)))
-#+stack-allocatable-vectors
-(with-test (:name (:no-consing :dx-vectors))
+(with-test (:name (:no-consing :dx-vectors) :skipped-on '(not :stack-allocatable-vectors))
(assert-no-consing (force-make-array-on-stack 128))
(assert-no-consing (make-array-on-stack-1))
(assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
(assert-no-consing (make-array-on-stack-5))
(assert-no-consing (vector-on-stack :x :y)))
-#+raw-instance-init-vops
-(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc)
+(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc :skipped-on '(not :raw-instance-init-vops))
(let (a b)
(setf a 1.24 b 1.23d0)
(assert-no-consing (make-foo2-on-stack a b)))
(sb-thread:with-mutex (*mutex*)
(true *mutex*)))
-#+sb-thread
-(with-test (:name (:no-consing :mutex) :fails-on :ppc)
+(with-test (:name (:no-consing :mutex) :fails-on :ppc :skipped-on '(not :sb-thread))
(assert-no-consing (test-mutex)))
-#+sb-thread
-(with-test (:name (:no-consing :spinlock) :fails-on :ppc)
+(with-test (:name (:no-consing :spinlock) :fails-on :ppc :skipped-on '(not :sb-thread))
(assert-no-consing (test-spinlock)))
\f
(simple-type-error () 'error)))
t)))
-#+sb-eval
-(with-test (:name :bug-524707)
+(with-test (:name :bug-524707 :skipped-on '(not :sb-eval))
(let ((*evaluator-mode* :interpret)
(lambda-form '(lambda (x) (declare (fixnum x)) (1+ x))))
(let ((fun (eval lambda-form)))
(setq ok t)))
(assert ok))))
-#+c-stack-is-control-stack
-(with-test (:name (:exhaust :alien-stack))
+(with-test (:name (:exhaust :alien-stack) :skipped-on '(not :c-stack-is-control-stack))
(let ((ok nil))
(labels ((exhaust-alien-stack (i)
(with-alien ((integer-array (array int 500)))
(the (eql #c(1.0 2.0))
x))))))))
-;; The x86 port used not to reduce the arguments of transcendentals
-;; correctly. On other platforms, we trust libm to DTRT.
-#+x86
+;; This was previously x86-only, with note:
+;; The x86 port used not to reduce the arguments of transcendentals
+;; correctly. On other platforms, we trust libm to DTRT.
+;; but it doesn't cost any real amount to just test them all
(with-test (:name :range-reduction)
(flet ((almost= (x y)
(< (abs (- x y)) 1d-5)))
;; The tests are extremely brittle and could be broken by any number of
;; back- or front-end optimisations. We should just keep the issue above
;; in mind at all times when working with SSE or similar instruction sets.
-#+(or x86 x86-64) ;; No other platforms have SB-VM::TOUCH-OBJECT.
+;;
+;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
(macrolet ((with-pinned-floats ((count type &rest names) &body body)
"Force COUNT float values to be kept live (and hopefully in registers),
fill a temporary register with noise, and execute BODY."
(locally ,@body))
,@(loop for var in dummy
collect `(sb-vm::touch-object ,var)))))))
- (with-test (:name :clear-sqrtsd)
+ (with-test (:name :clear-sqrtsd :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-sqrtsd (float)
(declare (optimize speed (safety 1))
(type (double-float (0d0)) float))
(declare (notinline test-sqrtsd))
(assert (zerop (imagpart (test-sqrtsd 4d0))))))
- (with-test (:name :clear-sqrtsd-single)
+ (with-test (:name :clear-sqrtsd-single :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-sqrtsd-float (float)
(declare (optimize speed (safety 1))
(type (single-float (0f0)) float))
(declare (notinline test-sqrtsd-float))
(assert (zerop (imagpart (test-sqrtsd-float 4f0))))))
- (with-test (:name :clear-cvtss2sd)
+ (with-test (:name :clear-cvtss2sd :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtss2sd (float)
(declare (optimize speed (safety 1))
(type single-float float))
(declare (notinline test-cvtss2sd))
(assert (zerop (imagpart (test-cvtss2sd 1f0))))))
- (with-test (:name :clear-cvtsd2ss)
+ (with-test (:name :clear-cvtsd2ss :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtsd2ss (float)
(declare (optimize speed (safety 1))
(type double-float float))
(declare (notinline test-cvtsd2ss))
(assert (zerop (imagpart (test-cvtsd2ss 4d0))))))
- (with-test (:name :clear-cvtsi2sd)
+ (with-test (:name :clear-cvtsi2sd :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtsi2sd (int)
(declare (optimize speed (safety 0))
(type (unsigned-byte 10) int))
(declare (notinline test-cvtsi2sd))
(assert (zerop (imagpart (test-cvtsi2sd 4))))))
- (with-test (:name :clear-cvtsi2ss)
+ (with-test (:name :clear-cvtsi2ss :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtsi2ss (int)
(declare (optimize speed (safety 0))
(type (unsigned-byte 10) int))
(assert gc-happend)))
;;; SB-EXT:GENERATION-* accessors returned bogus values for generation > 0
-#+gencgc
-(with-test (:name :bug-529014)
+(with-test (:name :bug-529014 :skipped-on '(not :gencgc))
;; FIXME: These parameters are a) tunable in the source and b)
;; duplicated multiple times there and now here. It would be good to
;; OAOO-ify them (probably to src/compiler/generic/params.lisp).
;;; This test works reliably on non-conservative platforms and
;;; somewhat reliably on conservative platforms with threads.
-#+(or (not (or x86 x86-64)) sb-thread)
(progn
(defparameter *ht* nil)
(sb-thread::wait-on-semaphore ,sem)
(values-list ,values))))
-(with-test (:name (:hash-table :weakness :eql :numbers))
+(with-test (:name (:hash-table :weakness :eql :numbers) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(flet ((random-number ()
(random 1000)))
(loop for weakness in '(nil :key :value :key-and-value :key-or-value) do
(format stream "Hash: ~S~%" (sb-impl::hash-table-hash-vector ht))
(force-output stream))
-(with-test (:name (:hash-table :weakness :removal))
+(with-test (:name (:hash-table :weakness :removal) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(loop for test in '(eq eql equal equalp) do
(format t "test: ~A~%" test)
(loop for weakness in '(:key :value :key-and-value :key-or-value)
(return)))
(gc :full t))))))
-(with-test (:name (:hash-table :weakness :string-interning))
+(with-test (:name (:hash-table :weakness :string-interning) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(let ((ht (make-hash-table :test 'equal :weakness :key))
(s "a"))
(setf (gethash s ht) s)
(assert (eq (gethash (copy-seq s) ht) s))))
;;; see if hash_vector is not written when there is none ...
-(with-test (:name (:hash-table :weakness :eq))
+(with-test (:name (:hash-table :weakness :eq) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(loop repeat 10 do
(let ((index (random 2000)))
(let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
hash-table)))))
;; used to crash in gc
-(with-test (:name (:hash-table :weakness :keep))
+(with-test (:name (:hash-table :weakness :keep) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(loop repeat 2 do
(let ((h1 (make-hash-table :weakness :key :test #'equal))
(keep ()))
(assert (not (setf (documentation 'docfoo 'function) nil)))
(assert (string= (documentation 'docfoo 'function) "zot")))
-#+sb-doc
-(with-test (:name (documentation built-in-macro))
+(with-test (:name (documentation built-in-macro) :skipped-on '(not :sb-doc))
(assert (documentation 'trace 'function)))
-#+sb-doc
-(with-test (:name (documentation built-in-function))
+(with-test (:name (documentation built-in-function) :skipped-on '(not :sb-doc))
(assert (documentation 'cons 'function)))
(with-test (:name :describe-generic-function-with-assumed-type)
;;; SLEEP should work with large integers as well -- no timers
;;; on win32, so don't test there.
-#-win32
-(with-test (:name (sleep pretty-much-forever))
+(with-test (:name (sleep pretty-much-forever) :skipped-on :win32)
(assert (eq :timeout
(handler-case
(sb-ext:with-timeout 1
;;; comprehensive test.
(loop repeat 2
do (compile nil '(lambda (x) x))
- do (sb-ext:gc :full t))
\ No newline at end of file
+ do (sb-ext:gc :full t))
(assert (equalp #(251) (string-to-octets (string (code-char 369))
:external-format :latin-2)))
-#+sb-unicode
-(with-test (:name (:euc-jp :decoding-errors))
+(with-test (:name (:euc-jp :decoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-decoding-error
(lambda (c) (use-value #\? c))))
(assert (string= "?{?"
(coerce #(182 123 253 238) '(vector (unsigned-byte 8)))
:external-format :euc-jp)))))
-#+sb-unicode
-(with-test (:name (:utf-8 :surrogates :encoding-errors))
+(with-test (:name (:utf-8 :surrogates :encoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-encoding-error
(lambda (c) (use-value #\? c))))
(assert (equalp (string-to-octets (string (code-char #xd800))
:external-format :utf-8)
(vector (char-code #\?))))))
-#+sb-unicode
-(with-test (:name (:utf-8 :surrogates :decoding-errors))
+(with-test (:name (:utf-8 :surrogates :decoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-decoding-error
(lambda (c) (use-value #\? c))))
(assert (find #\? (octets-to-string
(coerce #(237 160 128) '(vector (unsigned-byte 8)))
:external-format :utf-8)))))
-#+sb-unicode
-(with-test (:name (:ucs-2 :out-of-range :encoding-errors))
+(with-test (:name (:ucs-2 :out-of-range :encoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-encoding-error
(lambda (c) (use-value "???" c))))
(assert (equalp (string-to-octets (string (code-char #x10001))
:external-format :ucs-2be)
#(0 63 0 63 0 63)))))
-#+sb-unicode
-(with-test (:name (:ucs-4 :out-of-range :decoding-errors))
+(with-test (:name (:ucs-4 :out-of-range :decoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-decoding-error
(lambda (c) (use-value "???" c))))
(assert (equalp (octets-to-string (coerce '(1 2 3 4) '(vector (unsigned-byte 8)))
:external-format :ucs-4be)
(string (code-char #x10ffff))))))
-#+sb-unicode
-(with-test (:name (:utf-16le :ensure-roundtrip))
+(with-test (:name (:utf-16le :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-16le))
(dec (x)
(octets #(#x20 0 0 #x2 0 #x20 0 #xd8 0 #xdc 1 #xd8 1 #xdc #xff #xdb #xfd #xdf)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-16le :encoding-error))
+
+(with-test (:name (:utf-16le :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-16le :replacement #\?)))
(dec (x)
(let ((string (map 'string 'code-char '(#xd800 #xdc00 #xfffe #x10ffff))))
(assert (equalp (enc string) #(63 0 63 0 63 0 63 0))))))
-#+sb-unicode
-(with-test (:name (:utf-16be :ensure-roundtrip))
+(with-test (:name (:utf-16be :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-16be))
(dec (x)
(octets #(0 #x20 #x2 0 #x20 0 #xd8 0 #xdc 0 #xd8 1 #xdc 1 #xdb #xff #xdf #xfd)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-16be :encoding-error))
+
+(with-test (:name (:utf-16be :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-16be :replacement #\?)))
(dec (x)
(let ((string (map 'string 'code-char '(#xd800 #xdc00 #xfffe #x10ffff))))
(assert (equalp (enc string) #(0 63 0 63 0 63 0 63))))))
-#+sb-unicode
-(with-test (:name (:utf-32le :ensure-roundtrip))
+
+(with-test (:name (:utf-32le :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-32le))
(dec (x)
(octets #(#x20 0 0 0 0 #x2 0 0 0 #x20 0 0 0 0 1 0 1 4 1 0 #xfd #xff #x10 0)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-32le :encoding-error))
+
+(with-test (:name (:utf-32le :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-32le :replacement #\?)))
(dec (x)
(let ((string (map 'string 'code-char '(#xd800 #xdc00 #xfffe #x10ffff))))
(assert (equalp (enc string) #(63 0 0 0 63 0 0 0 63 0 0 0 63 0 0 0))))))
-#+sb-unicode
-(with-test (:name (:utf-32be :ensure-roundtrip))
+
+(with-test (:name (:utf-32be :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-32be))
(dec (x)
(octets #(0 0 0 #x20 0 0 #x2 0 0 0 #x20 0 0 1 0 0 0 1 4 1 0 #x10 #xff #xfd)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-32be :encoding-error))
+
+(with-test (:name (:utf-32be :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-32be :replacement #\?)))
(dec (x)
:good)))))
;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
-#+sb-thread
-(with-test (:name :bug-511072)
+(with-test (:name :bug-511072 :skipped-on '(not :sb-thread))
(let* ((p (make-package :bug-511072))
(sem (sb-thread:make-semaphore))
(t2 (sb-thread:make-thread (lambda ()
;;; Reported by Willem Broekema: Reading #p"\\\\" caused an error due
;;; to insufficient sanity in input testing in EXTRACT-DEVICE (in
;;; src;code;win32-pathname).
-#+win32
-(with-test (:name :bug-489698)
+(with-test (:name :bug-489698 :skipped-on '(not :win32))
(assert (equal (make-pathname :directory '(:absolute))
(read-from-string "#p\"\\\\\\\\\""))))
(ignore-errors
(delete-file file)))))
-#+sb-unicode
-(with-test (:name (:print-readable :character :utf-8))
+(with-test (:name (:print-readable :character :utf-8) :skipped-on '(not :sb-unicode))
(test-readable-character (code-char #xfffe) :utf-8))
-#+sb-unicode
-(with-test (:name (:print-readable :character :iso-8859-1))
+(with-test (:name (:print-readable :character :iso-8859-1) :skipped-on '(not :sb-unicode))
(test-readable-character (code-char #xfffe) :iso-8859-1))
(assert (string= (eval '(format nil "~:C" #\a)) "a"))
(assert (= (read-byte in) i)))
(process-close process))))
-#+sb-thread
-(with-test (:name :run-program-cat-2)
+(with-test (:name :run-program-cat-2 :skipped-on '(not :sb-thread))
;; Tests that reading from a FIFO is interruptible.
(let* ((process (sb-ext:run-program "/bin/cat" '()
:wait nil
(defun report ()
(terpri)
(format t "Finished running tests.~%")
- (cond (*all-failures*
- (format t "Status:~%")
- (dolist (fail (reverse *all-failures*))
- (cond ((eq (car fail) :unhandled-error)
- (format t " ~20a ~a~%"
- "Unhandled error"
- (enough-namestring (second fail))))
- ((eq (car fail) :invalid-exit-status)
- (format t " ~20a ~a~%"
- "Invalid exit status:"
- (enough-namestring (second fail))))
- (t
- (format t " ~20a ~a / ~a~%"
- (ecase (first fail)
- (:expected-failure "Expected failure:")
- (:unexpected-failure "Failure:")
- (:unexpected-success "Unexpected success:"))
- (enough-namestring (second fail))
- (third fail))))))
- (t
- (format t "All tests succeeded~%"))))
+ (let ((skipcount 0))
+ (cond (*all-failures*
+ (format t "Status:~%")
+ (dolist (fail (reverse *all-failures*))
+ (cond ((eq (car fail) :unhandled-error)
+ (format t " ~20a ~a~%"
+ "Unhandled error"
+ (enough-namestring (second fail))))
+ ((eq (car fail) :invalid-exit-status)
+ (format t " ~20a ~a~%"
+ "Invalid exit status:"
+ (enough-namestring (second fail))))
+ ((eq (car fail) :skipped-disabled)
+ (incf skipcount))
+ (t
+ (format t " ~20a ~a / ~a~%"
+ (ecase (first fail)
+ (:expected-failure "Expected failure:")
+ (:unexpected-failure "Failure:")
+ (:unexpected-success "Unexpected success:")
+ (:skipped-broken "Skipped (broken):")
+ (:skipped-disabled "Skipped (irrelevant):"))
+ (enough-namestring (second fail))
+ (third fail)))))
+ (when (> skipcount 0)
+ (format t " (~a tests skipped for this combination of platform and features)~%"
+ skipcount)))
+ (t
+ (format t "All tests succeeded~%")))))
(defun pure-runner (files test-fun)
(format t "// Running pure tests (~a)~%" test-fun)
(defun unexpected-failures ()
(remove-if (lambda (x)
(or (eq (car x) :expected-failure)
- (eq (car x) :unexpected-success)))
+ (eq (car x) :unexpected-success)
+ (eq (car x) :skipped-broken)
+ (eq (car x) :skipped-disabled)))
*all-failures*))
(defun setup-cl-user ()
#-win32
(require :sb-posix)
-#-win32
-(with-test (:name :interrupt-open)
+(with-test (:name :interrupt-open :skipped-on :win32)
(let ((fifo nil)
(to 0))
(unwind-protect
#-win32
(require :sb-posix)
-#-win32
-(with-test (:name :overeager-character-buffering)
+(with-test (:name :overeager-character-buffering :skipped-on :win32)
(let ((fifo nil)
(proc nil))
(maphash
(terpri *trace-output*)
(force-output *trace-output*))
-(defmacro with-test ((&key fails-on name) &body body)
+(defmacro with-test ((&key fails-on broken-on skipped-on name) &body body)
(let ((block-name (gensym)))
- `(block ,block-name
- (handler-bind ((error (lambda (error)
- (if (expected-failure-p ,fails-on)
- (fail-test :expected-failure ',name error)
- (fail-test :unexpected-failure ',name error))
- (return-from ,block-name))))
- (progn
- (log-msg "Running ~S" ',name)
- (start-test)
- ,@body
- (if (expected-failure-p ,fails-on)
- (fail-test :unexpected-success ',name nil)
- (log-msg "Success ~S" ',name)))))))
+ `(cond
+ ((broken-p ,broken-on)
+ (fail-test :skipped-broken ',name "Test broken on this platform"))
+ ((skipped-p ,skipped-on)
+ (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
+ (t
+ (block ,block-name
+ (handler-bind ((error (lambda (error)
+ (if (expected-failure-p ,fails-on)
+ (fail-test :expected-failure ',name error)
+ (fail-test :unexpected-failure ',name error))
+ (return-from ,block-name))))
+ (progn
+ (log-msg "Running ~S" ',name)
+ (start-test)
+ ,@body
+ (if (expected-failure-p ,fails-on)
+ (fail-test :unexpected-success ',name nil)
+ (log-msg "Success ~S" ',name)))))))))
(defun report-test-status ()
(with-standard-io-syntax
(defun expected-failure-p (fails-on)
(sb-impl::featurep fails-on))
+(defun broken-p (broken-on)
+ (sb-impl::featurep broken-on))
+
+(defun skipped-p (skipped-on)
+ (sb-impl::featurep skipped-on))
+
(defun really-invoke-debugger (condition)
(with-simple-restart (continue "Continue")
(let ((*invoke-debugger-hook* *invoke-debugger-hook*))
;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
-#+sb-thread
(with-test (:name without-interrupts+condition-wait
- :fails-on :sb-lutex)
+ :fails-on :sb-lutex
+ :skipped-on '(not :sb-thread))
(let* ((lock (make-mutex))
(queue (make-waitqueue))
(thread (make-thread (lambda ()
;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
-#+sb-thread
-(with-test (:name without-interrupts+get-mutex)
+(with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread))
(let* ((lock (make-mutex))
(bar (progn (get-mutex lock) nil))
(thread (make-thread (lambda ()
(assert (eq :aborted (join-thread thread :default :aborted)))
(assert bar)))
-#+sb-thread
-(with-test (:name parallel-find-class)
+(with-test (:name parallel-find-class :skipped-on '(not :sb-thread))
(let* ((oops nil)
(threads (loop repeat 10
collect (make-thread (lambda ()
(mapcar #'sb-thread:join-thread threads)
(assert (not oops))))
-#+sb-thread
-(with-test (:name :semaphore-multiple-waiters)
+(with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
(let ((semaphore (make-semaphore :name "test sem")))
(labels ((make-readers (n i)
(values
;;;; Printing waitqueues
-#+sb-thread
-(with-test (:name :waitqueue-circle-print)
+(with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
(let* ((*print-circle* nil)
(lock (sb-thread:make-mutex))
(wq (sb-thread:make-waitqueue)))
(assert (= 123 (symbol-value-in-thread '* *current-thread*)))
(assert (= 123 *))))
-#+sb-thread
-(with-test (:name symbol-value-in-thread.2)
+(with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(child (make-thread (lambda ()
;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
;;; interrupted malloc in one thread can apparently block a free in another. There
;;; are also some indications that pthread_mutex_lock is not re-entrant.
-#+(and sb-thread (not darwin))
-(with-test (:name symbol-value-in-thread.3)
+(with-test (:name symbol-value-in-thread.3 :skipped-on '(not :sb-thread) :broken-on :darwin)
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(running t)
(setf running nil)
(join-thread noise)))
-#+sb-thread
-(with-test (:name symbol-value-in-thread.4)
+(with-test (:name symbol-value-in-thread.4 :skipped-on '(not :sb-thread))
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(child (make-thread (lambda ()
(signal-semaphore semaphore)
(assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
-#+sb-thread
-(with-test (:name symbol-value-in-thread.5)
+(with-test (:name symbol-value-in-thread.5 :skipped-on '(not :sb-thread))
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(child (make-thread (lambda ()
(assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
(join-thread child)))))
-#+sb-thread
-(with-test (:name symbol-value-in-thread.6)
+(with-test (:name symbol-value-in-thread.6 :skipped-on '(not :sb-thread))
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(name (gensym))
(unless (equal res want)
(error "wanted ~S, got ~S" want res)))))
-#+sb-thread
-(with-test (:name symbol-value-in-thread.7)
+(with-test (:name symbol-value-in-thread.7 :skipped-on '(not :sb-thread))
(let ((child (make-thread (lambda ())))
(error-occurred nil))
(join-thread child)
(sb-thread::symbol-value-in-thread-error-info e)))))
(assert error-occurred)))
-#+sb-thread
-(with-test (:name symbol-value-in-thread.8)
+(with-test (:name symbol-value-in-thread.8 :skipped-on '(not :sb-thread))
(let ((child (make-thread (lambda ())))
(error-occurred nil))
(join-thread child)
(sb-thread::symbol-value-in-thread-error-info e)))))
(assert error-occurred)))
-#+sb-thread
-(with-test (:name deadlock-detection.1)
+(with-test (:name deadlock-detection.1 :skipped-on '(not :sb-thread))
(loop
repeat 1000
do (flet ((test (ma mb sa sb)
(equal '(:ok :deadlock) res)
(equal '(:deadlock :deadlock) res))))))))
-#+sb-thread
-(with-test (:name deadlock-detection.2)
+(with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread))
(let* ((m1 (sb-thread:make-mutex :name "M1"))
(m2 (sb-thread:make-mutex :name "M2"))
(s1 (sb-thread:make-semaphore :name "S1"))
(assert (stringp err)))
(assert (eq :ok (sb-thread:join-thread t1)))))
-#+sb-thread
-(with-test (:name deadlock-detection.3)
+(with-test (:name deadlock-detection.3 :skipped-on '(not :sb-thread))
(let* ((m1 (sb-thread:make-mutex :name "M1"))
(m2 (sb-thread:make-mutex :name "M2"))
(s1 (sb-thread:make-semaphore :name "S1"))
:deadlock))))
(assert (eq :ok (join-thread t1)))))
-#+sb-thread
-(with-test (:name deadlock-detection.4)
+(with-test (:name deadlock-detection.4 :skipped-on '(not :sb-thread))
(loop
repeat 1000
do (flet ((test (ma mb sa sb)
(equal '(:ok :deadlock) res)
(equal '(:deadlock :deadlock) res))))))))
-#+sb-thread
-(with-test (:name deadlock-detection.5)
+(with-test (:name deadlock-detection.5 :skipped-on '(not :sb-thread))
(let* ((m1 (sb-thread::make-spinlock :name "M1"))
(m2 (sb-thread::make-spinlock :name "M2"))
(s1 (sb-thread:make-semaphore :name "S1"))
(assert (stringp err)))
(assert (eq :ok (sb-thread:join-thread t1)))))
-#+sb-thread
-(with-test (:name deadlock-detection.7)
+(with-test (:name deadlock-detection.7 :skipped-on '(not :sb-thread))
(let* ((m1 (sb-thread::make-spinlock :name "M1"))
(m2 (sb-thread::make-spinlock :name "M2"))
(s1 (sb-thread:make-semaphore :name "S1"))
time)
(loop until finishedp)))
-#-win32
-(with-test (:name (:timer :deferrables-blocked))
+(with-test (:name (:timer :deferrables-blocked) :skipped-on :win32)
(make-and-schedule-and-wait (lambda ()
(check-deferrables-blocked-or-lose 0))
(random 0.1))
(check-deferrables-unblocked-or-lose 0))
-#-win32
-(with-test (:name (:timer :deferrables-unblocked))
+(with-test (:name (:timer :deferrables-unblocked) :skipped-on :win32)
(make-and-schedule-and-wait (lambda ()
(sb-sys:with-interrupts
(check-deferrables-unblocked-or-lose 0)))
(random 0.1))
(check-deferrables-unblocked-or-lose 0))
-#-win32
-(with-test (:name (:timer :deferrables-unblocked :unwind))
+(with-test (:name (:timer :deferrables-unblocked :unwind) :skipped-on :win32)
(catch 'xxx
(make-and-schedule-and-wait (lambda ()
(check-deferrables-blocked-or-lose 0)
`(handler-case (progn (progn ,@body) nil)
(sb-ext:timeout () t)))
-#-win32
(with-test (:name (:timer :relative)
- :fails-on '(and :sparc :linux))
+ :fails-on '(and :sparc :linux)
+ :skipped-on :win32)
(let* ((has-run-p nil)
(timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
(with-test (:name (:timer :absolute)
- :fails-on '(and :sparc :linux))
+ :fails-on '(and :sparc :linux)
+ :skipped-on :win32)
(let* ((has-run-p nil)
(timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#+sb-thread
-(with-test (:name (:timer :other-thread))
+(with-test (:name (:timer :other-thread) :skipped-on '(not :sb-thread))
(let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
(timer (make-timer (lambda ()
(assert (eq thread sb-thread:*current-thread*)))
:thread thread)))
(schedule-timer timer 0.1)))
-#+sb-thread
-(with-test (:name (:timer :new-thread))
+(with-test (:name (:timer :new-thread) :skipped-on '(not :sb-thread))
(let* ((original-thread sb-thread:*current-thread*)
(timer (make-timer
(lambda ()
:thread t)))
(schedule-timer timer 0.1)))
-#-win32
(with-test (:name (:timer :repeat-and-unschedule)
- :fails-on '(and :sparc :linux))
+ :fails-on '(and :sparc :linux)
+ :skipped-on :win32)
(let* ((run-count 0)
timer)
(setq timer
(assert (not (timer-scheduled-p timer)))
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:timer :reschedule))
+(with-test (:name (:timer :reschedule) :skipped-on :win32)
(let* ((has-run-p nil)
(timer (make-timer (lambda ()
(setq has-run-p t)))))
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:timer :stress))
+(with-test (:name (:timer :stress) :skipped-on :win32)
(let ((time (1+ (get-universal-time))))
(loop repeat 200 do
(schedule-timer (make-timer (lambda ())) time :absolute-p t))
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:timer :stress2))
+(with-test (:name (:timer :stress2) :skipped-on :win32)
(let ((time (1+ (get-universal-time)))
(n 0))
(loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:with-timeout :timeout))
+(with-test (:name (:with-timeout :timeout) :skipped-on :win32)
(assert (raises-timeout-p
(sb-ext:with-timeout 0.2
(sleep 1)))))
-#-win32
-(with-test (:name (:with-timeout :fall-through))
+(with-test (:name (:with-timeout :fall-through) :skipped-on :win32)
(assert (not (raises-timeout-p
(sb-ext:with-timeout 0.3
(sleep 0.1))))))
-#-win32
-(with-test (:name (:with-timeout :nested-timeout-smaller))
+(with-test (:name (:with-timeout :nested-timeout-smaller) :skipped-on :win32)
(assert(raises-timeout-p
(sb-ext:with-timeout 10
(sb-ext:with-timeout 0.5
(sleep 2))))))
-#-win32
-(with-test (:name (:with-timeout :nested-timeout-bigger))
+(with-test (:name (:with-timeout :nested-timeout-bigger) :skipped-on :win32)
(assert(raises-timeout-p
(sb-ext:with-timeout 0.5
(sb-ext:with-timeout 2
(defun wait-for-threads (threads)
(loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
-#+sb-thread
-(with-test (:name (:with-timeout :many-at-the-same-time))
+(with-test (:name (:with-timeout :many-at-the-same-time) :skipped-on '(not :sb-thread))
(let ((ok t))
(let ((threads (loop repeat 10 collect
(sb-thread:make-thread
(wait-for-threads threads)))))
(assert ok))))
-#+sb-thread
-(with-test (:name (:with-timeout :dead-thread))
+(with-test (:name (:with-timeout :dead-thread) :skipped-on '(not :sb-thread))
(sb-thread:make-thread
(lambda ()
(let ((timer (make-timer (lambda ()))))
;;; FIXME: Since timeouts do not work on Windows this would loop
;;; forever.
-#-win32
-(with-test (:name (:hash-cache :interrupt))
+(with-test (:name (:hash-cache :interrupt) :skipped-on :win32)
(let* ((type1 (random-type 500))
(type2 (random-type 500))
(wanted (subtypep type1 type2)))
;;; Used to hang occasionally at least on x86. Two bugs caused it:
;;; running out of stack (due to repeating timers being rescheduled
;;; before they ran) and dying threads were open interrupts.
-#+sb-thread
-(with-test (:name (:timer :parallel-unschedule) :fails-on :ppc)
- #+darwin
- (error "Prone to hang on Darwin due to interrupt issues.")
- #+ppc
- (error "Prone to hang the host on linux/ppc for unknown reasons.")
+(with-test (:name (:timer :parallel-unschedule) :fails-on :ppc :skipped-on '(not :sb-thread) :broken-on '(or :darwin :ppc))
(let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
(other nil))
(flet ((flop ()
;;;;
;;;; Used to have problems in genereal, see comment on (:TIMER
;;;; :PARALLEL-UNSCHEDULE).
-#-win32
-(with-test (:name (:timer :schedule-stress))
+(with-test (:name (:timer :schedule-stress) :skipped-on :win32)
(flet ((test ()
(let* ((slow-timers
(loop for i from 1 upto 1
#-sb-thread
(loop repeat 10 do (test))))
-#+sb-thread
-(with-test (:name (:timer :threaded-stress))
+(with-test (:name (:timer :threaded-stress) :skipped-on '(not :sb-thread))
(let ((barrier (sb-thread:make-semaphore))
(goal 100))
(flet ((wait-for-goal ()
;;; go away.
(import 'sb-alien::alien-lambda)
+;;; XXX XXX this should change to use run-compiler.sh, now that we have it
(defun run-compiler ()
(let ((proc (run-program "gcc" '("win32-stack-unwind.c"
"-mno-cygwin" "-shared"
projects / sbcl.git / commitdiff