[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: SRFI-19: Fix TAI->UTC conversions, leap second ha
|
From: |
Mark H. Weaver |
|
Subject: |
[Guile-commits] 01/01: SRFI-19: Fix TAI->UTC conversions, leap second handling, etc. |
|
Date: |
Sat, 20 Oct 2018 17:28:42 -0400 (EDT) |
mhw pushed a commit to branch stable-2.2
in repository guile.
commit 5106377a3460e1e35daf14ea6edbe80426347155
Author: Mark H Weaver <address@hidden>
Date: Sat Oct 20 03:34:56 2018 -0400
SRFI-19: Fix TAI->UTC conversions, leap second handling, etc.
Fixes <https://bugs.gnu.org/21911>.
Fixes <https://bugs.gnu.org/22034>.
Fixes <https://bugs.gnu.org/21902>.
Partially fixes <https://bugs.gnu.org/21904>.
Reported by Zefram <address@hidden>.
* doc/ref/srfi-modules.texi (SRFI-19 Introduction): Fix the definitions
of Julian Day and Modified Julian Day. Give the correct full names of
UTC and TAI.
* module/srfi/srfi-19.scm: Import (srfi srfi-1). Use modern Guile
keyword syntax in the 'define-module' form.
(leap-second-neg-delta): New procedure, derived from a similar procedure
in the latest upstream SRFI-19 reference implementation.
(priv:time-tai->time-utc!, time-tai->julian-day)
(time-monotonic->julian-day): Use 'leap-second-neg-delta'.
(local-tz-offset): Fix comment.
(leap-second?): Remove.
(tai-before-leap-second?): New procedure, derived from upstream SRFI-19.
(time-utc->date): Use 'define*' to handle the optional argument. Remove
the leap second handling, following upstream SRFI-19.
(time-tai->date): Rewrite in terms of 'time-utc->date'. Add special
leap second handling, following upstream SRFI-19.
(time-monotonic->date): Rewrite in terms of 'time-tai->date'.
(date->time-tai, date->time-monotonic): Add special leap second
handling, following upstream SRFI-19.
(directives): In the entry for the "~Y" escape in 'date->string', pad
the year field to 4 characters, following upstream SRFI-19.
* test-suite/tests/srfi-19.test: Add tests.
---
doc/ref/srfi-modules.texi | 24 +++----
module/srfi/srfi-19.scm | 145 +++++++++++++++++-------------------------
test-suite/tests/srfi-19.test | 117 +++++++++++++++++++++++++++++++++-
3 files changed, 183 insertions(+), 103 deletions(-)
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 5d2ebe6..99967e5 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -2401,8 +2401,8 @@ functions and variables described here are provided by
@cindex UTC
@cindex TAI
This module implements time and date representations and calculations,
-in various time systems, including universal time (UTC) and atomic
-time (TAI).
+in various time systems, including Coordinated Universal Time (UTC)
+and International Atomic Time (TAI).
For those not familiar with these time systems, TAI is based on a
fixed length second derived from oscillations of certain atoms. UTC
@@ -2434,18 +2434,14 @@ in @file{srfi-19.scm} for how to update this table.
@cindex julian day
@cindex modified julian day
Also, for those not familiar with the terminology, a @dfn{Julian Day}
-is a real number which is a count of days and fraction of a day, in
-UTC, starting from -4713-01-01T12:00:00Z, ie.@: midday Monday 1 Jan
-4713 B.C. A @dfn{Modified Julian Day} is the same, but starting from
-1858-11-17T00:00:00Z, ie.@: midnight 17 November 1858 UTC. That time
-is julian day 2400000.5.
-
address@hidden The SRFI-1 spec says -4714-11-24T12:00:00Z (November 24, -4714
at
address@hidden noon, UTC), but this is incorrect. It looks like it might have
address@hidden arisen from the code incorrectly treating years a multiple of
100
address@hidden but not 400 prior to 1582 as non-leap years, where instead the
Julian
address@hidden calendar should be used so all multiples of 4 before 1582 are
leap
address@hidden years.
+represents a point in time as a real number of days since
+-4713-11-24T12:00:00Z, i.e.@: midday UT on 24 November 4714 BC in the
+proleptic Gregorian calendar (1 January 4713 BC in the proleptic Julian
+calendar).
+
+A @dfn{Modified Julian Day} represents a point in time as a real number
+of days since 1858-11-17T00:00:00Z, i.e.@: midnight UT on Wednesday 17
+November AD 1858. That time is julian day 2400000.5.
@node SRFI-19 Time
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index 42a51ef..d7e078d 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -40,13 +40,14 @@
;; the DATE structure.
(define-module (srfi srfi-19)
- :use-module (srfi srfi-6)
- :use-module (srfi srfi-8)
- :use-module (srfi srfi-9)
- :autoload (ice-9 rdelim) (read-line)
- :use-module (ice-9 i18n)
- :replace (current-time)
- :export (;; Constants
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-6)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:autoload (ice-9 rdelim) (read-line)
+ #:use-module (ice-9 i18n)
+ #:replace (current-time)
+ #:export (;; Constants
time-duration
time-monotonic
time-process
@@ -244,6 +245,16 @@
(if (< utc-seconds (* (- 1972 1970) 365 sid)) 0
(lsd leap-second-table))))
+;; going from tai seconds to utc seconds ...
+(define (leap-second-neg-delta tai-seconds)
+ (letrec ((lsd (lambda (table)
+ (cond ((null? table) 0)
+ ((>= tai-seconds (+ (caar table) (cdar table)))
+ (cdar table))
+ (else (lsd (cdr table)))))) )
+ (if (< tai-seconds (* (- 1972 1970) 365 sid)) 0
+ (lsd leap-second-table))))
+
;;; the TIME structure; creates the accessors, too.
@@ -449,7 +460,7 @@
(set-time-type! time-out time-utc)
(set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (- (time-second time-in)
- (leap-second-delta
+ (leap-second-neg-delta
(time-second time-in))))
time-out)
@@ -594,7 +605,7 @@
;; This should be written to be OS specific.
(define (local-tz-offset utc-time)
- ;; SRFI uses seconds West, but guile (and libc) use seconds East.
+ ;; SRFI 19 uses seconds East, but 'tm:gmtoff' returns seconds West.
(- (tm:gmtoff (localtime (time-second utc-time)))))
;; special thing -- ignores nanos
@@ -603,21 +614,16 @@
sid)
tai-epoch-in-jd))
-(define (leap-second? second)
- (and (assoc second leap-second-table) #t))
+(define (tai-before-leap-second? second)
+ (any (lambda (x)
+ (= second (+ (car x) (cdr x) -1)))
+ leap-second-table))
-(define (time-utc->date time . tz-offset)
+(define* (time-utc->date time #:optional (tz-offset
+ (local-tz-offset time)))
(if (not (eq? (time-type time) time-utc))
(time-error 'time-utc->date 'incompatible-time-types time))
- (let* ((offset (if (null? tz-offset)
- (local-tz-offset time)
- (car tz-offset)))
- (leap-second? (leap-second? (+ offset (time-second time))))
- (jdn (time->julian-day-number (if leap-second?
- (- (time-second time) 1)
- (time-second time))
- offset)))
-
+ (let ((jdn (time->julian-day-number (time-second time) tz-offset)))
(call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year)
;; secs is a real because jdn is a real in Guile;
@@ -628,78 +634,34 @@
(minutes (quotient rem 60))
(seconds (remainder rem 60)))
(make-date (time-nanosecond time)
- (if leap-second? (+ seconds 1) seconds)
+ seconds
minutes
hours
date
month
year
- offset))))))
+ tz-offset))))))
(define (time-tai->date time . tz-offset)
(if (not (eq? (time-type time) time-tai))
(time-error 'time-tai->date 'incompatible-time-types time))
- (let* ((offset (if (null? tz-offset)
- (local-tz-offset (time-tai->time-utc time))
- (car tz-offset)))
- (seconds (- (time-second time)
- (leap-second-delta (time-second time))))
- (leap-second? (leap-second? (+ offset seconds)))
- (jdn (time->julian-day-number (if leap-second?
- (- seconds 1)
- seconds)
- offset)))
- (call-with-values (lambda () (decode-julian-day-number jdn))
- (lambda (secs date month year)
- ;; secs is a real because jdn is a real in Guile;
- ;; but it is conceptionally an integer.
- ;; adjust for leap seconds if necessary ...
- (let* ((int-secs (inexact->exact (round secs)))
- (hours (quotient int-secs (* 60 60)))
- (rem (remainder int-secs (* 60 60)))
- (minutes (quotient rem 60))
- (seconds (remainder rem 60)))
- (make-date (time-nanosecond time)
- (if leap-second? (+ seconds 1) seconds)
- minutes
- hours
- date
- month
- year
- offset))))))
+ (if (tai-before-leap-second? (time-second time))
+ ;; If it's *right* before the leap, we must handle this case to
+ ;; avoid the information lost when converting to UTC. We subtract
+ ;; a second before conversion, and then effectively add it back
+ ;; after conversion by setting the second field to 60.
+ (let ((d (apply time-utc->date
+ (subtract-duration! (time-tai->time-utc time)
+ (make-time time-duration 0 1))
+ tz-offset)))
+ (set-date-second! d 60)
+ d)
+ (apply time-utc->date (time-tai->time-utc time) tz-offset)))
-;; this is the same as time-tai->date.
(define (time-monotonic->date time . tz-offset)
(if (not (eq? (time-type time) time-monotonic))
(time-error 'time-monotonic->date 'incompatible-time-types time))
- (let* ((offset (if (null? tz-offset)
- (local-tz-offset (time-monotonic->time-utc time))
- (car tz-offset)))
- (seconds (- (time-second time)
- (leap-second-delta (time-second time))))
- (leap-second? (leap-second? (+ offset seconds)))
- (jdn (time->julian-day-number (if leap-second?
- (- seconds 1)
- seconds)
- offset)))
- (call-with-values (lambda () (decode-julian-day-number jdn))
- (lambda (secs date month year)
- ;; secs is a real because jdn is a real in Guile;
- ;; but it is conceptionally an integer.
- ;; adjust for leap seconds if necessary ...
- (let* ((int-secs (inexact->exact (round secs)))
- (hours (quotient int-secs (* 60 60)))
- (rem (remainder int-secs (* 60 60)))
- (minutes (quotient rem 60))
- (seconds (remainder rem 60)))
- (make-date (time-nanosecond time)
- (if leap-second? (+ seconds 1) seconds)
- minutes
- hours
- date
- month
- year
- offset))))))
+ (apply time-tai->date (time-monotonic->time-tai time) tz-offset))
(define (date->time-utc date)
(let* ((jdays (- (encode-julian-day-number (date-day date)
@@ -717,11 +679,17 @@
(date-second date)
(- (date-zone-offset date))))))
-(define (date->time-tai date)
- (time-utc->time-tai! (date->time-utc date)))
+(define (date->time-tai d)
+ (if (= (date-second d) 60)
+ (subtract-duration! (time-utc->time-tai! (date->time-utc d))
+ (make-time time-duration 0 1))
+ (time-utc->time-tai! (date->time-utc d))))
-(define (date->time-monotonic date)
- (time-utc->time-monotonic! (date->time-utc date)))
+(define (date->time-monotonic d)
+ (if (= (date-second d) 60)
+ (subtract-duration! (time-utc->time-monotonic! (date->time-utc d))
+ (make-time time-duration 0 1))
+ (time-utc->time-monotonic! (date->time-utc d))))
(define (leap-year? year)
(or (= (modulo year 400) 0)
@@ -835,7 +803,7 @@
(if (not (eq? (time-type time) time-tai))
(time-error 'time-tai->julian-day 'incompatible-time-types time))
(+ (/ (+ (- (time-second time)
- (leap-second-delta (time-second time)))
+ (leap-second-neg-delta (time-second time)))
(/ (time-nanosecond time) nano))
sid)
tai-epoch-in-jd))
@@ -849,7 +817,7 @@
(if (not (eq? (time-type time) time-monotonic))
(time-error 'time-monotonic->julian-day 'incompatible-time-types time))
(+ (/ (+ (- (time-second time)
- (leap-second-delta (time-second time)))
+ (leap-second-neg-delta (time-second time)))
(/ (time-nanosecond time) nano))
sid)
tai-epoch-in-jd))
@@ -1093,7 +1061,10 @@
2)
port)))
(cons #\Y (lambda (date pad-with port)
- (display (date-year date) port)))
+ (display (padding (date-year date)
+ pad-with
+ 4)
+ port)))
(cons #\z (lambda (date pad-with port)
(tz-printer (date-zone-offset date) port)))
(cons #\Z (lambda (date pad-with port)
diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test
index c963f15..028791b 100644
--- a/test-suite/tests/srfi-19.test
+++ b/test-suite/tests/srfi-19.test
@@ -1,8 +1,8 @@
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <address@hidden> --- June 2001
;;;;
-;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008,
-;;;; 2011, 2014, 2017 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003-2008, 2011, 2014, 2017, 2018
+;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -211,6 +211,9 @@ incomplete numerical tower implementation.)"
(pass-if "31dec98 23:59:59"
(time-equal? (make-time time-tai 0 915148830)
(date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
+ (pass-if "31dec98 23:59:60"
+ (time-equal? (make-time time-tai 0 915148831)
+ (date->time-tai (make-date 0 60 59 23 31 12 1998 0))))
(pass-if "1jan99 0:00:00"
(time-equal? (make-time time-tai 0 915148832)
(date->time-tai (make-date 0 0 0 0 1 1 1999 0))))
@@ -220,10 +223,120 @@ incomplete numerical tower implementation.)"
(pass-if "31dec05 23:59:59"
(time-equal? (make-time time-tai 0 1136073631)
(date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
+ (pass-if "31dec05 23:59:60"
+ (time-equal? (make-time time-tai 0 1136073632)
+ (date->time-tai (make-date 0 60 59 23 31 12 2005 0))))
(pass-if "1jan06 0:00:00"
(time-equal? (make-time time-tai 0 1136073633)
(date->time-tai (make-date 0 0 0 0 1 1 2006 0)))))
+ (with-test-prefix "date->time-monotonic"
+ ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
+ ;; seconds of MONOTONIC in date->time-monotonic
+ (pass-if "31dec98 23:59:59"
+ (time-equal? (make-time time-monotonic 0 915148830)
+ (date->time-monotonic (make-date 0 59 59 23 31 12 1998 0))))
+ (pass-if "31dec98 23:59:60"
+ (time-equal? (make-time time-monotonic 0 915148831)
+ (date->time-monotonic (make-date 0 60 59 23 31 12 1998 0))))
+ (pass-if "1jan99 0:00:00"
+ (time-equal? (make-time time-monotonic 0 915148832)
+ (date->time-monotonic (make-date 0 0 0 0 1 1 1999 0))))
+
+ ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
+ ;; seconds of MONOTONIC in date->time-monotonic
+ (pass-if "31dec05 23:59:59"
+ (time-equal? (make-time time-monotonic 0 1136073631)
+ (date->time-monotonic (make-date 0 59 59 23 31 12 2005 0))))
+ (pass-if "31dec05 23:59:60"
+ (time-equal? (make-time time-monotonic 0 1136073632)
+ (date->time-monotonic (make-date 0 60 59 23 31 12 2005 0))))
+ (pass-if "1jan06 0:00:00"
+ (time-equal? (make-time time-monotonic 0 1136073633)
+ (date->time-monotonic (make-date 0 0 0 0 1 1 2006 0)))))
+
+ (with-test-prefix "julian-day->date"
+ (pass-if-equal "0002-07-29T12:00:00Z" "0002-07-29T12:00:00Z"
+ (date->string (julian-day->date 1722000 0) "~4"))
+ (pass-if-equal "0024-06-23T12:00:00Z" "0024-06-23T12:00:00Z"
+ (date->string (julian-day->date 1730000 0) "~4"))
+ (pass-if-equal "2000-01-01T00:00:00Z" "2000-01-01T00:00:00Z"
+ (date->string (julian-day->date 4903089/2 0) "~4")))
+
+ (with-test-prefix "time-utc->date"
+ (pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100"
+ (date->string (time-utc->date (make-time time-utc 0 1341100799)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T01:00:00+0100" "2012-07-01T01:00:00+0100"
+ (date->string (time-utc->date (make-time time-utc 0 1341100800)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T01:00:01+0100" "2012-07-01T01:00:01+0100"
+ (date->string (time-utc->date (make-time time-utc 0 1341100801)
+ 3600)
+ "~4")))
+
+ (with-test-prefix "time-tai->date"
+ (pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100"
+ (date->string (time-tai->date (make-time time-tai 0 1341100833)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T00:59:60+0100" "2012-07-01T00:59:60+0100"
+ (date->string (time-tai->date (make-time time-tai 0 1341100834)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T01:00:00+0100" "2012-07-01T01:00:00+0100"
+ (date->string (time-tai->date (make-time time-tai 0 1341100835)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T01:00:01+0100" "2012-07-01T01:00:01+0100"
+ (date->string (time-tai->date (make-time time-tai 0 1341100836)
+ 3600)
+ "~4")))
+
+ (with-test-prefix "time-monotonic->date"
+ (pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100"
+ (date->string (time-monotonic->date (make-time time-monotonic
+ 0 1341100833)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T00:59:60+0100" "2012-07-01T00:59:60+0100"
+ (date->string (time-monotonic->date (make-time time-monotonic
+ 0 1341100834)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T01:00:00+0100" "2012-07-01T01:00:00+0100"
+ (date->string (time-monotonic->date (make-time time-monotonic
+ 0 1341100835)
+ 3600)
+ "~4"))
+ (pass-if-equal "2012-07-01T01:00:01+0100" "2012-07-01T01:00:01+0100"
+ (date->string (time-monotonic->date (make-time time-monotonic
+ 0 1341100836)
+ 3600)
+ "~4")))
+
+ (with-test-prefix "time-tai->julian-day"
+ (pass-if-equal "2012-07-01T00:59:59+0100" 212207860799/86400
+ (time-tai->julian-day (make-time time-tai 0 1341100833)))
+ (pass-if-equal "2012-07-01T00:59:60+0100" 4912219/2
+ (time-tai->julian-day (make-time time-tai 0 1341100834)))
+ (pass-if-equal "2012-07-01T01:00:00+0100" 4912219/2
+ (time-tai->julian-day (make-time time-tai 0 1341100835)))
+ (pass-if-equal "2012-07-01T01:00:01+0100" 212207860801/86400
+ (time-tai->julian-day (make-time time-tai 0 1341100836))))
+
+ (with-test-prefix "time-monotonic->julian-day"
+ (pass-if-equal "2012-07-01T00:59:59+0100" 212207860799/86400
+ (time-monotonic->julian-day (make-time time-monotonic 0 1341100833)))
+ (pass-if-equal "2012-07-01T00:59:60+0100" 4912219/2
+ (time-monotonic->julian-day (make-time time-monotonic 0 1341100834)))
+ (pass-if-equal "2012-07-01T01:00:00+0100" 4912219/2
+ (time-monotonic->julian-day (make-time time-monotonic 0 1341100835)))
+ (pass-if-equal "2012-07-01T01:00:01+0100" 212207860801/86400
+ (time-monotonic->julian-day (make-time time-monotonic 0 1341100836))))
+
(with-test-prefix "date-week-number"
(pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
(pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))