diff --git a/devel/210_15.md b/devel/210_15.md new file mode 100644 index 00000000..5ada9e35 --- /dev/null +++ b/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 +``` + + diff --git a/goldfish/srfi/srfi-19.scm b/goldfish/srfi/srfi-19.scm index 532e20a9..70ff4b05 100644 --- a/goldfish/srfi/srfi-19.scm +++ b/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 diff --git a/tests/goldfish/liii/time-test.scm b/tests/goldfish/liii/time-test.scm index b228148f..011b8dba 100644 --- a/tests/goldfish/liii/time-test.scm +++ b/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 ;; ====================