X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=loopy.scm;h=7b43ba6d6dbe6274786779d7b7fd9f7cb7bc0ef0;hb=140ab5bad794069833dc046a4a988cc6e6c22d1a;hp=cb7ee81106d7bace5bfe9841b31684d31cdd0868;hpb=0d17f91644ea33444e06155f1e58adb5331fc24d;p=8sync.git

diff --git a/loopy.scm b/loopy.scm
index cb7ee81..7b43ba6 100644
--- a/loopy.scm
+++ b/loopy.scm
@@ -17,7 +17,8 @@
             make-time-segment time-segment?
             time-segment-time time-segment-queue
 
-            time-< time-= time-<= time-+
+            time< time= time<= time-delta+
+            time-minus time-plus
 
             <time-delta>
             make-time-delta tdelta time-delta?
@@ -36,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))
@@ -119,7 +120,7 @@
 (define* (make-time-segment time #:optional (queue (make-q)))
   (make-time-segment-intern time queue))
 
-(define (time-< time1 time2)
+(define (time< time1 time2)
   (cond ((< (car time1)
             (car time2))
          #t)
@@ -130,13 +131,13 @@
          #t)
         (else #f)))
 
-(define (time-= time1 time2)
+(define (time= time1 time2)
   (and (= (car time1) (car time2))
        (= (cdr time1) (cdr time2))))
 
-(define (time-<= time1 time2)
-  (or (time-< time1 time2)
-      (time-= time1 time2)))
+(define (time<= time1 time2)
+  (or (time< time1 time2)
+      (time= time1 time2)))
 
 
 (define-record-type <time-delta>
@@ -150,9 +151,35 @@
 
 (define tdelta make-time-delta)
 
-(define (time-+ time time-delta)
-  (cons (+ (car time) (time-delta-sec time-delta))
-        (+ (cdr time) (time-delta-usec time-delta))))
+(define (time-carry-correct time)
+  "Corrects/handles time microsecond carry.
+Will produce (0 . 0) instead of a negative number, if needed."
+  (cond ((>= (cdr time) 1000000)
+         (cons
+          (+ (car time) 1)
+          (- (cdr time) 1000000)))
+        ((< (cdr time) 0)
+         (if (= (car time) 0)
+             '(0 0)
+             (cons
+              (- (car time) 1)
+              (+ (cdr time) 1000000))))
+        (else time)))
+
+(define (time-delta+ time 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)
+  (time-carry-correct
+   (cons (- (car time1) (car time2))
+         (- (cdr time2) (cdr time2)))))
+
+(define (time-plus time1 time2)
+  (time-carry-correct
+   (cons (+ (car time1) (car time2))
+         (+ (cdr time2) (cdr time2)))))
 
 
 (define-record-type <schedule>
@@ -183,10 +210,10 @@
         new-segment))
     (define (loop segments)
       (define (segment-equals-time? segment)
-        (time-= time (time-segment-time segment)))
+        (time= time (time-segment-time segment)))
 
       (define (segment-more-than-time? segment)
-        (time-< time (time-segment-time segment)))
+        (time< time (time-segment-time segment)))
 
       ;; We could switch this out to be more mutate'y
       ;; and avoid the O(n) of space... is that over-optimizing?
@@ -218,9 +245,9 @@
   "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))
+      (time= (time-segment-time segment) time))
     (define (segment-is-before-now? segment)
-      (time-< (time-segment-time segment) time))
+      (time< (time-segment-time segment) time))
 
     (let loop ((segments-before '())
                (segments-left (schedule-segments schedule)))
@@ -292,24 +319,37 @@
 ;;; Request to run stuff
 ;;; ====================
 
-(define-record-type <run-request>
+(define-immutable-record-type <run-request>
   (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-wrap-at body ... when)
-  (run (wrap body ...) when))
+(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)
+  (make-run-request (wrap body ...) (tdelta delay-time)))
+
+(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
@@ -318,7 +358,7 @@
 (define %current-agenda (make-parameter #f))
 
 (define (update-agenda-from-select! agenda)
-  (define (hash-keys selector)
+  (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
@@ -326,26 +366,24 @@
     (let ((soonest-time (schedule-soonest-time (agenda-schedule agenda))))
       (cond 
        ((not (q-empty? (agenda-queue agenda)))
-        (values 0 0))
+        (cons 0 0))
        (soonest-time    ; ie, the agenda is non-empty
         (let* ((current-time (agenda-time agenda)))
-          (if (time-<= soonest-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)
-              (values 0 0)
-              (values
-               (- (car soonest-time) (car current-time))
-               (- (cdr soonest-time) (cdr current-time))))))
+              (cons 0 0)
+              (time-minus soonest-time current-time))))
        (else
-        (values #f #f)))))
+        (cons #f #f)))))
   (define (do-select)
     ;; TODO: support usecond wait time too
-    (receive (sec usec)
-        (get-wait-time)
-      (select (hash-keys (agenda-read-port-map agenda))
-              (hash-keys (agenda-write-port-map agenda))
-              (hash-keys (agenda-except-port-map agenda))
-              sec usec)))
+    (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)
@@ -407,17 +445,20 @@
              (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))))))
 
@@ -444,8 +485,8 @@ based on the results"
                 (let ((request-time (run-request-when run-request)))
                   (match request-time
                     ((? time-delta? time-delta)
-                     (let ((time (time-+ (agenda-time agenda)
-                                         time-delta)))
+                     (let ((time (time-delta+ (agenda-time agenda)
+                                              time-delta)))
                        (schedule-at! time (run-request-proc run-request))))
                     ((? integer? sec)
                      (let ((time (cons sec 0)))