From 670c928694dd662fc01798c7101b1362c0f80491 Mon Sep 17 00:00:00 2001 From: JackChen <17683835261@163.com> Date: Thu, 12 Feb 2026 15:48:33 +0800 Subject: [PATCH 1/4] =?UTF-8?q?=E6=B5=8B=E8=AF=95=E7=94=A8=E4=BE=8B?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- goldfish/srfi/srfi-19.scm | 22 ++++--- tests/goldfish/liii/time-test.scm | 103 ++++++++++++++++++++++++++++++ 2 files changed, 116 insertions(+), 9 deletions(-) diff --git a/goldfish/srfi/srfi-19.scm b/goldfish/srfi/srfi-19.scm index 7fde8c4b..34e1b0d6 100644 --- a/goldfish/srfi/srfi-19.scm +++ b/goldfish/srfi/srfi-19.scm @@ -418,16 +418,20 @@ ;; Time/Date/Julian Day/Modified Julian Day Converters ;; ==================== - (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))) + ;; Howard Hinnant's days_from_civil algorithm, inverse of civil-from-days + (let* ((y (- year (if (<= month 2) 1 0))) + (era (if (>= y 0) + (floor-quotient y 400) + (floor-quotient (- y 399) 400))) + (yoe (- y (* era 400))) + (m (+ month (if (> month 2) -3 9))) ; March=0, ..., February=11 + (doy (+ (floor-quotient (+ (* 153 m) 2) 5) (- day 1))) + (doe (+ (* yoe 365) + (floor-quotient yoe 4) + (- (floor-quotient yoe 100)) + doy))) + (- (+ (* era 146097) doe) 719468))) (define (priv:civil-from-days days) ;; Howard Hinnant's algorithm, adapted for proleptic Gregorian calendar diff --git a/tests/goldfish/liii/time-test.scm b/tests/goldfish/liii/time-test.scm index d021e9a3..da059f54 100644 --- a/tests/goldfish/liii/time-test.scm +++ b/tests/goldfish/liii/time-test.scm @@ -849,6 +849,37 @@ time-utc->date date->time-utc 将日期对象转换为 TIME-UTC 时间对象。 + +语法 +---- +(time-utc->date time-utc [tz-offset]) +(date->time-utc date) + +参数 +---- +time-utc : time? +必须是 TIME-UTC 类型的时间对象。 + +tz-offset : integer? (可选) +时区偏移（秒），默认 0 表示 UTC。 + +date : date? +日期对象。 + +返回值 +----- +time-utc->date : date? +date->time-utc : time? + +说明 +---- +1. time-utc->date 将 UTC 时间按 tz-offset 转换成本地日期。 +2. date->time-utc 将本地日期按 date 的 zone-offset 转回 UTC 时间。 + +错误处理 +-------- +wrong-type-arg +当参数类型不正确，或 time-utc 不是 TIME-UTC 时抛出错误。 |# ;; time-utc->date basic (UTC) @@ -933,6 +964,78 @@ date->time-utc (check (date-nanosecond d2) => (date-nanosecond d1)) (check (date-zone-offset d2) => (date-zone-offset d1))) +;; 2000-02-29 leap day round-trip (UTC) +(let* ((d1 (make-date 0 0 0 0 29 2 2000 0)) + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 2000) + (check (date-month d2) => 2) + (check (date-day d2) => 29)) + +;; additional leap year boundary cases (UTC) +(let* ((d1 (make-date 0 0 0 0 28 2 1900 0)) ; 1900 is not a leap year + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 1900) + (check (date-month d2) => 2) + (check (date-day d2) => 28)) + +(let* ((d1 (make-date 0 0 0 0 1 3 1900 0)) + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 1900) + (check (date-month d2) => 3) + (check (date-day d2) => 1)) + +(let* ((d1 (make-date 0 0 0 0 29 2 2004 0)) ; regular leap year + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 2004) + (check (date-month d2) => 2) + (check (date-day d2) => 29)) + +(let* ((d1 (make-date 0 0 0 0 28 2 2100 0)) ; 2100 is not a leap year + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 2100) + (check (date-month d2) => 2) + (check (date-day d2) => 28)) + +(let* ((d1 (make-date 0 0 0 0 1 3 2100 0)) + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 2100) + (check (date-month d2) => 3) + (check (date-day d2) => 1)) + +(let* ((d1 (make-date 0 0 0 0 29 2 2400 0)) ; 2400 is a leap year + (t (date->time-utc d1)) + (d2 (time-utc->date t 0))) + (check (date-year d2) => 2400) + (check (date-month d2) => 2) + (check (date-day d2) => 29)) + +;; time-utc -> date -> time-utc round-trip cases +(let* ((t1 (make-time TIME-UTC 0 0)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check (time=? t1 t2) => #t)) + +(let* ((t1 (make-time TIME-UTC 123456789 98765)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check (time=? t1 t2) => #t)) + +(let* ((t1 (make-time TIME-UTC 500000000 -12345)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check (time=? t1 t2) => #t)) + +(let* ((t1 (make-time TIME-UTC 0 1704067200)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check (time=? t1 t2) => #t)) + ;; converter error conditions (check-catch 'wrong-type-arg (time-utc->date (make-time TIME-TAI 0 0) 0)) From bdbb22f81c08b42c99d00581cab9dd010e14c945 Mon Sep 17 00:00:00 2001 From: JackChen <17683835261@163.com> Date: Thu, 12 Feb 2026 16:44:36 +0800 Subject: [PATCH 2/4] todo --- goldfish/srfi/srfi-19.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/goldfish/srfi/srfi-19.scm b/goldfish/srfi/srfi-19.scm index 34e1b0d6..95b75721 100644 --- a/goldfish/srfi/srfi-19.scm +++ b/goldfish/srfi/srfi-19.scm @@ -454,6 +454,8 @@ (y (if (<= m 2) (+ y 1) y))) (values y m d))) + ;; TODO: spec says default tz-offset should be local time zone. + ;; We don't have a local tz interface yet, so default is 0 (UTC). (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)) From 875c69ea7c5cfc43a967fe5abbed1d5f06ece230 Mon Sep 17 00:00:00 2001 From: JackChen <17683835261@163.com> Date: Thu, 12 Feb 2026 16:46:30 +0800 Subject: [PATCH 3/4] =?UTF-8?q?=E6=96=87=E6=A1=A3?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- devel/210_15.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/devel/210_15.md b/devel/210_15.md index 5ada9e35..da986b66 100644 --- a/devel/210_15.md +++ b/devel/210_15.md @@ -1,5 +1,7 @@ # [210_15] srfi-19 time-utc date相互转化实现 +## 修改 srfi-19 time-utc date相互转化实现，添加测试 + ## 添加 srfi-19 time-utc date相互转化实现 ## 如何测试 From 0862a4dca49e04a2ef351d6e51f9015080d9bf96 Mon Sep 17 00:00:00 2001 From: JackChen <17683835261@163.com> Date: Thu, 12 Feb 2026 17:20:26 +0800 Subject: [PATCH 4/4] check-true --- tests/goldfish/liii/time-test.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/goldfish/liii/time-test.scm b/tests/goldfish/liii/time-test.scm index da059f54..1a2fd2b2 100644 --- a/tests/goldfish/liii/time-test.scm +++ b/tests/goldfish/liii/time-test.scm @@ -1019,22 +1019,22 @@ wrong-type-arg (let* ((t1 (make-time TIME-UTC 0 0)) (d (time-utc->date t1)) (t2 (date->time-utc d))) - (check (time=? t1 t2) => #t)) + (check-true (time=? t1 t2))) (let* ((t1 (make-time TIME-UTC 123456789 98765)) (d (time-utc->date t1)) (t2 (date->time-utc d))) - (check (time=? t1 t2) => #t)) + (check-true (time=? t1 t2))) (let* ((t1 (make-time TIME-UTC 500000000 -12345)) (d (time-utc->date t1)) (t2 (date->time-utc d))) - (check (time=? t1 t2) => #t)) + (check-true (time=? t1 t2))) (let* ((t1 (make-time TIME-UTC 0 1704067200)) (d (time-utc->date t1)) (t2 (date->time-utc d))) - (check (time=? t1 t2) => #t)) + (check-true (time=? t1 t2))) ;; converter error conditions (check-catch 'wrong-type-arg