1.0.2.11:

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

diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index d07a7a0..a2028b8 100644 (file)
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -13,11 +13,15 @@
 
 (use-package :test-util)
 
+(defmacro raises-timeout-p (&body body)
+  `(handler-case (progn (progn ,@body) nil)
+    (sb-ext:timeout () t)))
+
 (with-test (:name (:timer :relative))
   (let* ((has-run-p nil)
-         (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+         (timer (make-timer (lambda () (setq has-run-p t))
                             :name "simple timer")))
-    (sb-impl::schedule-timer timer 0.5)
+    (schedule-timer timer 0.5)
     (sleep 0.2)
     (assert (not has-run-p))
     (sleep 0.5)
@@ -26,50 +30,53 @@
 
 (with-test (:name (:timer :absolute))
   (let* ((has-run-p nil)
-         (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+         (timer (make-timer (lambda () (setq has-run-p t))
                             :name "simple timer")))
-    (sb-impl::schedule-timer timer (+ 1/2 (get-universal-time))
-                             :absolute-p t)
+    (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
     (sleep 0.2)
     (assert (not has-run-p))
     (sleep 0.5)
     (assert has-run-p)
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 
-(defvar *x* nil)
-
 #+sb-thread
 (with-test (:name (:timer :other-thread))
-  (let* ((thread (sb-thread:make-thread (lambda () (let ((*x* t)) (sleep 2)))))
-         (timer (sb-impl::make-timer (lambda () (assert *x*)) :thread thread)))
-    (sb-impl::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))
-  (let ((*x* t)
-        (timer (sb-impl::make-timer (lambda () (assert (not *x*))) :thread t)))
-    (sb-impl::schedule-timer timer 0.1)))
+  (let* ((original-thread sb-thread:*current-thread*)
+         (timer (make-timer
+                 (lambda ()
+                   (assert (not (eq original-thread
+                                    sb-thread:*current-thread*))))
+                 :thread t)))
+    (schedule-timer timer 0.1)))
 
 (with-test (:name (:timer :repeat-and-unschedule))
   (let* ((run-count 0)
          timer)
     (setq timer
-          (sb-impl::make-timer (lambda ()
+          (make-timer (lambda ()
                         (when (= 5 (incf run-count))
-                          (sb-impl::unschedule-timer timer)))))
-    (sb-impl::schedule-timer timer 0 :repeat-interval 0.2)
-    (assert (not (sb-impl::timer-expired-p timer 0.3)))
+                          (unschedule-timer timer)))))
+    (schedule-timer timer 0 :repeat-interval 0.2)
+    (assert (timer-scheduled-p timer :delta 0.3))
     (sleep 1.3)
     (assert (= 5 run-count))
-    (assert (sb-impl::timer-expired-p timer))
+    (assert (not (timer-scheduled-p timer)))
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 
 (with-test (:name (:timer :reschedule))
   (let* ((has-run-p nil)
-         (timer (sb-impl::make-timer (lambda ()
+         (timer (make-timer (lambda ()
                               (setq has-run-p t)))))
-    (sb-impl::schedule-timer timer 0.2)
-    (sb-impl::schedule-timer timer 0.3)
+    (schedule-timer timer 0.2)
+    (schedule-timer timer 0.3)
     (sleep 0.5)
     (assert has-run-p)
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
@@ -77,15 +84,10 @@
 (with-test (:name (:timer :stress))
   (let ((time (1+ (get-universal-time))))
     (loop repeat 200 do
-          (sb-impl::schedule-timer (sb-impl::make-timer (lambda ())) time
-                                   :absolute-p t))
+          (schedule-timer (make-timer (lambda ())) time :absolute-p t))
     (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
@@ -107,3 +109,55 @@
           (sb-ext:with-timeout 0.5
             (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))
+  (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))))))))