From: Mark H Weaver <mhw@netris.org>
Date: Sun, 21 Oct 2018 23:38:18 +0000 (-0400)
Subject: SRFI-19: Check for incompatible types in time comparisons.
X-Git-Tag: v2.9.2~2^2~35
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=c9d903b6e4f8cc1d8382b20a2f0502c4ce8ffe0a;p=platform%2Fupstream%2Fguile.git

SRFI-19: Check for incompatible types in time comparisons.

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

diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index ba1327c9f..2f5f322df 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -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)