schedule-segments-split schedule-extract-until!
add-segments-contents-to-queue!
- %sync 8sync
+ %8sync
<run-request>
make-run-request run-request?
port-request-port
port-request-read port-request-write port-request-except
- run-it wrap run run-at run-delay
+ run-it wrap wrap-apply run run-at run-delay
%port-request %run %run-at %run-delay
8port-request 8run 8run-at 8run-delay
(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))
+ (mixed-rest (- time mixed-whole)) ; float or fraction component
+ (sec mixed-whole)
+ (usec (floor (* 1000000 mixed-rest))))
+ (cons (inexact->exact sec) (inexact->exact usec))))
+
(define (time-segment-right-format time)
"Ensure TIME is in the right format.
(((? integer? s) . (? integer? u)) time)
;; time was just an integer (just the second)
((? integer? _) (cons time 0))
+ ((or (? rational? _) (? inexact? _))
+ (time-from-float-or-fraction time))
(_ (throw 'invalid-time "Invalid time" time))))
(define* (make-time-segment time #:optional (queue (make-q)))
(sec time-delta-sec)
(usec time-delta-usec))
-(define* (make-time-delta sec #:optional (usec 0))
+(define* (make-time-delta time)
"Make a <time-delta> of SEC seconds and USEC microseconds.
This is used primarily so the agenda can recognize RUN-REQUEST objects
-which are meant "
- (make-time-delta-intern sec usec))
+which are meant to delay computation"
+ (match (time-segment-right-format time)
+ ((sec . usec)
+ (make-time-delta-intern sec usec))))
(define tdelta make-time-delta)
"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>
(lambda ()
body ...))
+(define-syntax-rule (wrap-apply body)
+ "Wrap possibly multi-value function in a procedure, applies all arguments"
+ (lambda args
+ (apply body args)))
+
+
;; @@: Do we really want `body ...' here?
;; what about just `body'?
(define-syntax-rule (run body ...)
(make-future call-first on-success on-fail on-error)
when))
-(define-syntax-rule (%sync async-request)
+(define-syntax-rule (%8sync async-request)
"Run BODY asynchronously at a prompt, passing args to make-future.
-Pronounced `eight-sync' despite the spelling.
-
-%sync was chosen because (async) was already taken and could lead to
-errors, and this version of asynchronous code uses a prompt, so the `a'
-character becomes a `%' prompt! :)
-
-The % and 8 characters kind of look similar... hence this library's
-name! (That, and the pun 'eight-synchronous' programming.)
-There are 8sync aliases if you prefer that name."
+Runs things asynchronously (8synchronously?)"
(abort-to-prompt (current-agenda-prompt)
async-request))
-(define-syntax-rule (8sync args ...)
- "Alias for %sync"
- (%sync args ...))
-
;; Async port request and run-request meta-requests
(define (make-async-request proc)
"Wrap PROC in an async-request
The purpose of this is to make sure that users don't accidentally
-return the wrong thing via (8sync) and trip themselves up."
+return the wrong thing via (%8sync) and trip themselves up."
(cons '*async-request* proc))
(define (setup-async-request resume-kont async-request)
;; TODO: deliver more helpful errors depending on what the user
;; returned
(_ (throw 'invalid-async-request
- "Invalid request passed back via an (%sync) procedure."
+ "Invalid request passed back via an (%8sync) procedure."
async-request))))
(define-syntax-rule (%run body ...)
;; 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)