+(define (schedule-empty? schedule)
+ "Check if the SCHEDULE is currently empty"
+ (eq? (schedule-segments schedule) '()))
+
+(define (schedule-segments-split schedule time)
+ "Does a multiple value return of time segments before/at and after TIME"
+ (let ((time (time-segment-right-format time)))
+ (define (segment-is-now? segment)
+ (time= (time-segment-time segment) time))
+ (define (segment-is-before-now? segment)
+ (time< (time-segment-time segment) time))
+
+ (let loop ((segments-before '())
+ (segments-left (schedule-segments schedule)))
+ (match segments-left
+ ;; end of the line, return
+ ('()
+ (values (reverse segments-before) '()))
+
+ ;; It's right now, so time to stop, but include this one in before
+ ;; but otherwise return
+ (((? segment-is-now? first) rest ...)
+ (values (reverse (cons first segments-before)) rest))
+
+ ;; This is prior or at now, so add it and keep going
+ (((? segment-is-before-now? first) rest ...)
+ (loop (cons first segments-before) rest))
+
+ ;; Otherwise it's past now, just return what we have
+ (segments-after
+ (values segments-before segments-after))))))
+
+(define (schedule-extract-until! schedule time)
+ "Extract all segments until TIME from SCHEDULE, and pop old segments off"
+ (receive (segments-before segments-after)
+ (schedule-segments-split schedule time)
+ (set-schedule-segments! schedule segments-after)
+ segments-before))
+
+(define (add-segments-contents-to-queue! segments queue)
+ (for-each
+ (lambda (segment)
+ (let ((seg-queue (time-segment-queue segment)))
+ (while (not (q-empty? seg-queue))
+ (enq! queue (deq! seg-queue)))))
+ segments))
+
+
+\f
+;;; Request to run stuff
+;;; ====================
+
+(define-record-type <run-request>
+ (make-run-request proc when)
+ run-request?
+ (proc run-request-proc)
+ (when run-request-when))
+
+(define* (run-it proc #:optional when)
+ "Make a request to run PROC (possibly at WHEN)"
+ (make-run-request proc when))
+
+(define-syntax-rule (wrap body ...)
+ "Wrap contents in a procedure"
+ (lambda ()
+ body ...))
+
+;; @@: Do we really want `body ...' here?
+;; what about just `body'?
+(define-syntax-rule (run body ...)
+ "Run everything in BODY but wrap in a convenient procedure"
+ (make-run-request (wrap body ...) #f))
+
+(define-syntax-rule (run-at body ... when)
+ "Run BODY at WHEN"
+ (make-run-request (wrap body ...) when))
+
+;; @@: Is it okay to overload the term "delay" like this?
+;; Would `run-in' be better?
+(define-syntax-rule (run-delay body ... delay-time)
+ "Run BODY at DELAY-TIME time from now"
+ (make-run-request (wrap body ...) (tdelta delay-time)))
+
+
+;; A request to set up a port with at least one of read, write, except
+;; handling processes
+
+(define-record-type <port-request>
+ (make-port-request-intern port read write except)
+ port-request?
+ (port port-request-port)
+ (read port-request-read)
+ (write port-request-write)
+ (except port-request-except))
+
+(define* (make-port-request port #:key read write except)
+ (if (not (or read write except))
+ (throw 'no-port-handler-given "No port handler given.\n"))
+ (make-port-request-intern port read write except))
+
+
+\f
+;;; Asynchronous escape to run things
+;;; =================================
+
+;; The future's in futures
+
+(define (make-future call-first on-success on-fail on-error)
+ ;; TODO: add error stuff here
+ (lambda ()
+ (let ((call-result (call-first)))
+ ;; queue up calling the
+ (run (on-success call-result)))))
+
+(define (agenda-on-error agenda)
+ (const #f))
+
+(define (agenda-on-fail agenda)
+ (const #f))
+
+(define* (request-future call-first on-success
+ #:key
+ (agenda (%current-agenda))
+ (on-fail (agenda-on-fail agenda))
+ (on-error (agenda-on-error agenda))
+ (when #f))
+ ;; TODO: error handling
+ ;; do we need some distinction between expected, catchable errors,
+ ;; and unexpected, uncatchable ones? Probably...?
+ (make-run-request
+ (make-future call-first on-success on-fail on-error)
+ when))
+
+(define-syntax-rule (%sync body args ...)
+ "Run BODY asynchronously at a prompt, passing args to make-future.
+
+Pronounced `async' 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! (There are 8sync aliases if you prefer that name.)"
+ (abort-to-prompt (current-agenda-prompt)
+ (wrap body)
+ args ...))
+
+(define-syntax-rule (%sync-at body when args ...)
+ (abort-to-prompt (current-agenda-prompt)
+ (wrap body)
+ #:when when
+ args ...))
+
+(define-syntax-rule (%sync-delay body delay-time args ...)
+ (abort-to-prompt (current-agenda-prompt)
+ (wrap body)
+ #:when (tdelta delay-time)
+ args ...))
+
+(define-syntax-rule (8sync args ...)
+ "Alias for %sync"
+ (%sync args ...))
+
+(define-syntax-rule (8sync-at args ...)
+ "Alias for %sync-at"
+ (%sync-at args ...))
+
+(define-syntax-rule (8sync-delay args ...)
+ "Alias for %sync-delay"
+ (8sync-delay args ...))
+
+
+\f
+;;; Execution of agenda, and current agenda
+;;; =======================================
+
+(define %current-agenda (make-parameter #f))
+
+(define (update-agenda-from-select! agenda)
+ "Potentially (select) on ports specified in agenda, adding items to queue"
+ (define (hash-keys hash)
+ (hash-map->list (lambda (k v) k) hash))
+ (define (get-wait-time)
+ ;; TODO: we need to figure this out based on whether there's anything
+ ;; in the queue, and if not, how long till the next scheduled item
+ (let ((soonest-time (schedule-soonest-time (agenda-schedule agenda))))
+ (cond
+ ((not (q-empty? (agenda-queue agenda)))
+ (cons 0 0))
+ (soonest-time ; ie, the agenda is non-empty
+ (let* ((current-time (agenda-time agenda)))
+ (if (time<= soonest-time current-time)
+ ;; Well there's something due so let's select
+ ;; (this avoids a (possible?) race condition chance)
+ (cons 0 0)
+ (time-minus soonest-time current-time))))
+ (else
+ (cons #f #f)))))
+ (define (do-select)
+ ;; 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))))
+ (define (get-procs-to-run)
+ (define (ports->procs ports port-map)
+ (lambda (initial-procs)
+ (fold
+ (lambda (port prev)
+ (cons (lambda ()
+ ((hash-ref port-map port) port))
+ prev))
+ initial-procs
+ ports)))
+ (match (do-select)
+ ((read-ports write-ports except-ports)
+ ;; @@: Come on, we can do better than append ;P
+ ((compose (ports->procs
+ read-ports
+ (agenda-read-port-map agenda))
+ (ports->procs
+ write-ports
+ (agenda-write-port-map agenda))
+ (ports->procs
+ except-ports
+ (agenda-except-port-map agenda)))
+ '()))))
+ (define (update-agenda)
+ (let ((procs-to-run (get-procs-to-run))
+ (q (agenda-queue agenda)))
+ (for-each
+ (lambda (proc)
+ (enq! q proc))
+ procs-to-run))
+ agenda)
+ (define (ports-to-select?)
+ (define (has-items? selector)
+ ;; @@: O(n)
+ ;; ... we could use hash-for-each and a continuation to jump
+ ;; out with a #t at first indication of an item
+ (not (= (hash-count (const #t)
+ (selector agenda))
+ 0)))
+ (or (has-items? agenda-read-port-map)
+ (has-items? agenda-write-port-map)
+ (has-items? agenda-except-port-map)))
+
+ (if (ports-to-select?)
+ (update-agenda)
+ agenda))
+
+(define (agenda-handle-port-request! agenda port-request)
+ "Update an agenda for a port-request"
+ (define (handle-selector request-selector port-map-selector)
+ (if (request-selector port-request)
+ (hash-set! (port-map-selector agenda)
+ (port-request-port port-request)
+ (request-selector port-request))))
+ (handle-selector port-request-read agenda-read-port-map)
+ (handle-selector port-request-write agenda-write-port-map)
+ (handle-selector port-request-except agenda-except-port-map))
+
+
+(define* (start-agenda agenda
+ #:key stop-condition
+ (get-time gettimeofday)
+ (handle-ports update-agenda-from-select!))
+ ;; TODO: Document fields
+ "Start up the AGENDA"