mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +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 • committed by Andy Wingo
parent 8361d59d1c
commit 0389c59bd4
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)))