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: Check for incompatible types in time comparisons.

Browse source 
Fixes <https://bugs.gnu.org/26163>.
Reported by Zefram <zefram@fysh.org>.

* module/srfi/srfi-19.scm (time-compare-check): New procedure.
(time=?): Use 'time-compare-check' to check the arguments and raise an
error in case of mismatched types.  Previously, mismatched types would
cause time=? to return #f.
(time>?, time<?, time>=?, time<=?, time-difference!): Use
'time-compare-check' to check the arguments.
This commit is contained in:
Mark H Weaver 2018-10-21 19:38:18 -04:00
parent 437e1aa036
commit c9d903b6e4
1 changed files with 12 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -374,35 +374,39 @@
(else (time-error 'time-resolution 'invalid-clock-type clock-type)))))
;; -- Time comparisons
(define (time-compare-check t1 t2 caller)
(unless (and (time? t1) (time? t2)
(eq? (time-type t1) (time-type t2)))
(time-error caller 'incompatible-time-types (cons t1 t2))))
(define (time=? t1 t2)
;; Arrange tests for speed and presume that t1 and t2 are actually times.
;; also presume it will be rare to check two times of different types.
(time-compare-check t1 t2 'time=?)
(and (= (time-second t1) (time-second t2))
(= (time-nanosecond t1) (time-nanosecond t2))
;; XXX The SRFI-19 reference implementation raises an error in
;; case of unequal time types. Here we return #false.
(eq? (time-type t1) (time-type t2))))
;; XXX In the following comparison procedures, the SRFI-19 reference
;; implementation raises an error in case of unequal time types.
(= (time-nanosecond t1) (time-nanosecond t2))))
(define (time>? t1 t2)
(time-compare-check t1 t2 'time>?)
(or (> (time-second t1) (time-second t2))
(and (= (time-second t1) (time-second t2))
(> (time-nanosecond t1) (time-nanosecond t2)))))
(define (time<? t1 t2)
(time-compare-check t1 t2 'time<?)
(or (< (time-second t1) (time-second t2))
(and (= (time-second t1) (time-second t2))
(< (time-nanosecond t1) (time-nanosecond t2)))))
(define (time>=? t1 t2)
(time-compare-check t1 t2 'time>=?)
(or (> (time-second t1) (time-second t2))
(and (= (time-second t1) (time-second t2))
(>= (time-nanosecond t1) (time-nanosecond t2)))))
(define (time<=? t1 t2)
(time-compare-check t1 t2 'time<=?)
(or (< (time-second t1) (time-second t2))
(and (= (time-second t1) (time-second t2))
(<= (time-nanosecond t1) (time-nanosecond t2)))))
@ -413,6 +417,7 @@
;; implementation raises an error in case of unequal time types.
(define (time-difference! time1 time2)
(time-compare-check time1 time2 'time-difference!)
(let ((sec-diff (- (time-second time1) (time-second time2)))
(nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
(set-time-type! time1 time-duration)