[Guile-commits] 01/01: SRFI-19: Check for incompatible types in time comparisons.

[Mark H. Weaver]

mhw pushed a commit to branch stable-2.2
in repository guile.

commit c9d903b6e4f8cc1d8382b20a2f0502c4ce8ffe0a
Author: Mark H Weaver <address@hidden>
Date:   Sun Oct 21 19:38:18 2018 -0400

    SRFI-19: Check for incompatible types in time comparisons.
    
    Fixes <https://bugs.gnu.org/26163>.
    Reported by Zefram <address@hidden>.
    
    * 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.
---
 module/srfi/srfi-19.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index ba1327c..2f5f322 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)