diff options
| -rw-r--r-- | doc/ref/srfi-modules.texi | 24 | ||||
| -rw-r--r-- | module/srfi/srfi-19.scm | 145 | ||||
| -rw-r--r-- | 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 5d2ebe67c..99967e574 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. - -@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. +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 42a51ef20..d7e078de1 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 c963f15c9..028791bc3 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 <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))) |