mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

SRFI-19: Fix normalization of seconds and nanoseconds in time records.

Browse source 
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:
Mark H Weaver 2018-10-21 19:21:47 -04:00
parent bbe6daa769
commit 437e1aa036
2 changed files with 24 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/srfi/srfi-19.scm
View file

@ -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)))

8
test-suite/tests/srfi-19.test
View file

@ -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