From 3a67fbfd441b39630ff3c3201d2a731b51b1a8ee Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 23 Oct 2018 00:39:30 -0400
Subject: [PATCH 1/2] SRFI-19: TAI<->UTC conversions support non-integer
 deltas.

Previously, 'utc->tai' and 'tai->utc' were unary procedures and returned
a second value, mapping seconds to seconds, based on the assumption that
the nanoseconds field would never be changed by these maps.  To support
non-integer values of TAI-UTC, here we change 'utc->tai' and 'tai->utc'
to accept two arguments and return two values: nanoseconds and seconds.

* module/srfi/srfi-19 (utc->tai, tai->utc): Add an additional 'ns'
argument, and return it as an additional value.
(current-time-tai, priv:time-tai->time-utc!, priv:time-utc->time-tai!)
(time-tai->julian-day, time-monotonic->julian-day): Adapt accordingly.
---
 module/srfi/srfi-19.scm | 56 +++++++++++++++++++++++------------------
 1 file changed, 31 insertions(+), 25 deletions(-)

diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index 46de91a7e..f653b1bc3 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -237,21 +237,21 @@
   (set! leap-second-table (read-tai-utc-data filename)))
 
 
-(define (utc->tai utc-seconds)
+(define (utc->tai ns utc-seconds)
   (let loop ((table leap-second-table))
     (cond ((null? table)
-           utc-seconds)
+           (values ns utc-seconds))
           ((>= utc-seconds (caar table))
-           (+ utc-seconds (cdar table)))
+           (values ns (+ utc-seconds (cdar table))))
           (else
            (loop (cdr table))))))
 
-(define (tai->utc tai-seconds)
+(define (tai->utc ns tai-seconds)
   (let loop ((table leap-second-table))
     (cond ((null? table)
-           tai-seconds)
+           (values ns tai-seconds))
           ((>= tai-seconds (+ (caar table) (cdar table)))
-           (- tai-seconds (cdar table)))
+           (values ns (- tai-seconds (cdar table))))
           (else
            (loop (cdr table))))))
 
@@ -309,9 +309,8 @@
   (let* ((tod (gettimeofday))
          (sec (car tod))
          (usec (cdr tod)))
-    (make-time time-tai
-               (* usec 1000)
-               (utc->tai sec))))
+    (receive (ns s) (utc->tai (* usec 1000) sec)
+      (make-time time-tai ns s))))
 
 ;;(define (current-time-ms-time time-type proc)
 ;;  (let ((current-ms (proc)))
@@ -460,10 +459,12 @@
 (define (priv:time-tai->time-utc! time-in time-out caller)
   (if (not (eq? (time-type time-in) time-tai))
       (time-error caller 'incompatible-time-types time-in))
-  (set-time-type! time-out time-utc)
-  (set-time-nanosecond! time-out (time-nanosecond time-in))
-  (set-time-second!     time-out (tai->utc (time-second time-in)))
-  time-out)
+  (receive (ns s) (tai->utc (time-nanosecond time-in)
+                            (time-second time-in))
+    (set-time-type! time-out time-utc)
+    (set-time-nanosecond! time-out ns)
+    (set-time-second!     time-out s)
+    time-out))
 
 (define (time-tai->time-utc time-in)
   (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))
@@ -475,10 +476,13 @@
 (define (priv:time-utc->time-tai! time-in time-out caller)
   (if (not (eq? (time-type time-in) time-utc))
       (time-error caller 'incompatible-time-types time-in))
-  (set-time-type! time-out time-tai)
-  (set-time-nanosecond! time-out (time-nanosecond time-in))
-  (set-time-second!     time-out (utc->tai (time-second time-in)))
-  time-out)
+  (receive (ns s)
+      (utc->tai (time-nanosecond time-in)
+                (time-second time-in))
+    (set-time-type! time-out time-tai)
+    (set-time-nanosecond! time-out ns)
+    (set-time-second!     time-out s)
+    time-out))
 
 (define (time-utc->time-tai time-in)
   (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))
@@ -807,10 +811,11 @@
 (define (time-tai->julian-day time)
   (if (not (eq? (time-type time) time-tai))
       (time-error 'time-tai->julian-day 'incompatible-time-types  time))
-  (+ (/ (+ (tai->utc (time-second time))
-           (/ (time-nanosecond time) nano))
-        sid)
-     tai-epoch-in-jd))
+  (receive (ns s) (tai->utc (time-nanosecond time)
+                            (time-second time))
+    (+ (/ (+ s (/ ns nano))
+          sid)
+       tai-epoch-in-jd)))
 
 (define (time-tai->modified-julian-day time)
   (- (time-tai->julian-day time)
@@ -820,10 +825,11 @@
 (define (time-monotonic->julian-day time)
   (if (not (eq? (time-type time) time-monotonic))
       (time-error 'time-monotonic->julian-day 'incompatible-time-types  time))
-  (+ (/ (+ (tai->utc (time-second time))
-           (/ (time-nanosecond time) nano))
-        sid)
-     tai-epoch-in-jd))
+  (receive (ns s) (tai->utc (time-nanosecond time)
+                            (time-second time))
+    (+ (/ (+ s (/ ns nano))
+          sid)
+       tai-epoch-in-jd)))
 
 (define (time-monotonic->modified-julian-day time)
   (- (time-monotonic->julian-day time)
-- 
2.19.1