diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index d7e078de1..9de22b0ed 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 028791bc3..ffaf9db43 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"