diff options
author | Mark H Weaver <mhw@netris.org> | 2018-10-21 19:21:47 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2018-10-21 19:25:45 -0400 |
commit | 437e1aa03659b77a8eb4b5c6d2b104c03d038564 (patch) | |
tree | 884e6e2e1fa617c0f90fbc22f06525ab6d62feb5 | |
parent | bbe6daa769e183a41909e345412af73c6d2561ec (diff) | |
download | guile-437e1aa03659b77a8eb4b5c6d2b104c03d038564.tar.gz |
SRFI-19: Fix normalization of seconds and nanoseconds in time records.
Fixes <https://bugs.gnu.org/26162>.
Reported by Zefram <zefram@fysh.org>.
* module/srfi/srfi-19.scm (time-normalize!): Rewrite.
* test-suite/tests/srfi-19.test: Add tests.
-rw-r--r-- | module/srfi/srfi-19.scm | 34 | ||||
-rw-r--r-- | test-suite/tests/srfi-19.test | 8 |
2 files changed, 24 insertions, 18 deletions
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 9de22b0ed..ba1327c9f 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -275,24 +275,22 @@ (values (inexact->exact l) (- r l))))) (define (time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (receive (int frac) - (split-real (time-nanosecond t)) - (set-time-second! t (+ (time-second t) - (quotient int 1000000000))) - (set-time-nanosecond! t (+ (remainder int 1000000000) - frac)))) - (if (and (positive? (time-second t)) - (negative? (time-nanosecond t))) - (begin - (set-time-second! t (- (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) - (if (and (negative? (time-second t)) - (positive? (time-nanosecond t))) - (begin - (set-time-second! t (+ (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) - t) + (let ((s (time-second t)) + (ns (time-nanosecond t))) + (when (>= (abs (time-nanosecond t)) + nano) + (let ((s* (+ s (inexact->exact + (truncate-quotient ns nano)))) + (ns* (truncate-remainder ns nano))) + (set-time-second! t s*) + (set-time-nanosecond! t ns*))) + (cond ((and (positive? s) (negative? ns)) + (set-time-second! t (- s 1)) + (set-time-nanosecond! t (+ ns nano))) + ((and (negative? s) (positive? ns)) + (set-time-second! t (+ s 1)) + (set-time-nanosecond! t (- ns nano)))) + t)) (define (make-time type nanosecond second) (time-normalize! (make-time-unnormalized type nanosecond second))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 0f1c33352..4d79f1043 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -206,6 +206,14 @@ incomplete numerical tower implementation.)" (test-time-arithmetic add-duration time1 diff time2) (test-time-arithmetic subtract-duration time2 diff time1)) + (with-test-prefix "nanosecond normalization" + (pass-if "small positive duration" + (time-equal? (make-time time-duration 999999000 0) + (time-difference (make-time time-tai 0 1) (make-time time-tai 1000 0)))) + (pass-if "small negative duration" + (time-equal? (make-time time-duration -999999000 0) + (time-difference (make-time time-tai 1000 0) (make-time time-tai 0 1))))) + (with-test-prefix "date->time-tai" ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2 ;; seconds of TAI in date->time-tai |