mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-29 16:30:19 +02:00
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.
This commit is contained in:
parent
bbe6daa769
commit
437e1aa036
2 changed files with 24 additions and 18 deletions
|
@ -275,24 +275,22 @@
|
||||||
(values (inexact->exact l) (- r l)))))
|
(values (inexact->exact l) (- r l)))))
|
||||||
|
|
||||||
(define (time-normalize! t)
|
(define (time-normalize! t)
|
||||||
(if (>= (abs (time-nanosecond t)) 1000000000)
|
(let ((s (time-second t))
|
||||||
(receive (int frac)
|
(ns (time-nanosecond t)))
|
||||||
(split-real (time-nanosecond t))
|
(when (>= (abs (time-nanosecond t))
|
||||||
(set-time-second! t (+ (time-second t)
|
nano)
|
||||||
(quotient int 1000000000)))
|
(let ((s* (+ s (inexact->exact
|
||||||
(set-time-nanosecond! t (+ (remainder int 1000000000)
|
(truncate-quotient ns nano))))
|
||||||
frac))))
|
(ns* (truncate-remainder ns nano)))
|
||||||
(if (and (positive? (time-second t))
|
(set-time-second! t s*)
|
||||||
(negative? (time-nanosecond t)))
|
(set-time-nanosecond! t ns*)))
|
||||||
(begin
|
(cond ((and (positive? s) (negative? ns))
|
||||||
(set-time-second! t (- (time-second t) 1))
|
(set-time-second! t (- s 1))
|
||||||
(set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
|
(set-time-nanosecond! t (+ ns nano)))
|
||||||
(if (and (negative? (time-second t))
|
((and (negative? s) (positive? ns))
|
||||||
(positive? (time-nanosecond t)))
|
(set-time-second! t (+ s 1))
|
||||||
(begin
|
(set-time-nanosecond! t (- ns nano))))
|
||||||
(set-time-second! t (+ (time-second t) 1))
|
t))
|
||||||
(set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
|
|
||||||
t)
|
|
||||||
|
|
||||||
(define (make-time type nanosecond second)
|
(define (make-time type nanosecond second)
|
||||||
(time-normalize! (make-time-unnormalized type nanosecond second)))
|
(time-normalize! (make-time-unnormalized type nanosecond second)))
|
||||||
|
|
|
@ -206,6 +206,14 @@ incomplete numerical tower implementation.)"
|
||||||
(test-time-arithmetic add-duration time1 diff time2)
|
(test-time-arithmetic add-duration time1 diff time2)
|
||||||
(test-time-arithmetic subtract-duration time2 diff time1))
|
(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"
|
(with-test-prefix "date->time-tai"
|
||||||
;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
|
;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
|
||||||
;; seconds of TAI in date->time-tai
|
;; seconds of TAI in date->time-tai
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue