X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftimer.impure.lisp;h=0c8bca3bb0fccfa5e3c487f50177453b2e026ebc;hb=71938e4be658b01c6aba3db5428a7ddce0dd48a2;hp=bfdcb78c2f61750e787b840539536487c2d52aca;hpb=d27e4848d1b93cb08de9cb02d82e4ce5d0663c68;p=sbcl.git

diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index bfdcb78..0c8bca3 100644
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -13,7 +13,12 @@
 
 (use-package :test-util)
 
-(with-test (:name (:timer :relative))
+(defmacro raises-timeout-p (&body body)
+  `(handler-case (progn (progn ,@body) nil)
+    (sb-ext:timeout () t)))
+
+(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")))
@@ -24,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")))
@@ -53,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
@@ -84,10 +91,6 @@
     (sleep 2)
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 
-(defmacro raises-timeout-p (&body body)
-  `(handler-case (progn (progn ,@body) nil)
-    (sb-ext:timeout () t)))
-
 (with-test (:name (:with-timeout :timeout))
   (assert (raises-timeout-p
            (sb-ext:with-timeout 0.2
@@ -110,11 +113,54 @@
             (sb-ext:with-timeout 2
               (sleep 2))))))
 
+(defun wait-for-threads (threads)
+  (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+
 #+sb-thread
 (with-test (:name (:with-timeout :many-at-the-same-time))
-  (loop repeat 10 do
-        (sb-thread:make-thread
-         (lambda ()
-           (sb-ext:with-timeout 0.5
-             (sleep 5)
-             (assert nil))))))
+  (let ((ok t))
+    (let ((threads (loop repeat 10 collect
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (handler-case
+                                (sb-ext:with-timeout 0.5
+                                  (sleep 5)
+                                  (setf ok nil)
+                                  (format t "~%not ok~%"))
+                              (timeout ()
+                                )))))))
+      (assert (not (raises-timeout-p
+                    (sb-ext:with-timeout 20
+                      (wait-for-threads threads)))))
+      (assert ok))))
+
+#+sb-thread
+(with-test (:name (:with-timeout :dead-thread))
+  (sb-thread:make-thread
+   (lambda ()
+     (let ((timer (make-timer (lambda ()))))
+       (schedule-timer timer 3)
+       (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))))))))