X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=loopy.scm;h=8c216eeb7d1dd509d50846b76bf6ca510c682c4d;hb=f04065ae644b415fdf14564aec4be0c6f6189988;hp=ee1bc8121319943f49271b47b17e495ac92821de;hpb=3d1cf1e79073cdd9c0ecb09ee9e4f7dd29dc4149;p=8sync.git diff --git a/loopy.scm b/loopy.scm index ee1bc81..8c216ee 100644 --- a/loopy.scm +++ b/loopy.scm @@ -37,7 +37,7 @@ make-run-request run-request? run-request-proc run-request-when - run wrap run-wrap run-wrap-at + run-it wrap run run-at delay %current-agenda start-agenda agenda-run-once)) @@ -110,6 +110,11 @@ (queue time-segment-queue)) (define (time-segment-right-format time) + "Ensure TIME is in the right format. + +The right format means (second . microsecond). +If an integer, will convert appropriately." + ;; TODO: add floating point / rational number support. (match time ;; time is already a cons of second and microsecnd (((? integer? s) . (? integer? u)) time) @@ -118,9 +123,14 @@ (_ (throw 'invalid-time "Invalid time" time)))) (define* (make-time-segment time #:optional (queue (make-q))) + "Make a time segment of TIME and QUEUE + +No automatic conversion is done, so you might have to +run (time-segment-right-format) first." (make-time-segment-intern time queue)) (define (time< time1 time2) + "Check if TIME1 is less than TIME2" (cond ((< (car time1) (car time2)) #t) @@ -132,10 +142,12 @@ (else #f))) (define (time= time1 time2) + "Check whether TIME1 and TIME2 are equivalent" (and (= (car time1) (car time2)) (= (cdr time1) (cdr time2)))) (define (time<= time1 time2) + "Check if TIME1 is less than or equal to TIME2" (or (time< time1 time2) (time= time1 time2))) @@ -146,8 +158,12 @@ (sec time-delta-sec) (usec time-delta-usec)) -(define* (make-time-delta sec #:optional usec) - (make-time-delta-intern sec (or usec 0))) +(define* (make-time-delta sec #:optional (usec 0)) + "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)) (define tdelta make-time-delta) @@ -167,19 +183,22 @@ Will produce (0 . 0) instead of a negative number, if needed." (else time))) (define (time-delta+ time time-delta) + "Increment a TIME by the value of TIME-DELTA" (time-carry-correct (cons (+ (car time) (time-delta-sec time-delta)) (+ (cdr time) (time-delta-usec time-delta))))) (define (time-minus time1 time2) + "Subtract TIME2 from TIME1" (time-carry-correct (cons (- (car time1) (car time2)) - (- (car time2) (cdr time2))))) + (- (cdr time2) (cdr time2))))) (define (time-plus time1 time2) + "Add TIME1 and TIME2" (time-carry-correct (cons (+ (car time1) (car time2)) - (+ (car time2) (cdr time2))))) + (+ (cdr time2) (cdr time2))))) (define-record-type @@ -188,6 +207,7 @@ Will produce (0 . 0) instead of a negative number, if needed." (segments schedule-segments set-schedule-segments!)) (define* (make-schedule #:optional segments) + "Make a schedule, optionally pre-composed of SEGMENTS" (make-schedule-intern (or segments '()))) (define (schedule-soonest-time schedule) @@ -202,6 +222,7 @@ Will produce (0 . 0) instead of a negative number, if needed." ;; but at least it'll be reasonably easy to refactor to ;; a more functional setup? (define (schedule-add! schedule time proc) + "Mutate SCHEDULE, adding PROC at an appropriate time segment for TIME" (let ((time (time-segment-right-format time))) (define (new-time-segment) (let ((new-segment @@ -239,6 +260,7 @@ Will produce (0 . 0) instead of a negative number, if needed." (loop (schedule-segments schedule))))) (define (schedule-empty? schedule) + "Check if the SCHEDULE is currently empty" (eq? (schedule-segments schedule) '())) (define (schedule-segments-split schedule time) @@ -319,24 +341,38 @@ Will produce (0 . 0) instead of a negative number, if needed." ;;; Request to run stuff ;;; ==================== -(define-record-type +(define-immutable-record-type (make-run-request proc when) run-request? (proc run-request-proc) (when run-request-when)) -(define* (run proc #:optional 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 ...)) -(define-syntax-rule (run-wrap body ...) - (run (wrap 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)) + +(define-syntax-rule (run-delay body ... delay-time) + "Run BODY at DELAY-TIME time from now" + (make-run-request (wrap body ...) (tdelta delay-time))) -(define-syntax-rule (run-wrap-at body ... when) - (run (wrap body ...) when)) +(define (delay run-request delay-time) + "Delay a RUN-REQUEST by DELAY-TIME" + (set-field run-request + (run-request-when) + (tdelta delay-time))) ;;; Execution of agenda, and current agenda @@ -356,11 +392,11 @@ Will produce (0 . 0) instead of a negative number, if needed." (cons 0 0)) (soonest-time ; ie, the agenda is non-empty (let* ((current-time (agenda-time agenda))) - (if (time<= (pk 'soonest-time soonest-time) (pk 'current-time current-time)) + (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) - (pk 'time-minus (time-minus soonest-time current-time))))) + (time-minus soonest-time current-time)))) (else (cons #f #f))))) (define (do-select) @@ -432,17 +468,20 @@ Will produce (0 . 0) instead of a negative number, if needed." (agenda-run-once agenda)))) (if (and stop-condition (stop-condition agenda)) 'done - (let* ((new-time (get-time)) - (agenda - (handle-ports - ;; Adjust the agenda's time just in time - ;; We do this here rather than in agenda-run-once to make - ;; agenda-run-once's behavior fairly predictable - (set-field agenda (agenda-time) new-time)))) + (let* ((agenda + ;; We have to update the time after ports handled, too + ;; because it may have changed after a select + (set-field + (handle-ports + ;; Adjust the agenda's time just in time + ;; We do this here rather than in agenda-run-once to make + ;; agenda-run-once's behavior fairly predictable + (set-field agenda (agenda-time) (get-time))) + (agenda-time) (get-time)))) ;; Update the agenda's current queue based on ;; currently applicable time segments (add-segments-contents-to-queue! - (schedule-extract-until! (agenda-schedule agenda) new-time) + (schedule-extract-until! (agenda-schedule agenda) (agenda-time agenda)) (agenda-queue agenda)) (loop agenda))))))