[210_14] srfi-19 time compare实现

devel/210_14.md

@@ -0,0 +1,15 @@
+# [210_14] srfi-19 time compare实现
+
+## 添加 srfi-19 time compare实现
+
+## 如何测试
+
+```shell
+# 可能需要清除缓存
+# rm .xmake/ build/ -r
+xmake f -vyD
+xmake b goldfish
+./bin/goldfish tests/goldfish/liii/time-test.scm
+```
+
+

goldfish/srfi/srfi-19.scm

@@ -65,6 +65,7 @@
     set-time-type! set-time-nanosecond! set-time-second!
     copy-time
     ;; Time comparison procedures
+    time<=? time<? time=? time>=? time>?
     ;; Time arithmetic procedures
     time-difference
     ;; Current time and clock resolution
@@ -150,7 +151,37 @@
     ;; Time comparison procedures
     ;; ====================
 
-    ;; TODO
+    (define (priv:check-same-time-type time1 time2)
+      (unless (and (time? time1) (time? time2))
+        (error 'wrong-type-arg "time comparison: time1 and time2 must be time objects"
+               (list time1 time2)))
+      (unless (eq? (time-type time1) (time-type time2))
+        (error 'wrong-type-arg "time comparison: time types must match"
+               (list (time-type time1) (time-type time2)))))
+
+    (define (priv:time-compare time1 time2)
+      (priv:check-same-time-type time1 time2)
+      (let ((delta (- (priv:time->nanoseconds time1)
+                      (priv:time->nanoseconds time2))))
+        (cond
+          ((< delta 0) -1)
+          ((> delta 0) 1)
+          (else 0))))
+
+    (define (time<? time1 time2)
+      (< (priv:time-compare time1 time2) 0))
+
+    (define (time<=? time1 time2)
+      (<= (priv:time-compare time1 time2) 0))
+
+    (define (time=? time1 time2)
+      (= (priv:time-compare time1 time2) 0))
+
+    (define (time>=? time1 time2)
+      (>= (priv:time-compare time1 time2) 0))
+
+    (define (time>? time1 time2)
+      (> (priv:time-compare time1 time2) 0))
 
     ;; ====================
     ;; Time arithmetic procedures

tests/goldfish/liii/time-test.scm

@@ -392,6 +392,55 @@ wrong-type-arg
 (check-catch 'wrong-type-arg
   (time-difference "not-time" (make-time TIME-UTC 0 0)))
 
+#|
+time<=? time<? time=? time>=? time>?
+比较两个时间对象的大小。
+
+语法
+----
+(time<=? time1 time2)
+(time<?  time1 time2)
+(time=?  time1 time2)
+(time>=? time1 time2)
+(time>?  time1 time2)
+
+参数
+----
+time1 : time?
+time2 : time?
+两个时间对象，时间类型必须相同。
+
+返回值
+-----
+boolean?
+返回比较结果。
+
+错误处理
+--------
+wrong-type-arg
+当参数不是时间对象或时间类型不匹配时抛出错误。
+|#
+
+;; Test time comparison
+(let* ((t1 (make-time TIME-UTC 100 5))
+       (t2 (make-time TIME-UTC 100 5))
+       (t3 (make-time TIME-UTC 200 5))
+       (t4 (make-time TIME-UTC 0 6)))
+  (check (time=? t1 t2) => #t)
+  (check (time<? t1 t3) => #t)
+  (check (time<=? t1 t3) => #t)
+  (check (time>? t4 t3) => #t)
+  (check (time>=? t4 t3) => #t)
+  (check (time<? t3 t1) => #f)
+  (check (time>? t1 t4) => #f))
+
+;; Test comparison error conditions
+(check-catch 'wrong-type-arg
+  (time<? (make-time TIME-UTC 0 0)
+          (make-time TIME-TAI 0 0)))
+(check-catch 'wrong-type-arg
+  (time=? "not-time" (make-time TIME-UTC 0 0)))
+
 ;; Test error conditions
 (check-catch 'wrong-type-arg (time-type "not-a-time"))
 (check-catch 'wrong-type-arg (time-nanosecond 123))