mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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 <zefram@fysh.org>. * 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.
This commit is contained in:
Mark H Weaver
Andy Wingo
parent
4e24cca595
commit
e00563492a
3 changed files with 182 additions and 102 deletions
|
|
@ -2402,8 +2402,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
|
||||
|
|
@ -2435,18 +2435,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.
|
||||
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).
|
||||
|
||||
@c The SRFI-1 spec says -4714-11-24T12:00:00Z (November 24, -4714 at
|
||||
@c noon, UTC), but this is incorrect. It looks like it might have
|
||||
@c arisen from the code incorrectly treating years a multiple of 100
|
||||
@c but not 400 prior to 1582 as non-leap years, where instead the Julian
|
||||
@c calendar should be used so all multiples of 4 before 1582 are leap
|
||||
@c years.
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
|
||||
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- 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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue