tests/deadline.impure.lisp

   1 (defmacro assert-timeout (form)
   2   (let ((ok (gensym "OK")))
   3     `(let ((,ok ',ok))
   4        (unless (eq ,ok
   5                    (handler-case ,form
   6                      (timeout ()
   7                        ,ok)))
   8          (error "No timeout from form:~%  ~S" ',form)))))
   9
  10
  11 (assert-timeout
  12  (sb-sys:with-deadline (:seconds 1)
  13    (run-program "sleep" '("3") :search t :wait t)))
  14
  15 (let ((n 0)
  16       (final nil))
  17   (handler-case
  18       (handler-bind ((sb-sys:deadline-timeout (lambda (c)
  19                                                 (when (< n 2)
  20                                                   (incf n)
  21                                                   (sb-sys:defer-deadline 0.1 c)))))
  22         (sb-sys:with-deadline (:seconds 1)
  23           (run-program "sleep" '("2") :search t :wait t)))
  24     (sb-sys:deadline-timeout (c)
  25       (setf final c)))
  26   (assert (= n 2))
  27   (assert final))
  28
  29 (let ((n 0)
  30       (final nil))
  31   (handler-case
  32       (handler-bind ((sb-sys:deadline-timeout (lambda (c)
  33                                                 (incf n)
  34                                                 (sb-sys:defer-deadline 0.1 c))))
  35         (sb-sys:with-deadline (:seconds 1)
  36           (run-program "sleep" '("2") :search t :wait t)))
  37     (sb-sys:deadline-timeout (c)
  38       (setf final c)))
  39   (assert (plusp n))
  40   (assert (not final)))
  41
  42 #+(and sb-thread (not sb-lutex))
  43 (progn
  44   (assert-timeout
  45    (let ((lock (sb-thread:make-mutex))
  46          (waitp t))
  47      (sb-thread:make-thread (lambda ()
  48                               (sb-thread:get-mutex lock)
  49                               (setf waitp nil)
  50                               (sleep 5)))
  51      (loop while waitp do (sleep 0.01))
  52      (sb-impl::with-deadline (:seconds 1)
  53        (sb-thread:get-mutex lock))))
  54
  55   (assert-timeout
  56    (let ((sem (sb-thread::make-semaphore :count 0)))
  57      (sb-impl::with-deadline (:seconds 1)
  58        (sb-thread::wait-on-semaphore sem))))
  59
  60   (assert-timeout
  61    (sb-impl::with-deadline (:seconds 1)
  62      (sb-thread:join-thread
  63       (sb-thread:make-thread (lambda () (loop (sleep 1))))))))