(error 'deadline-timeout :seconds *deadline-seconds*)
(defer-deadline (&optional (seconds *deadline-seconds*))
:report "Defer the deadline for SECONDS more."
+ :interactive (lambda ()
+ (sb!int:read-evaluated-form
+ "By how many seconds shall the deadline ~
+ be deferred?: "))
(let* ((new-deadline-seconds (coerce seconds 'single-float))
(new-deadline (+ (seconds-to-internal-time new-deadline-seconds)
(get-internal-real-time))))
(setf *deadline* new-deadline
- *deadline-seconds* new-deadline-seconds)))))
+ *deadline-seconds* new-deadline-seconds)))
+ (cancel-deadline ()
+ :report "Cancel the deadline and continue."
+ (setf *deadline* nil *deadline-seconds* nil))))
nil)
(defun defer-deadline (seconds &optional condition)
"Find the DEFER-DEADLINE restart associated with CONDITION, and
-calls it with SECONDS as argument (deferring the deadline by that many
-seconds.) Continues from the indicated restart, or returns NIL if the
-restart is not found."
+invoke it with SECONDS as argument (deferring the deadline by that many
+seconds.) Otherwise return NIL if the restart is not found."
(try-restart 'defer-deadline condition seconds))
+(defun cancel-deadline (&optional condition)
+ "Find and invoke the CANCEL-DEADLINE restart associated with
+CONDITION, or return NIL if the restart is not found."
+ (try-restart 'cancel-deadline condition))
+
;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
;;;
;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
+(in-package :cl-user)
+
+(use-package :test-util)
+
(defmacro assert-timeout (form)
(let ((ok (gensym "OK")))
`(let ((,ok ',ok))
,ok)))
(error "No timeout from form:~% ~S" ',form)))))
+(defun run-sleep (seconds)
+ (sb-ext:run-program "sleep" (list (format nil "~D" seconds))
+ :search t :wait t))
-(assert-timeout
- (sb-sys:with-deadline (:seconds 1)
- (run-program "sleep" '("3") :search t :wait t)))
+(with-test (:name (:deadline :run-program :trivial))
+ (assert-timeout (sb-sys:with-deadline (:seconds 1)
+ (run-sleep 3))))
-(let ((n 0)
- (final nil))
- (handler-case
- (handler-bind ((sb-sys:deadline-timeout (lambda (c)
- (when (< n 2)
- (incf n)
- (sb-sys:defer-deadline 0.1 c)))))
- (sb-sys:with-deadline (:seconds 1)
- (run-program "sleep" '("2") :search t :wait t)))
- (sb-sys:deadline-timeout (c)
- (setf final c)))
- (assert (= n 2))
- (assert final))
+(with-test (:name (:deadline :defer-deadline-1))
+ (let ((n 0)
+ (final nil))
+ (handler-case
+ (handler-bind ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ (when (< n 2)
+ (incf n)
+ (sb-sys:defer-deadline 0.1 c)))))
+ (sb-sys:with-deadline (:seconds 1)
+ (run-sleep 2)))
+ (sb-sys:deadline-timeout (c)
+ (setf final c)))
+ (assert (= n 2))
+ (assert final)))
-(let ((n 0)
- (final nil))
- (handler-case
- (handler-bind ((sb-sys:deadline-timeout (lambda (c)
- (incf n)
- (sb-sys:defer-deadline 0.1 c))))
- (sb-sys:with-deadline (:seconds 1)
- (run-program "sleep" '("2") :search t :wait t)))
- (sb-sys:deadline-timeout (c)
- (setf final c)))
- (assert (plusp n))
- (assert (not final)))
+(with-test (:name (:deadline :defer-deadline-2))
+ (let ((n 0)
+ (final nil))
+ (handler-case
+ (handler-bind ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ (incf n)
+ (sb-sys:defer-deadline 0.1 c))))
+ (sb-sys:with-deadline (:seconds 1)
+ (run-sleep 2)))
+ (sb-sys:deadline-timeout (c)
+ (setf final c)))
+ (assert (plusp n))
+ (assert (not final))))
+
+(with-test (:name (:deadline :cancel-deadline))
+ (let ((n 0)
+ (final nil))
+ (handler-case
+ (handler-bind ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ (incf n)
+ (sb-sys:cancel-deadline c))))
+ (sb-sys:with-deadline (:seconds 1)
+ (run-sleep 2)))
+ (sb-sys:deadline-timeout (c)
+ (setf final c)))
+ (assert (= n 1))
+ (assert (not final))))
#+(and sb-thread (not sb-lutex))
(progn
- (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-impl::with-deadline (:seconds 1)
- (sb-thread:get-mutex lock))))
- (assert-timeout
- (let ((sem (sb-thread::make-semaphore :count 0)))
- (sb-impl::with-deadline (:seconds 1)
- (sb-thread::wait-on-semaphore sem))))
+ (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)))))
- (assert-timeout
- (sb-impl::with-deadline (:seconds 1)
- (sb-thread:join-thread
- (sb-thread:make-thread (lambda () (loop (sleep 1)))))))
+ (with-test (:name (:deadline :join-thread))
+ (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))
(lambda ()
(let ((start (get-internal-real-time)))
(handler-case
- (sb-impl::with-deadline (:seconds 1)
+ (sb-sys:with-deadline (:seconds 1)
(sb-thread:get-mutex lock))
(sb-sys:deadline-timeout (x)
(declare (ignore x))
(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)))))))
+ (assert (< seconds-passed 1.2)))))))
\ No newline at end of file
projects / sbcl.git / commitdiff