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相互转化实现 ## 如何测试 diff --git a/goldfish/srfi/srfi-19.scm b/goldfish/srfi/srfi-19.scm index 7fde8c4b..95b75721 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 @@ -450,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)) diff --git a/tests/goldfish/liii/time-test.scm b/tests/goldfish/liii/time-test.scm index d021e9a3..1a2fd2b2 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-true (time=? t1 t2))) + +(let* ((t1 (make-time TIME-UTC 123456789 98765)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check-true (time=? t1 t2))) + +(let* ((t1 (make-time TIME-UTC 500000000 -12345)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check-true (time=? t1 t2))) + +(let* ((t1 (make-time TIME-UTC 0 1704067200)) + (d (time-utc->date t1)) + (t2 (date->time-utc d))) + (check-true (time=? t1 t2))) + ;; converter error conditions (check-catch 'wrong-type-arg (time-utc->date (make-time TIME-TAI 0 0) 0))