(time time-segment-time)
(queue time-segment-queue))
+;; @@: This seems to be the same as srfi-18's seconds->time procedure?
+;; Maybe double check and switch to that? (Thanks amz3!)
+
(define (time-from-float-or-fraction time)
"Produce a (sec . usec) pair from TIME, a float or fraction"
(let* ((mixed-whole (floor time))
"Subtract TIME2 from TIME1"
(time-carry-correct
(cons (- (car time1) (car time2))
- (- (cdr time2) (cdr time2)))))
+ (- (cdr time1) (cdr time2)))))
(define (time-plus time1 time2)
"Add TIME1 and TIME2"
(time-carry-correct
(cons (+ (car time1) (car time2))
- (+ (cdr time2) (cdr time2)))))
+ (+ (cdr time1) (cdr time2)))))
(define-record-type <schedule>
;; TODO: support usecond wait time too
(match (get-wait-time)
((sec . usec)
- (select (hash-keys (agenda-read-port-map agenda))
- (hash-keys (agenda-write-port-map agenda))
- (hash-keys (agenda-except-port-map agenda))
- sec usec))))
+ (catch 'system-error
+ (lambda ()
+ (select (hash-keys (agenda-read-port-map agenda))
+ (hash-keys (agenda-write-port-map agenda))
+ (hash-keys (agenda-except-port-map agenda))
+ sec usec))
+ (lambda (key . rest-args)
+ (match rest-args
+ ((_ _ _ (EINTR))
+ '(() () ()))
+ (_ (error "Unhandled error in select!" key rest-args))))))))
(define (get-procs-to-run)
(define (ports->procs ports port-map)
(lambda (initial-procs)