[210_15] srfi-19 time-utc date相互转化实现

devel/210_15.md

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

goldfish/srfi/srfi-19.scm

@@ -75,6 +75,7 @@
     date-nanosecond date-second date-minute date-hour
     date-day        date-month  date-year   date-zone-offset
     ;; Time/Date/Julian Day/Modified Julian Day Converters
+    time-utc->date date->time-utc
     ;; Date to String/String to Date Converters
     date->string)
   (begin
@@ -415,7 +416,63 @@
     ;; Time/Date/Julian Day/Modified Julian Day Converters
     ;; ====================
 
-    ;; TODO
+    (define (priv:days-before-year year)
+      (+ (* 365 year)
+         (floor-quotient year 4)
+         (- (floor-quotient year 100))
+         (floor-quotient year 400)))
+
+    (define (priv:days-since-epoch year month day)
+      (+ (- (priv:days-before-year year)
+            (priv:days-before-year 1970))
+         (- (priv:year-day day month year) 1)))
+
+    (define (priv:civil-from-days days)
+      ;; Howard Hinnant's algorithm, adapted for proleptic Gregorian calendar
+      (let* ((z (+ days 719468))
+             (era (if (>= z 0)
+                    (floor-quotient z 146097)
+                    (floor-quotient (- z 146096) 146097)))
+             (doe (- z (* era 146097))) ; [0, 146096]
+             (yoe (floor-quotient (- doe (floor-quotient doe 1460)
+                                    (- (floor-quotient doe 36524))
+                                    (floor-quotient doe 146096))
+                                  365))
+             (y (+ yoe (* era 400)))
+             (doy (- doe (+ (* 365 yoe)
+                            (floor-quotient yoe 4)
+                            (- (floor-quotient yoe 100)))))
+             (mp (floor-quotient (+ (* 5 doy) 2) 153))
+             (d (+ (- doy (floor-quotient (+ (* 153 mp) 2) 5)) 1))
+             (m (+ mp (if (< mp 10) 3 -9)))
+             (y (if (<= m 2) (+ y 1) y)))
+        (values y m d)))
+
+    (define* (time-utc->date time-utc (tz-offset 0))
+      (unless (and (time? time-utc) (eq? (time-type time-utc) TIME-UTC))
+        (error 'wrong-type-arg "time-utc->date: time-utc must be a TIME-UTC object" time-utc))
+      (unless (integer? tz-offset)
+        (error 'wrong-type-arg "time-utc->date: tz-offset must be an integer" tz-offset))
+      (let* ((sec (+ (time-second time-utc) tz-offset))
+             (nsec (time-nanosecond time-utc)))
+        (receive (days day-sec) (floor/ sec priv:SID)
+          (receive (year month day) (priv:civil-from-days days)
+            (receive (hour rem1) (floor/ day-sec 3600)
+              (receive (minute second) (floor/ rem1 60)
+                (make-date nsec second minute hour day month year tz-offset)))))))
+
+    (define (date->time-utc date)
+      (unless (date? date)
+        (error 'wrong-type-arg "date->time-utc: date must be a date object" date))
+      (let* ((days (priv:days-since-epoch (date-year date)
+                                          (date-month date)
+                                          (date-day date)))
+             (local-sec (+ (* days priv:SID)
+                           (* (date-hour date) 3600)
+                           (* (date-minute date) 60)
+                           (date-second date)))
+             (utc-sec (- local-sec (date-zone-offset date))))
+        (make-time TIME-UTC (date-nanosecond date) utc-sec)))
 
     ;; ====================
     ;; Date to String/String to Date Converters

tests/goldfish/liii/time-test.scm

@@ -807,6 +807,108 @@ wrong-type-arg
 (check-true  (undefined? (date-year (make-time TIME-UTC 0 0))))
 (check-catch 'wrong-type-arg (date-zone-offset #f))
 
+;; ====================
+;; Time/Date Converters
+;; ====================
+
+#|
+time-utc->date
+将 TIME-UTC 时间对象转换为日期对象。
+
+date->time-utc
+将日期对象转换为 TIME-UTC 时间对象。
+|#
+
+;; time-utc->date basic (UTC)
+(let* ((t (make-time TIME-UTC 0 0))
+       (d (time-utc->date t 0)))
+  (check (date-year d) => 1970)
+  (check (date-month d) => 1)
+  (check (date-day d) => 1)
+  (check (date-hour d) => 0)
+  (check (date-minute d) => 0)
+  (check (date-second d) => 0)
+  (check (date-zone-offset d) => 0))
+
+;; time-utc->date with positive tz offset (+8)
+(let* ((t (make-time TIME-UTC 0 0))
+       (d (time-utc->date t 28800)))
+  (check (date-year d) => 1970)
+  (check (date-month d) => 1)
+  (check (date-day d) => 1)
+  (check (date-hour d) => 8)
+  (check (date-minute d) => 0)
+  (check (date-second d) => 0)
+  (check (date-zone-offset d) => 28800))
+
+;; time-utc->date with negative tz offset (-1 hour)
+(let* ((t (make-time TIME-UTC 0 0))
+       (d (time-utc->date t -3600)))
+  (check (date-year d) => 1969)
+  (check (date-month d) => 12)
+  (check (date-day d) => 31)
+  (check (date-hour d) => 23)
+  (check (date-minute d) => 0)
+  (check (date-second d) => 0)
+  (check (date-zone-offset d) => -3600))
+
+;; time-utc->date before 1970
+(let* ((t (make-time TIME-UTC 0 -1))
+       (d (time-utc->date t 0)))
+  (check (date-year d) => 1969)
+  (check (date-month d) => 12)
+  (check (date-day d) => 31)
+  (check (date-hour d) => 23)
+  (check (date-minute d) => 59)
+  (check (date-second d) => 59))
+
+;; time-utc->date negative day boundaries
+(let* ((t (make-time TIME-UTC 0 -86400))
+       (d (time-utc->date t 0)))
+  (check (date-year d) => 1969)
+  (check (date-month d) => 12)
+  (check (date-day d) => 31)
+  (check (date-hour d) => 0)
+  (check (date-minute d) => 0)
+  (check (date-second d) => 0))
+
+(let* ((t (make-time TIME-UTC 0 -86401))
+       (d (time-utc->date t 0)))
+  (check (date-year d) => 1969)
+  (check (date-month d) => 12)
+  (check (date-day d) => 30)
+  (check (date-hour d) => 23)
+  (check (date-minute d) => 59)
+  (check (date-second d) => 59))
+
+;; date->time-utc basic
+(let* ((d (make-date 0 0 0 8 1 1 1970 28800))
+       (t (date->time-utc d)))
+  (check (time-type t) => TIME-UTC)
+  (check (time-second t) => 0)
+  (check (time-nanosecond t) => 0))
+
+;; round-trip date -> time -> date with same tz-offset
+(let* ((d1 (make-date 123456789 45 30 14 25 12 2023 28800))
+       (t (date->time-utc d1))
+       (d2 (time-utc->date t (date-zone-offset d1))))
+  (check (date-year d2) => (date-year d1))
+  (check (date-month d2) => (date-month d1))
+  (check (date-day d2) => (date-day d1))
+  (check (date-hour d2) => (date-hour d1))
+  (check (date-minute d2) => (date-minute d1))
+  (check (date-second d2) => (date-second d1))
+  (check (date-nanosecond d2) => (date-nanosecond d1))
+  (check (date-zone-offset d2) => (date-zone-offset d1)))
+
+;; converter error conditions
+(check-catch 'wrong-type-arg
+  (time-utc->date (make-time TIME-TAI 0 0) 0))
+(check-catch 'wrong-type-arg
+  (time-utc->date (make-time TIME-UTC 0 0) "bad-offset"))
+(check-catch 'wrong-type-arg
+  (date->time-utc "not-a-date"))
+
 ;; ====================
 ;; Date to String/String to Date Converters
 ;; ====================