[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: SRFI-19: Fix handling of negative years and negat
|
From: |
Mark H. Weaver |
|
Subject: |
[Guile-commits] 01/01: SRFI-19: Fix handling of negative years and negative julian days. |
|
Date: |
Sat, 20 Oct 2018 23:17:46 -0400 (EDT) |
mhw pushed a commit to branch stable-2.2
in repository guile.
commit a58c7abd72648f77e4ede5f62a2c4e7969bb7f95
Author: Mark H Weaver <address@hidden>
Date: Sat Oct 20 23:02:16 2018 -0400
SRFI-19: Fix handling of negative years and negative julian days.
Fixes <https://bugs.gnu.org/21906>.
Mitigates <https://bugs.gnu.org/21903> and <https://bugs.gnu.org/21904>.
Reported by: Zefram <address@hidden>.
* module/srfi/srfi-19.scm (encode-julian-day-number)
(decode-julian-day-number, date-week-number): Use 'floor-quotient'
instead of 'quotient', and 'floor' instead of 'truncate', where
appropriate.
(time-utc->date): Ensure that the 'nanoseconds' field of the returned
date is non-negative.
(leap-year): Handle negative years properly, and reformulate the
computation.
(week-day): Handle negative years properly. Use 'floor-quotient'
instead of 'quotient' where appropriate.
(directives): In the handler for '~Y' format escapes, improve the
handling of years outside of the range 0-9999.
(read-directives): Add a FIXME comment to fix the '~Y' reader to handle
years outside of the range 0-9999.
* test-suite/tests/srfi-19.test: Import (srfi srfi-1). Use Guile's
modern keyword notation in the 'define-module' form. Add more tests.
---
module/srfi/srfi-19.scm | 65 +++++++++++++++++++++++++------------------
test-suite/tests/srfi-19.test | 53 +++++++++++++++++++++++++++++++----
2 files changed, 86 insertions(+), 32 deletions(-)
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index d7e078d..9de22b0 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -579,20 +579,20 @@
(+ day
(quotient (+ (* 153 m) 2) 5)
(* 365 y)
- (quotient y 4)
- (- (quotient y 100))
- (quotient y 400)
+ (floor-quotient y 4)
+ (- (floor-quotient y 100))
+ (floor-quotient y 400)
-32045)))
;; gives the seconds/date/month/year
(define (decode-julian-day-number jdn)
- (let* ((days (inexact->exact (truncate jdn)))
+ (let* ((days (inexact->exact (floor jdn)))
(a (+ days 32044))
- (b (quotient (+ (* 4 a) 3) 146097))
- (c (- a (quotient (* 146097 b) 4)))
- (d (quotient (+ (* 4 c) 3) 1461))
- (e (- c (quotient (* 1461 d) 4)))
- (m (quotient (+ (* 5 e) 2) 153))
+ (b (floor-quotient (+ (* 4 a) 3) 146097))
+ (c (- a (floor-quotient (* 146097 b) 4)))
+ (d (floor-quotient (+ (* 4 c) 3) 1461))
+ (e (- c (floor-quotient (* 1461 d) 4)))
+ (m (floor-quotient (+ (* 5 e) 2) 153))
(y (+ (* 100 b) d -4800 (quotient m 10))))
(values ; seconds date month year
(* (- jdn days) sid)
@@ -623,7 +623,10 @@
(local-tz-offset time)))
(if (not (eq? (time-type time) time-utc))
(time-error 'time-utc->date 'incompatible-time-types time))
- (let ((jdn (time->julian-day-number (time-second time) tz-offset)))
+ (let* ((nanoseconds (+ (time-nanosecond time)
+ (* nano (time-second time))))
+ (jdn (time->julian-day-number (floor-quotient nanoseconds nano)
+ 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;
@@ -633,7 +636,7 @@
(rem (remainder int-secs (* 60 60)))
(minutes (quotient rem 60))
(seconds (remainder rem 60)))
- (make-date (time-nanosecond time)
+ (make-date (modulo nanoseconds nano)
seconds
minutes
hours
@@ -692,8 +695,10 @@
(time-utc->time-monotonic! (date->time-utc d))))
(define (leap-year? year)
- (or (= (modulo year 400) 0)
- (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
+ (let ((y (if (negative? year) (+ year 1) year)))
+ (and (zero? (modulo y 4))
+ (or (not (zero? (modulo y 100)))
+ (zero? (modulo y 400))))))
;; Map 1-based month number M to number of days in the year before the
;; start of month M (in a non-leap year).
@@ -714,15 +719,16 @@
;; from calendar faq
(define (week-day day month year)
- (let* ((a (quotient (- 14 month) 12))
- (y (- year a))
+ (let* ((yy (if (negative? year) (+ year 1) year))
+ (a (quotient (- 14 month) 12))
+ (y (- yy a))
(m (+ month (* 12 a) -2)))
(modulo (+ day
y
- (quotient y 4)
- (- (quotient y 100))
- (quotient y 400)
- (quotient (* 31 m) 12))
+ (floor-quotient y 4)
+ (- (floor-quotient y 100))
+ (floor-quotient y 400)
+ (floor-quotient (* 31 m) 12))
7)))
(define (date-week-day date)
@@ -743,10 +749,10 @@
;; a day starting from 1 for 1st Jan.
;;
(define (date-week-number date day-of-week-starting-week)
- (quotient (- (date-year-day date)
- 1
- (days-before-first-week date day-of-week-starting-week))
- 7))
+ (floor-quotient (- (date-year-day date)
+ 1
+ (days-before-first-week date day-of-week-starting-week))
+ 7))
(define (current-date . tz-offset)
(let ((time (current-time time-utc)))
@@ -1061,10 +1067,11 @@
2)
port)))
(cons #\Y (lambda (date pad-with port)
- (display (padding (date-year date)
- pad-with
- 4)
- port)))
+ (let* ((yy (date-year date))
+ (y (if (negative? yy) (+ yy 1) yy)))
+ (unless (<= 0 y 9999)
+ (display (if (negative? y) #\- #\+) port))
+ (display (padding (abs y) 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)
@@ -1344,8 +1351,12 @@
(list #\y char-fail eireader2
(lambda (val object)
(set-date-year! object (natural-year val))))
+
+ ;; XXX FIXME: Support the extended year format used by
+ ;; 'date->string' when the year is not in the range 0-9999.
(list #\Y char-numeric? ireader4 (lambda (val object)
(set-date-year! object val)))
+
(list #\z (lambda (c)
(or (char=? c #\Z)
(char=? c #\z)
diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test
index 028791b..ffaf9db 100644
--- a/test-suite/tests/srfi-19.test
+++ b/test-suite/tests/srfi-19.test
@@ -22,10 +22,11 @@
;; separate module, or later tests will fail.
(define-module (test-suite test-srfi-19)
- :duplicates (last) ;; avoid warning about srfi-19 replacing `current-time'
- :use-module (test-suite lib)
- :use-module (srfi srfi-19)
- :use-module (ice-9 format))
+ #:duplicates (last) ;; avoid warning about srfi-19 replacing `current-time'
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 format))
;; Make sure we use the default locale.
(when (defined? 'setlocale)
@@ -261,7 +262,49 @@ incomplete numerical tower implementation.)"
(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")))
+ (date->string (julian-day->date 4903089/2 0) "~4"))
+ (pass-if-equal "negative julian days"
+ '((-2000000 . "-10188-02-01T14:24:00Z wk=04 dow=6 doy=032")
+ (-20000 . "-4767-02-20T14:24:00Z wk=08 dow=0 doy=051")
+ (-10 . "-4713-11-14T14:24:00Z wk=45 dow=5 doy=318")
+ (-9 . "-4713-11-15T14:24:00Z wk=45 dow=6 doy=319")
+ (-8 . "-4713-11-16T14:24:00Z wk=46 dow=0 doy=320")
+ (-7 . "-4713-11-17T14:24:00Z wk=46 dow=1 doy=321")
+ (-6 . "-4713-11-18T14:24:00Z wk=46 dow=2 doy=322")
+ (-5 . "-4713-11-19T14:24:00Z wk=46 dow=3 doy=323")
+ (-4 . "-4713-11-20T14:24:00Z wk=46 dow=4 doy=324")
+ (-3 . "-4713-11-21T14:24:00Z wk=46 dow=5 doy=325")
+ (-2 . "-4713-11-22T14:24:00Z wk=46 dow=6 doy=326")
+ (-1 . "-4713-11-23T14:24:00Z wk=47 dow=0 doy=327")
+ (0 . "-4713-11-24T14:24:00Z wk=47 dow=1 doy=328")
+ (1 . "-4713-11-25T14:24:00Z wk=47 dow=2 doy=329")
+ (2 . "-4713-11-26T14:24:00Z wk=47 dow=3 doy=330")
+ (3 . "-4713-11-27T14:24:00Z wk=47 dow=4 doy=331")
+ (4 . "-4713-11-28T14:24:00Z wk=47 dow=5 doy=332")
+ (5 . "-4713-11-29T14:24:00Z wk=47 dow=6 doy=333")
+ (6 . "-4713-11-30T14:24:00Z wk=48 dow=0 doy=334")
+ (7 . "-4713-12-01T14:24:00Z wk=48 dow=1 doy=335")
+ (8 . "-4713-12-02T14:24:00Z wk=48 dow=2 doy=336")
+ (9 . "-4713-12-03T14:24:00Z wk=48 dow=3 doy=337"))
+ (map (lambda (n)
+ (cons n (date->string (julian-day->date (+ n 1/10) 0)
+ "~4 wk=~U dow=~w doy=~j")))
+ (cons* -2000000 -20000 (iota 20 -10))))
+ (pass-if-equal "negative year numbers"
+ '((1721055 . "-0001-12-27T14:24:00Z wk=52 dow=1 doy=361")
+ (1721056 . "-0001-12-28T14:24:00Z wk=52 dow=2 doy=362")
+ (1721057 . "-0001-12-29T14:24:00Z wk=52 dow=3 doy=363")
+ (1721058 . "-0001-12-30T14:24:00Z wk=52 dow=4 doy=364")
+ (1721059 . "-0001-12-31T14:24:00Z wk=52 dow=5 doy=365")
+ (1721060 . "0000-01-01T14:24:00Z wk=00 dow=6 doy=001")
+ (1721061 . "0000-01-02T14:24:00Z wk=01 dow=0 doy=002")
+ (1721062 . "0000-01-03T14:24:00Z wk=01 dow=1 doy=003")
+ (1721063 . "0000-01-04T14:24:00Z wk=01 dow=2 doy=004")
+ (1721064 . "0000-01-05T14:24:00Z wk=01 dow=3 doy=005"))
+ (map (lambda (n)
+ (cons n (date->string (julian-day->date (+ n 1/10) 0)
+ "~4 wk=~U dow=~w doy=~j")))
+ (iota 10 1721055))))
(with-test-prefix "time-utc->date"
(pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100"