1.0.13.18: Revived OpenBSD support, contributed by Josh Elsasser

[sbcl.git] / tests / timer.impure.lisp

diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index 220c659..0c8bca3 100644 (file)
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -17,7 +17,8 @@
   `(handler-case (progn (progn ,@body) nil)
     (sb-ext:timeout () t)))
 
-(with-test (:name (:timer :relative))
+(with-test (:name (:timer :relative)
+            :fails-on '(and :sparc :linux))
   (let* ((has-run-p nil)
          (timer (make-timer (lambda () (setq has-run-p t))
                             :name "simple timer")))
@@ -28,7 +29,8 @@
     (assert has-run-p)
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 
-(with-test (:name (:timer :absolute))
+(with-test (:name (:timer :absolute)
+            :fails-on '(and :sparc :linux))
   (let* ((has-run-p nil)
          (timer (make-timer (lambda () (setq has-run-p t))
                             :name "simple timer")))
@@ -57,7 +59,8 @@
                  :thread t)))
     (schedule-timer timer 0.1)))
 
-(with-test (:name (:timer :repeat-and-unschedule))
+(with-test (:name (:timer :repeat-and-unschedule)
+            :fails-on '(and :sparc :linux))
   (let* ((run-count 0)
          timer)
     (setq timer
@@ -140,3 +143,24 @@
        (assert t))))
   (sleep 6)
   (assert t))
+
+
+(defun random-type (n)
+  `(integer ,(random n) ,(+ n (random n))))
+
+;;; FIXME: Since timeouts do not work on Windows this would loop
+;;; forever.
+#-win32
+(with-test (:name '(:hash-cache :interrupt))
+  (let* ((type1 (random-type 500))
+         (type2 (random-type 500))
+         (wanted (subtypep type1 type2)))
+    (dotimes (i 100)
+      (block foo
+        (sb-ext:schedule-timer (sb-ext:make-timer
+                                (lambda ()
+                                  (assert (eq wanted (subtypep type1 type2)))
+                                    (return-from foo)))
+                               0.05)
+        (loop
+           (assert (eq wanted (subtypep type1 type2))))))))