From mboxrd@z Thu Jan  1 00:00:00 1970
Path: news.gmane.org!.POSTED!not-for-mail
From: Mark H Weaver <mhw@netris.org>
Newsgroups: gmane.lisp.guile.bugs
Subject: bug#26632: TAI<->UTC conversion botches 1961 to 1971
Date: Wed, 24 Oct 2018 01:57:33 -0400
Message-ID: <87zhv3yjhu.fsf@netris.org>
References: <20170424010218.GL6765@fysh.org>
NNTP-Posting-Host: blaine.gmane.org
Mime-Version: 1.0
Content-Type: multipart/mixed; boundary="=-=-="
X-Trace: blaine.gmane.org 1540360577 13028 195.159.176.226 (24 Oct 2018 05:56:17 GMT)
X-Complaints-To: usenet@blaine.gmane.org
NNTP-Posting-Date: Wed, 24 Oct 2018 05:56:17 +0000 (UTC)
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.1 (gnu/linux)
Cc: 26632@debbugs.gnu.org
To: Zefram <zefram@fysh.org>
Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Wed Oct 24 07:56:13 2018
Return-path: <bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org>
Envelope-to: guile-bugs@m.gmane.org
Original-Received: from lists.gnu.org ([208.118.235.17])
	by blaine.gmane.org with esmtp (Exim 4.84_2)
	(envelope-from <bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org>)
	id 1gFC9K-0003F8-RV
	for guile-bugs@m.gmane.org; Wed, 24 Oct 2018 07:56:11 +0200
Original-Received: from localhost ([::1]:46141 helo=lists.gnu.org)
	by lists.gnu.org with esmtp (Exim 4.71)
	(envelope-from <bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org>)
	id 1gFCBR-0001tf-3F
	for guile-bugs@m.gmane.org; Wed, 24 Oct 2018 01:58:21 -0400
Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:39528)
	by lists.gnu.org with esmtp (Exim 4.71)
	(envelope-from <Debian-debbugs@debbugs.gnu.org>) id 1gFCBJ-0001tD-B1
	for bug-guile@gnu.org; Wed, 24 Oct 2018 01:58:16 -0400
Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
	(envelope-from <Debian-debbugs@debbugs.gnu.org>) id 1gFCBA-0002nt-Ab
	for bug-guile@gnu.org; Wed, 24 Oct 2018 01:58:09 -0400
Original-Received: from debbugs.gnu.org ([208.118.235.43]:34771)
	by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16)
	(Exim 4.71) (envelope-from <Debian-debbugs@debbugs.gnu.org>)
	id 1gFCB8-0002nF-Hl
	for bug-guile@gnu.org; Wed, 24 Oct 2018 01:58:03 -0400
Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2)
	(envelope-from <Debian-debbugs@debbugs.gnu.org>) id 1gFCB8-0005Dp-8H
	for bug-guile@gnu.org; Wed, 24 Oct 2018 01:58:02 -0400
X-Loop: help-debbugs@gnu.org
Resent-From: Mark H Weaver <mhw@netris.org>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces@debbugs.gnu.org>
Resent-CC: bug-guile@gnu.org
Resent-Date: Wed, 24 Oct 2018 05:58:02 +0000
Resent-Message-ID: <handler.26632.B26632.154036067820064@debbugs.gnu.org>
Resent-Sender: help-debbugs@gnu.org
X-GNU-PR-Message: followup 26632
X-GNU-PR-Package: guile
X-GNU-PR-Keywords: 
Original-Received: via spool by 26632-submit@debbugs.gnu.org id=B26632.154036067820064
	(code B ref 26632); Wed, 24 Oct 2018 05:58:02 +0000
Original-Received: (at 26632) by debbugs.gnu.org; 24 Oct 2018 05:57:58 +0000
Original-Received: from localhost ([127.0.0.1]:39029 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces@debbugs.gnu.org>)
	id 1gFCB4-0005DY-5q
	for submit@debbugs.gnu.org; Wed, 24 Oct 2018 01:57:58 -0400
Original-Received: from world.peace.net ([64.112.178.59]:60528)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <mhw@netris.org>) id 1gFCAz-0005DI-RM
	for 26632@debbugs.gnu.org; Wed, 24 Oct 2018 01:57:55 -0400
Original-Received: from mhw by world.peace.net with esmtpsa
	(TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89)
	(envelope-from <mhw@netris.org>)
	id 1gFCAs-0004yF-Dx; Wed, 24 Oct 2018 01:57:47 -0400
In-Reply-To: <20170424010218.GL6765@fysh.org> (Zefram's message of "Mon, 24
	Apr 2017 02:02:18 +0100")
X-BeenThere: debbugs-submit@debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 208.118.235.43
X-BeenThere: bug-guile@gnu.org
List-Id: "Bug reports for GUILE,
	GNU's Ubiquitous Extension Language" <bug-guile.gnu.org>
List-Unsubscribe: <https://lists.gnu.org/mailman/options/bug-guile>,
	<mailto:bug-guile-request@gnu.org?subject=unsubscribe>
List-Archive: <http://lists.gnu.org/archive/html/bug-guile/>
List-Post: <mailto:bug-guile@gnu.org>
List-Help: <mailto:bug-guile-request@gnu.org?subject=help>
List-Subscribe: <https://lists.gnu.org/mailman/listinfo/bug-guile>,
	<mailto:bug-guile-request@gnu.org?subject=subscribe>
Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org
Original-Sender: "bug-guile" <bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org>
Xref: news.gmane.org gmane.lisp.guile.bugs:9243
Archived-At: <http://permalink.gmane.org/gmane.lisp.guile.bugs/9243>

--=-=-=
Content-Type: text/plain

Hi Zefram,

Zefram <zefram@fysh.org> writes:
> The SRFI-19 library gets TAI<->UTC conversions badly wrong in the years
> 1961 to 1971 (inclusive).

Indeed.

> This has to be examined somewhat indirectly, because SRFI-19 doesn't offer
> any way to display a TAI time in its conventional form as a date-like
> structure, nor to input a TAI time from such a structure.

FWIW, here are two procedures I hacked up to support TAI dates:

--8<---------------cut here---------------start------------->8---
(define (time-tai->date-tai t . tz-offset)
  (apply time-tai->date
         (time-utc->time-tai! (make-time time-utc
                                         (time-nanosecond t)
                                         (time-second t)))
         tz-offset))

(define (date-tai->time-tai d)
  (let ((t (time-tai->time-utc (date->time-tai d))))
    (set-time-type! t time-tai)
    t))
--8<---------------cut here---------------end--------------->8---

> SRFI-19's date structure, as implemented, is always interpreted
> according to UTC.

Indeed, I discovered this as well, and found it surprising.  The text of
SRFI-19 fails to mention it, but the reference implementation makes it
quite clear.

> First I'll consider an ordinary day in 1967:
>
> scheme@(guile-user)> (use-modules (srfi srfi-19))
> scheme@(guile-user)> (time-difference
> ... (time-utc->time-tai (date->time-utc (make-date 0 0 0 0 15 3 1967 0)))
> ... (time-utc->time-tai (date->time-utc (make-date 0 0 0 0 14 3 1967 0))))
> $1 = #<time type: time-duration nanosecond: 0 second: 86400>
>
> This takes the start and end of 1967-03-14, as judged by UTC, converts
> both of these times to TAI, and asks for the duration of that TAI
> interval.  It's asking how many TAI seconds long that UTC day was.
> As described in <http://maia.usno.navy.mil/ser7/tai-utc.dat>, there
> was no UTC leap on that day, but throughout 1967 UTC had a frequency
> offset from TAI such that each UTC second lasted exactly 1.00000003 TAI
> seconds.  The correct answer to the above question is therefore exactly
> 86400.002592 s.  The answer shown above, of 86400.000000 s, is incorrect.
>
> If time-tai->time-utc is applied to the times in the above example,
> it accurately inverts what time-utc->time-tai did.  It is good that the
> conversions are mutually consistent, but in this case it means they are
> both wrong.
>
> Second, I'll consider a less ordinary day:
>
> scheme@(guile-user)> (time-difference
> ... (time-utc->time-tai (date->time-utc (make-date 0 0 0 12 1 2 1968 0)))
> ... (time-utc->time-tai (date->time-utc (make-date 0 0 0 12 31 1 1968 0))))
> $2 = #<time type: time-duration nanosecond: 0 second: 86400>
>
> This time the period considered is from noon 1968-01-31 to noon
> 1968-02-01.  The same frequency offset described above applies throughout
> this period.  The additional complication here is that at the end of
> 1968-01-31 there was a leap of -0.1 (TAI) seconds.  The true duration of
> this day is therefore exactly 86399.902592 s.  The answer shown above,
> of 86400.000000 s, is incorrect in two ways, accounting for neither the
> frequency offset nor the leap.

I've attached two patches to fix this bug.  The first lays the
groundwork by adding support for non-integer TAI-UTC deltas.  The second
patch adds the TAI-UTC tables for 1961-1971 and uses them to implement
TAI<->UTC conversions over that time range with nanosecond accuracy.

Although the code is now written, I'm unsure whether we should add it to
Guile.  I'm vaguely concerned about violating widely-held assumptions,
e.g. that UTC runs at the same rate as TAI (except when leap seconds are
introduced), which might cause some code on top of Guile to misbehave if
the system clock is set pre-1972, although admittedly such a scenario
seems unlikely.

I'm curious to hear opinions on this.

Anyway, here are the patches.

      Mark



--=-=-=
Content-Type: text/x-patch
Content-Disposition: inline;
 filename=0001-SRFI-19-TAI-UTC-conversions-support-non-integer-delt.patch
Content-Description: [PATCH 1/2] SRFI-19: TAI<->UTC conversions support
 non-integer deltas

>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


--=-=-=
Content-Type: text/x-patch
Content-Disposition: inline;
 filename=0002-SRFI-19-Implement-correct-TAI-UTC-conversions-for-19.patch
Content-Description: [PATCH 2/2] SRFI-19: Implement correct TAI<->UTC
 conversions for 1961-1971

>From adfcb5ee624d457a8dae33e8e122cbff6d4a1428 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 23 Oct 2018 00:42:12 -0400
Subject: [PATCH 2/2] SRFI-19: Implement correct TAI<->UTC conversions for
 1961-1971.

* module/srfi/srfi-19.scm (tai-utc-1961-1971-table): New variable.
(pre-1972-utc->tai, pre-1972-tai->utc): New procedures.
(utc->tai, tai->utc): Use the new procedures.
---
 module/srfi/srfi-19.scm | 58 +++++++++++++++++++++++++++++++++++++++--
 1 file changed, 56 insertions(+), 2 deletions(-)

diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index f653b1bc3..d4afa1931 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -240,7 +240,7 @@
 (define (utc->tai ns utc-seconds)
   (let loop ((table leap-second-table))
     (cond ((null? table)
-           (values ns utc-seconds))
+           (pre-1972-utc->tai ns utc-seconds))
           ((>= utc-seconds (caar table))
            (values ns (+ utc-seconds (cdar table))))
           (else
@@ -249,13 +249,67 @@
 (define (tai->utc ns tai-seconds)
   (let loop ((table leap-second-table))
     (cond ((null? table)
-           (values ns tai-seconds))
+           (pre-1972-tai->utc ns tai-seconds))
           ((>= tai-seconds (+ (caar table) (cdar table)))
            (values ns (- tai-seconds (cdar table))))
           (else
            (loop (cdr table))))))
 
 
+(define tai-utc-1961-1971-table
+  ;;      UTC start       delta@start  slope
+  ;;        (ns)             (ns)      (ns/s)
+  '(( -60480000000000000  6185682000    30)
+    (-126230400000000000  4313170000    30)
+    (-136771200000000000  4155058000    15)
+    (-142128000000000000  3974706000    15)
+    (-152668800000000000  3716594000    15)
+    (-157766400000000000  3540130000    15)
+    (-168307200000000000  3282018000    15)
+    (-181526400000000000  2983730000    15)
+    (-189388800000000000  2765794000    15)
+    (-194659200000000000  2697278800    13)
+    (-252460800000000000  1845858000    13)
+    (-265680000000000000  1647570000    15)
+    (-283996800000000000  1422818000    15)))
+
+(define (pre-1972-utc->tai ns utc-seconds)
+  (let ((utc-ns (+ ns (* nano utc-seconds))))
+    (let loop ((table tai-utc-1961-1971-table))
+      (cond ((null? table)
+             (values ns utc-seconds))
+            ((>= utc-ns (caar table))
+             (apply (lambda (utc-start delta@start slope)
+                      (let ((tai-ns (+ utc-ns
+                                       delta@start
+                                       (round-quotient (* slope (- utc-ns
+                                                                   utc-start))
+                                                       nano))))
+                        (values (truncate-remainder tai-ns nano)
+                                (truncate-quotient tai-ns nano))))
+                    (car table)))
+            (else
+             (loop (cdr table)))))))
+
+(define (pre-1972-tai->utc ns tai-seconds)
+  (let ((tai-ns (+ ns (* nano tai-seconds))))
+    (let loop ((table tai-utc-1961-1971-table))
+      (cond ((null? table)
+             (values ns tai-seconds))
+            ((>= tai-ns (+ (caar table) (cadar table)))
+             (apply (lambda (utc-start delta@start slope)
+                      (let ((utc-ns (+ utc-start
+                                       (round-quotient (* nano (- tai-ns
+                                                                  utc-start
+                                                                  delta@start))
+                                                       (+ nano slope)))))
+                        (values (truncate-remainder utc-ns nano)
+                                (truncate-quotient utc-ns nano))))
+                    (car table)))
+            (else
+             (loop (cdr table)))))))
+
+
 ;;; the TIME structure; creates the accessors, too.
 
 (define-record-type time
-- 
2.19.1


--=-=-=--