X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=loopy.scm;h=603a75a47e19afc1be2208530ce05b0d9a078a26;hb=5766ad69cacb52a8a0705ae9279ec64f45e9aa31;hp=5477af677f65d7e8464eb3af686e1a1b591484c8;hpb=9ed57ce7714e4228941d689aa717196d3280db43;p=8sync.git diff --git a/loopy.scm b/loopy.scm index 5477af6..603a75a 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,16 +183,19 @@ 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)) (- (cdr time2) (cdr time2))))) (define (time-plus time1 time2) + "Add TIME1 and TIME2" (time-carry-correct (cons (+ (car time1) (car time2)) (+ (cdr time2) (cdr time2))))) @@ -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) @@ -285,58 +307,42 @@ Will produce (0 . 0) instead of a negative number, if needed." segments)) - -;;; Port handling -;;; ============= - -(define (make-port-mapping) - (make-hash-table)) - -(define* (port-mapping-set! port-mapping port #:optional read write except) - "Sets port-mapping for reader / writer / exception handlers" - (if (not (or read write except)) - (throw 'no-handlers-given "No handlers given for port" port)) - (hashq-set! port-mapping port - `#(,read ,write ,except))) - -(define (port-mapping-remove! port-mapping port) - (hashq-remove! port-mapping port)) - -;; TODO: This is O(n), I'm pretty sure :\ -;; ... it might be worthwhile for us to have a -;; port-mapping record that keeps a count of how many -;; handlers (maybe via a promise?) -(define (port-mapping-empty? port-mapping) - "Is this port mapping empty?" - (eq? (hash-count (const #t) port-mapping) 0)) - -(define (port-mapping-non-empty? port-mapping) - "Whether this port-mapping contains any elements" - (not (port-mapping-empty? port-mapping))) - - ;;; 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 @@ -432,17 +438,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))))))