X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=eightsync%2Fagenda.scm;h=386752695c41968c96a81df2d13e86983dae2220;hp=8ffe6f18a489a94520f0a1058f0d9a8e3ca1da8a;hb=21857a053fd1ba6af66d95a2874193aeef20c4a2;hpb=9b75050c50d072cc273861f5959c925eb1886ce4 diff --git a/eightsync/agenda.scm b/eightsync/agenda.scm index 8ffe6f1..3867526 100644 --- a/eightsync/agenda.scm +++ b/eightsync/agenda.scm @@ -50,7 +50,7 @@ schedule-segments-split schedule-extract-until! add-segments-contents-to-queue! - %sync 8sync + %8sync make-run-request run-request? @@ -61,11 +61,12 @@ 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 + print-error-and-continue + %current-agenda start-agenda agenda-run-once)) @@ -93,7 +94,7 @@ (define-immutable-record-type (make-agenda-intern queue prompt-tag read-port-map write-port-map except-port-map - schedule time) + schedule time catch-handler pre-unwind-handler) agenda? (queue agenda-queue) (prompt-tag agenda-prompt-tag) @@ -101,7 +102,9 @@ (write-port-map agenda-write-port-map) (except-port-map agenda-except-port-map) (schedule agenda-schedule) - (time agenda-time)) + (time agenda-time) + (catch-handler agenda-catch-handler) + (pre-unwind-handler agenda-pre-unwind-handler)) (define (make-async-prompt-tag) "Make an async prompt tag for an agenda. @@ -116,12 +119,15 @@ Generally done automatically for the user through (make-agenda)." (write-port-map (make-hash-table)) (except-port-map (make-hash-table)) (schedule (make-schedule)) - (time (gettimeofday))) + (time (gettimeofday)) + (catch-handler #f) + (pre-unwind-handler #f)) ;; TODO: document arguments "Make a fresh agenda." (make-agenda-intern queue prompt read-port-map write-port-map except-port-map - schedule time)) + schedule time + catch-handler pre-unwind-handler)) (define (current-agenda-prompt) "Get the prompt for the current agenda; signal an error if there isn't one." @@ -150,6 +156,17 @@ Generally done automatically for the user through (make-agenda)." (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. @@ -161,6 +178,8 @@ If an integer, will convert appropriately." (((? 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))) @@ -199,12 +218,14 @@ run (time-segment-right-format) first." (sec time-delta-sec) (usec time-delta-usec)) -(define* (make-time-delta sec #:optional (usec 0)) +(define* (make-time-delta time) "Make a 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) @@ -233,13 +254,13 @@ Will produce (0 . 0) instead of a negative number, if needed." "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 @@ -367,6 +388,12 @@ Will produce (0 . 0) instead of a negative number, if needed." (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 ...) @@ -408,6 +435,8 @@ Will produce (0 . 0) instead of a negative number, if needed." ;;; ================================= ;; The future's in futures +;; @@: ... kinda conflicts with ice-9 futures. Should we rename +;; to "futurists"? :) (define (make-future call-first on-success on-fail on-error) ;; TODO: add error stuff here @@ -435,31 +464,19 @@ Will produce (0 . 0) instead of a negative number, if needed." (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) @@ -470,7 +487,7 @@ return the wrong thing via (8sync) and trip themselves up." ;; 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 ...) @@ -502,12 +519,6 @@ return the wrong thing via (8sync) and trip themselves up." (lambda () body ...))))) -;; Aliases -(define-syntax-rule (8run args ...) (%run args ...)) -(define-syntax-rule (8run-at args ...) (%run-at args ...)) -(define-syntax-rule (8run-delay args ...) (%run-delay args ...)) -(define-syntax-rule (8port-request args ...) (%port-request args ...)) - ;;; Execution of agenda, and current agenda @@ -539,10 +550,17 @@ return the wrong thing via (8sync) and trip themselves up." ;; 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) @@ -633,6 +651,25 @@ return the wrong thing via (8sync) and trip themselves up." (agenda-queue agenda)) (loop agenda)))))) +(define (print-error-and-continue . args) + "Frequently used as pre-unwind-handler for agenda" + (format (current-error-port) "\n*** Caught exception with arguments: ~s ***\n" + args) + (display-backtrace (make-stack #t 1 0) + (current-error-port)) + (newline (current-error-port))) + +(define-syntax-rule (maybe-catch-all (catch-handler pre-unwind-handler) + body ...) + (if (or catch-handler pre-unwind-handler) + (catch + #t + (lambda () + body ...) + (or catch-handler (lambda _ #f)) + (or pre-unwind-handler (lambda _ #f))) + (begin body ...))) + (define (agenda-run-once agenda) "Run once through the agenda, and produce a new agenda based on the results" @@ -641,7 +678,10 @@ based on the results" (agenda-prompt-tag agenda) (lambda () (parameterize ((%current-agenda agenda)) - (proc))) + (maybe-catch-all + ((agenda-catch-handler agenda) + (agenda-pre-unwind-handler agenda)) + (proc)))) (lambda (kont async-request) (setup-async-request kont async-request))))