+ "Signal a DEADLINE-TIMEOUT condition, and associate a DEFER-DEADLINE
+restart with it. Implementors of blocking functions are responsible
+for calling this when a deadline is reached."
+ ;; Make sure we don't signal the same deadline twice. LET is not good
+ ;; enough: we might catch the same deadline again while unwinding.
+ (when *deadline*
+ (setf *deadline* nil))
+ (with-interrupts
+ (restart-case
+ (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)))
+ (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
+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))
+
+(declaim (inline relative-decoded-times))
+(defun relative-decoded-times (abs-sec abs-usec)
+ #!+sb-doc
+ "Returns relative decoded times: difference between SEC and USEC and
+current real time."
+ (multiple-value-bind (now-sec now-usec)
+ (decode-internal-time (get-internal-real-time))
+ (let ((rel-sec (- abs-sec now-sec)))
+ (cond ((> now-usec abs-usec)
+ (values (max 0 (1- rel-sec))
+ (- (+ abs-usec 1000000) now-usec)))
+ (t
+ (values (max 0 rel-sec)
+ (- abs-usec now-usec)))))))