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.

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index f97e73c..c235b63 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -264,8 +264,7 @@
     ((foo (unsigned 32)))
   foo)
 
     ((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
   ;; 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 (file)
--- a/tests/deadline.impure.lisp
+++ b/tests/deadline.impure.lisp
@@ -65,55 +65,52 @@
     (assert (= n 1))
     (assert (not final))))
 
     (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-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 (file)
--- 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
   (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 ?)))))
   (with-details t
     (assert (verify-backtrace #'namestring
                               '(((sb-c::tl-xep namestring) 0 ?)))))

@@ -273,8 +272,7 @@
     (assert (verify-backtrace #'namestring
                               '((namestring))))))
 
     (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))))
   (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))))))
 
     (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 ?))))
   (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))))))
 
     (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))))
   (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))))))
 
     (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) ?))))
   (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))))))
 
 
                               '((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)))))
   (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.
 ;;; 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)
 (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)))
   (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))))
 
     (assert (search "TRACE-THIS" out))
     (assert (search "returned OK" out))))
 

-#-(and (or ppc x86 x86-64) darwin)

 (with-test (:name (trace-recursive :encapsulate nil)
 (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)))
   (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 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -499,12 +499,10 @@
 
 (defvar *a-cons* (cons nil nil))
 
 
 (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)))
 
   (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))
   (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)))
 
 (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 (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)))
 
   (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 (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)))
 
   (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)))
   (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-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)))
 
   (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
   (assert-no-consing (test-spinlock)))
 
 \f

diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp
index fc8ec40..6afd64c 100644 (file)
--- a/tests/eval.impure.lisp
+++ b/tests/eval.impure.lisp
@@ -249,8 +249,7 @@
               (simple-type-error () 'error)))
       t)))
 
               (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)))
   (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 (file)
--- a/tests/exhaust.impure.lisp
+++ b/tests/exhaust.impure.lisp
@@ -84,8 +84,7 @@
           (setq ok t)))
       (assert ok))))
 
           (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)))
   (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 (file)
--- a/tests/float.pure.lisp
+++ b/tests/float.pure.lisp
@@ -245,9 +245,10 @@
                                        (the (eql #c(1.0 2.0))
                                          x))))))))
 
                                        (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)))
 (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.
 ;; 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."
 (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)))))))
                         (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))
     (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))))))
 
       (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))
     (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))))))
 
       (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))
     (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))))))
 
       (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))
     (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))))))
 
       (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))
     (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))))))
 
       (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))
     (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 (file)
--- 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
     (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).
   ;; 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 (file)
--- 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.
 
 ;;; 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)
 (progn
 
 (defparameter *ht* nil)

@@ -292,7 +291,7 @@
        (sb-thread::wait-on-semaphore ,sem)
        (values-list ,values))))
 
        (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
   (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))
 
   (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)
   (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))))))
 
                           (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)
   (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 ...
     (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)))
   (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
               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 ()))
   (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 (file)
--- 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")))
 
   (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)))
 
   (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)
   (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 (file)
--- 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.
 
 ;;; 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
   (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))
 ;;; 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 (file)
--- 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)))
 
 (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= "?{?"
   (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)))))
 
                       (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 #\?))))))
   (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)))))
 
   (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))
   (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)))))
 
                                       :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)))
   (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))))))
 
                                       :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)
   (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)))))
           (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)
   (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))))))
 
     (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)
   (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)))))
           (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)
   (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))))))
 
     (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)
   (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)))))
           (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)
   (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))))))
 
     (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)
   (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)))))
           (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)
   (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 (file)
--- 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
                   :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 ()
   (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 (file)
--- 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).
 ;;; 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\"\\\\\\\\\""))))
 
   (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 (file)
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -402,12 +402,10 @@
       (ignore-errors
         (delete-file file)))))
 
       (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))
 
   (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"))
   (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 (file)
--- a/tests/run-program.impure.lisp
+++ b/tests/run-program.impure.lisp
@@ -31,8 +31,7 @@
               (assert (= (read-byte in) i)))
       (process-close process))))
 
               (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
   ;; 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 (file)
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -41,27 +41,35 @@
 (defun report ()
   (terpri)
   (format t "Finished running tests.~%")
 (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 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)
 (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 ()
              *all-failures*))
 
 (defun setup-cl-user ()

diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index 0071bcc..6f2e0f4 100644 (file)
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -610,8 +610,7 @@
 #-win32
 (require :sb-posix)
 
 #-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
   (let ((fifo nil)
         (to 0))
     (unwind-protect

@@ -641,8 +640,7 @@
 
 #-win32
 (require :sb-posix)
 
 #-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
   (let ((fifo nil)
         (proc nil))
     (maphash

diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index cdc422c..dbd66a7 100644 (file)
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -18,21 +18,27 @@
   (terpri *trace-output*)
   (force-output *trace-output*))
 
   (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)))
   (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 report-test-status ()
   (with-standard-io-syntax

@@ -60,6 +66,12 @@
 (defun expected-failure-p (fails-on)
   (sb-impl::featurep fails-on))
 
 (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*))
 (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 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -51,9 +51,9 @@
 
 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
 
 
 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
 

-#+sb-thread

 (with-test (:name without-interrupts+condition-wait
 (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 ()
   (let* ((lock (make-mutex))
          (queue (make-waitqueue))
          (thread (make-thread (lambda ()

@@ -71,8 +71,7 @@
 
 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
 
 
 ;;; 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 ()
   (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)))
 
     (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 ()
   (let* ((oops nil)
          (threads (loop repeat 10
                         collect (make-thread (lambda ()

@@ -103,8 +101,7 @@
     (mapcar #'sb-thread:join-thread threads)
     (assert (not oops))))
 
     (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
   (let ((semaphore (make-semaphore :name "test sem")))
     (labels ((make-readers (n i)
                (values

@@ -159,8 +156,7 @@
 
 ;;;; Printing waitqueues
 
 
 ;;;; 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)))
   (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 *))))
 
     (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 ()
   (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.
 ;;; 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)
   (let* ((parent *current-thread*)
          (semaphore (make-semaphore))
          (running t)

@@ -230,8 +224,7 @@
     (setf running nil)
     (join-thread noise)))
 
     (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 ()
   (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))))))
 
     (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 ()
   (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)))))
 
     (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))
   (let* ((parent *current-thread*)
          (semaphore (make-semaphore))
          (name (gensym))

@@ -275,8 +266,7 @@
       (unless (equal res want)
         (error "wanted ~S, got ~S" want res)))))
 
       (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)
   (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::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)
   (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::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)
   (loop
     repeat 1000
     do (flet ((test (ma mb sa sb)

@@ -335,8 +323,7 @@
                          (equal '(:ok :deadlock) res)
                          (equal '(:deadlock :deadlock) res))))))))
 
                          (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"))
   (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)))))
 
        (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"))
   (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)))))
 
                     :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)
   (loop
     repeat 1000
     do (flet ((test (ma mb sa sb)

@@ -434,8 +419,7 @@
                          (equal '(:ok :deadlock) res)
                          (equal '(:deadlock :deadlock) res))))))))
 
                          (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"))
   (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)))))
 
        (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"))
   (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 (file)
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -61,23 +61,20 @@
                            time)
     (loop until finishedp)))
 
                            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))
 
   (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))
 
   (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)
   (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)))
 
   `(handler-case (progn (progn ,@body) nil)
     (sb-ext:timeout () t)))
 

-#-win32

 (with-test (:name (:timer :relative)
 (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")))
   (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*))))))
 
     (assert has-run-p)
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 

-#-win32

 (with-test (:name (:timer :absolute)
 (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")))
   (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*))))))
 
     (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)))
 
   (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 ()
   (let* ((original-thread sb-thread:*current-thread*)
          (timer (make-timer
                  (lambda ()

@@ -134,9 +129,9 @@
                  :thread t)))
     (schedule-timer timer 0.1)))
 
                  :thread t)))
     (schedule-timer timer 0.1)))
 

-#-win32

 (with-test (:name (:timer :repeat-and-unschedule)
 (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
   (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*))))))
 
     (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)))))
   (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*))))))
 
     (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*))))))
 
   (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)
   (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*))))))
 
     (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)))))
 
   (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))))))
 
   (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))))))
 
   (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
   (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)))
 
 (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
   (let ((ok t))
     (let ((threads (loop repeat 10 collect
                          (sb-thread:make-thread

@@ -226,8 +213,7 @@
                       (wait-for-threads threads)))))
       (assert ok))))
 
                       (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 ()))))
   (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.
 
 ;;; 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)))
   (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.
 ;;; 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 ()
   (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).
 ;;;;
 ;;;; 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
   (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
   (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 ()
   (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 (executable)
--- 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)
 
 ;;; 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"
 (defun run-compiler ()
   (let ((proc (run-program "gcc" '("win32-stack-unwind.c"
                                    "-mno-cygwin" "-shared"