From 4c81c652cdc32faefee1bccb84c3c9a7854e3edd Mon Sep 17 00:00:00 2001 From: Jim Wise Date: Mon, 6 Jun 2011 13:22:34 -0400 Subject: [PATCH] Rework test infrastructure to keep track of tests which are disabled on the platform/feature combination being tested, and to differentiate between tests disabled because the test is broken in some way, and those skipped because the platform in question is broken in some way (or the test is irrelevant for the given feature set). This takes the form of two new keywords to WITH-TEST -- :BROKEN-ON, which notes that the test itself is broken for a given feature expression, or :SKIPPED-ON, which skips a test for a given feature expression. This information is noted at the end of a test run like so: Finished running tests. Status: Skipped (broken): debug.impure.lisp / (TRACE ENCAPSULATE NIL) Skipped (broken): debug.impure.lisp / (TRACE-RECURSIVE ENCAPSULATE NIL) Expected failure: packages.impure.lisp / USE-PACKAGE-CONFLICT-SET Expected failure: packages.impure.lisp / IMPORT-SINGLE-CONFLICT (38 tests skipped for this combination of platform and features) ok //apparent success (reached end of run-tests.sh normally) Thu Jun 2 15:59:31 EDT 2011 Note that there is no :WORKS-ON or :ENABLED-ON, even though many of the read-time conditionals this replaced were for a given feature instead of for its absence -- you can still do, eg: (with-test (:name foo :broken-on '(not :x86)) ...) but such declarations are almost always too general (one exception being `:skipped-on '(not :sb-thread)'), and IMO, should be discouraged. While here, re-enable a bunch of tests previously skipped on Solaris which now work. --- tests/alien.impure.lisp | 3 +- tests/deadline.impure.lisp | 95 +++++++++++++------------- tests/debug.impure.lisp | 26 +++---- tests/dynamic-extent.impure.lisp | 21 ++---- tests/eval.impure.lisp | 3 +- tests/exhaust.impure.lisp | 3 +- tests/float.pure.lisp | 22 +++--- tests/gc.impure.lisp | 3 +- tests/hash.impure.lisp | 11 ++- tests/interface.impure.lisp | 6 +- tests/interface.pure.lisp | 5 +- tests/octets.pure.lisp | 45 ++++++------ tests/packages.impure.lisp | 3 +- tests/pathnames.impure.lisp | 3 +- tests/print.impure.lisp | 6 +- tests/run-program.impure.lisp | 3 +- tests/run-tests.lisp | 54 +++++++++------ tests/stream.impure.lisp | 6 +- tests/test-util.lisp | 40 +++++++---- tests/threads.pure.lisp | 55 ++++++--------- tests/timer.impure.lisp | 70 +++++++------------ tests/win32-foreign-stack-unwind.impure.lisp | 1 + 22 files changed, 216 insertions(+), 268 deletions(-) diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index f97e73c..c235b63 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -264,8 +264,7 @@ ((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 diff --git a/tests/deadline.impure.lisp b/tests/deadline.impure.lisp index e4b077e..88171e0 100644 --- a/tests/deadline.impure.lisp +++ b/tests/deadline.impure.lisp @@ -65,55 +65,52 @@ (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)))))) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 620d032..df70a78 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -264,8 +264,7 @@ (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 ?))))) @@ -273,8 +272,7 @@ (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)))) @@ -290,8 +288,7 @@ (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 ?)))) @@ -307,8 +304,7 @@ (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)))) @@ -324,8 +320,7 @@ (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) ?)))) @@ -342,8 +337,7 @@ '((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))))) @@ -434,9 +428,9 @@ ;;; 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))) @@ -444,9 +438,9 @@ (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))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 16aa5e9..76d2cf8 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -499,12 +499,10 @@ (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)) @@ -520,8 +518,7 @@ (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)) @@ -529,8 +526,7 @@ (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))) @@ -539,8 +535,7 @@ (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))) @@ -574,12 +569,10 @@ (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))) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index fc8ec40..6afd64c 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -249,8 +249,7 @@ (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))) diff --git a/tests/exhaust.impure.lisp b/tests/exhaust.impure.lisp index ef21e7c..4b8cd72 100644 --- a/tests/exhaust.impure.lisp +++ b/tests/exhaust.impure.lisp @@ -84,8 +84,7 @@ (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))) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 289360f..7b9502c 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -245,9 +245,10 @@ (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))) @@ -288,7 +289,8 @@ ;; 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." @@ -313,7 +315,7 @@ (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)) @@ -323,7 +325,7 @@ (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)) @@ -333,7 +335,7 @@ (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)) @@ -343,7 +345,7 @@ (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)) @@ -353,7 +355,7 @@ (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)) @@ -362,7 +364,7 @@ (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)) diff --git a/tests/gc.impure.lisp b/tests/gc.impure.lisp index fbe284b..a5e9bfb 100644 --- a/tests/gc.impure.lisp +++ b/tests/gc.impure.lisp @@ -53,8 +53,7 @@ (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). diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index 119c9f1..40dc9df 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -261,7 +261,6 @@ ;;; 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) @@ -292,7 +291,7 @@ (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 @@ -331,7 +330,7 @@ (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) @@ -358,7 +357,7 @@ (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) @@ -366,7 +365,7 @@ (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))) @@ -377,7 +376,7 @@ 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 ())) diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index cbb9ae3..2de5766 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -239,12 +239,10 @@ (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) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index 81a987b..7c600c6 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -65,8 +65,7 @@ ;;; 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 @@ -116,4 +115,4 @@ ;;; 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)) diff --git a/tests/octets.pure.lisp b/tests/octets.pure.lisp index d40b260..e78e2db 100644 --- a/tests/octets.pure.lisp +++ b/tests/octets.pure.lisp @@ -260,8 +260,7 @@ (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= "?{?" @@ -269,23 +268,20 @@ (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)) @@ -297,8 +293,7 @@ :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))) @@ -316,8 +311,7 @@ :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) @@ -328,8 +322,8 @@ (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) @@ -338,8 +332,7 @@ (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) @@ -350,8 +343,8 @@ (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) @@ -360,8 +353,8 @@ (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) @@ -372,8 +365,8 @@ (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) @@ -382,8 +375,8 @@ (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) @@ -394,8 +387,8 @@ (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) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 3b5273e..96431a5 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -290,8 +290,7 @@ if a restart was invoked." :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 () diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 7246924..1c705a8 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -531,8 +531,7 @@ ;;; 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\"\\\\\\\\\"")))) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 9b4f13d..e17492d 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -402,12 +402,10 @@ (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")) diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp index e62eb95..098c74d 100644 --- a/tests/run-program.impure.lisp +++ b/tests/run-program.impure.lisp @@ -31,8 +31,7 @@ (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 diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index 8cb583f..92808c0 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -41,27 +41,35 @@ (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) @@ -165,7 +173,9 @@ (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 () diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index 0071bcc..6f2e0f4 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -610,8 +610,7 @@ #-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 @@ -641,8 +640,7 @@ #-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 diff --git a/tests/test-util.lisp b/tests/test-util.lisp index cdc422c..dbd66a7 100644 --- a/tests/test-util.lisp +++ b/tests/test-util.lisp @@ -18,21 +18,27 @@ (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 @@ -60,6 +66,12 @@ (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*)) diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 9b6e91e..26c70f1 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -51,9 +51,9 @@ ;;; 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 () @@ -71,8 +71,7 @@ ;;; 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 () @@ -90,8 +89,7 @@ (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 () @@ -103,8 +101,7 @@ (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 @@ -159,8 +156,7 @@ ;;;; 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))) @@ -178,8 +174,7 @@ (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 () @@ -196,8 +191,7 @@ ;;; 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) @@ -230,8 +224,7 @@ (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 () @@ -240,8 +233,7 @@ (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 () @@ -256,8 +248,7 @@ (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)) @@ -275,8 +266,7 @@ (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) @@ -290,8 +280,7 @@ (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) @@ -305,8 +294,7 @@ (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) @@ -335,8 +323,7 @@ (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")) @@ -371,8 +358,7 @@ (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")) @@ -404,8 +390,7 @@ :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) @@ -434,8 +419,7 @@ (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")) @@ -470,8 +454,7 @@ (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")) diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp index 457bfd2..bca8805 100644 --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp @@ -61,23 +61,20 @@ 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) @@ -90,9 +87,9 @@ `(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"))) @@ -103,9 +100,9 @@ (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"))) @@ -116,16 +113,14 @@ (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 () @@ -134,9 +129,9 @@ :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 @@ -150,8 +145,7 @@ (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))))) @@ -161,16 +155,14 @@ (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) @@ -179,27 +171,23 @@ (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 @@ -208,8 +196,7 @@ (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 @@ -226,8 +213,7 @@ (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 ())))) @@ -242,8 +228,7 @@ ;;; 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))) @@ -260,12 +245,7 @@ ;;; 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 () @@ -292,8 +272,7 @@ ;;;; ;;;; 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 @@ -316,8 +295,7 @@ #-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 () diff --git a/tests/win32-foreign-stack-unwind.impure.lisp b/tests/win32-foreign-stack-unwind.impure.lisp index 18f6230..43c2a3b 100755 --- a/tests/win32-foreign-stack-unwind.impure.lisp +++ b/tests/win32-foreign-stack-unwind.impure.lisp @@ -19,6 +19,7 @@ ;;; 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" -- 1.7.10.4