On 2013-01-11 15:39:08 -0600, Robby Findler wrote: > I think it would be great if you were to find backwards-compatible > ways to bring these two a little bit closer. Making them use the > same internal date struct, for example, would be a great thing.
I wrote a patch to make both of these use the same structure, attached to the e-mail. It seems to pass all of the srfi-19 and date tests (with some tests changed where appropriate). Does it look alright? It turns out there was one (sort of) good reason for SRFI-19 to define its own struct type: it used mutation for several functions. Racket's date/date* are immutable. I just changed these to use functional update. Another thing: when a string is converted to a date, it's possible that the format string only has time-of-day but no date specification. Previously, this produced a srfi/19 date with '#t's but I've now defaulted it to the start day of the Unix epoch (arbitrarily). Cheers, Asumu
>From 9ab3a4d77ec1c16a9148690b85d6e7924aaf105d Mon Sep 17 00:00:00 2001 From: Asumu Takikawa <as...@ccs.neu.edu> Date: Fri, 11 Jan 2013 21:06:01 -0500 Subject: [PATCH] Make srfi/19 compatible with date* structs --- collects/srfi/19/time.rkt | 183 +++++++++++++++++++------------------- collects/tests/srfi/19/tests.rkt | 36 ++++---- 2 files changed, 109 insertions(+), 110 deletions(-) diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt index bac5a33..54ce061 100644 --- a/collects/srfi/19/time.rkt +++ b/collects/srfi/19/time.rkt @@ -79,7 +79,6 @@ ;; Date object and accessors ;; date structure is provided by core Racket, we just extended tu support miliseconds: srfi:make-date srfi:date? - deserialize-info:tm:date-v0 date-nanosecond srfi:date-second srfi:date-minute srfi:date-hour srfi:date-day srfi:date-month srfi:date-year date-zone-offset ;; This are not part of the date structure (as they are in the original Racket's date) @@ -608,40 +607,24 @@ time-in) ;; -- Date Structures -(define-values (tm:date srfi:make-date srfi:date? tm:date-ref tm:date-set!) - (make-struct-type - 'tm:date #f 8 0 #f - (list (cons prop:serializable - (make-serialize-info - (lambda (d) - (vector (date-nanosecond d) - (srfi:date-second d) - (srfi:date-minute d) - (srfi:date-hour d) - (srfi:date-day d) - (srfi:date-month d) - (srfi:date-year d) - (date-zone-offset d))) - #'deserialize-info:tm:date-v0 - #f - (or (current-load-relative-directory) - (current-directory))))) - (make-inspector) #f null)) -(define deserialize-info:tm:date-v0 - (make-deserialize-info - srfi:make-date - (lambda () - (let ([d0 (srfi:make-date #f #f #f #f #f #f #f #f)]) - (values d0 (lambda (d1) - (tm:set-date-nanosecond! d1 (date-nanosecond d0)) - (tm:set-date-second! d1 (srfi:date-second d0)) - (tm:set-date-minute! d1 (srfi:date-minute d0)) - (tm:set-date-hour! d1 (srfi:date-hour d0)) - (tm:set-date-day! d1 (srfi:date-day d0)) - (tm:set-date-month! d1 (srfi:date-month d0)) - (tm:set-date-year! d1 (srfi:date-year d0)) - (tm:set-date-zone-offset! d1 (date-zone-offset d0)))))))) +;; These identifiers originally referred to a separate date type, +;; but they now use Racket's native date type +(define (srfi:make-date nanosecond second minute + hour day month + year zone-offset) + (date* second minute + hour day month + year + ;; compute derived fields + (tm:week-day day month year) + (tm:year-day day month year) + #f + zone-offset + nanosecond + "")) + +(define srfi:date? date?) ;; Racket's date structure has the following: ;; * second : 0 to 61 (60 and 61 are for unusual leap-seconds) @@ -655,23 +638,14 @@ ;; * dst? : #t (daylight savings time) or #f ;; * time-zone-offset : the number of seconds east of GMT for this time zone (e.g., Pacific Standard Time is -28800), an exact integer 36 -(define (date-nanosecond d) (tm:date-ref d 0)) -(define (srfi:date-second d) (tm:date-ref d 1)) -(define (srfi:date-minute d) (tm:date-ref d 2)) -(define (srfi:date-hour d) (tm:date-ref d 3)) -(define (srfi:date-day d) (tm:date-ref d 4)) -(define (srfi:date-month d) (tm:date-ref d 5)) -(define (srfi:date-year d) (tm:date-ref d 6)) -(define (date-zone-offset d) (tm:date-ref d 7)) - -(define (tm:set-date-nanosecond! d ns) (tm:date-set! d 0 ns)) -(define (tm:set-date-second! d s) (tm:date-set! d 1 s)) -(define (tm:set-date-minute! d m) (tm:date-set! d 2 m)) -(define (tm:set-date-hour! d h) (tm:date-set! d 3 h)) -(define (tm:set-date-day! d day) (tm:date-set! d 4 day)) -(define (tm:set-date-month! d m) (tm:date-set! d 5 m)) -(define (tm:set-date-year! d y) (tm:date-set! d 6 y)) -(define (tm:set-date-zone-offset! d i) (tm:date-set! d 7 i)) +(define date-nanosecond date*-nanosecond) +(define srfi:date-second date-second) +(define srfi:date-minute date-minute) +(define srfi:date-hour date-hour) +(define srfi:date-day date-day) +(define srfi:date-month date-month) +(define srfi:date-year date-year) +(define date-zone-offset date-time-zone-offset) ;; gives the julian day which starts at noon. (define (tm:encode-julian-day-number day month year) @@ -774,9 +748,10 @@ (define (time-tai->date time . tz-offset) (if (tm:tai-before-leap-second? (time-second time)) ;; if it's *right* before the leap, we need to pretend to subtract a second ... - (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) (make-time time-duration 0 1)) tz-offset time-utc))) - (tm:set-date-second! d 60) - d) + (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) + (make-time time-duration 0 1)) + tz-offset time-utc))) + (struct-copy date* d [second #:parent date 60])) (tm:time->date (time-tai->time-utc time) tz-offset time-utc))) (define (time-utc->date time . tz-offset) @@ -1454,46 +1429,58 @@ (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) (list #\b char-alphabetic? locale-reader-abbr-month (lambda (val object) - (tm:set-date-month! object val))) + (struct-copy date* object [month #:parent date val]))) (list #\B char-alphabetic? locale-reader-long-month (lambda (val object) - (tm:set-date-month! object val))) - (list #\d char-numeric? ireader2 (lambda (val object) - (tm:set-date-day! - object val))) - (list #\e char-fail eireader2 (lambda (val object) - (tm:set-date-day! object val))) + (struct-copy date* object [month #:parent date val]))) + (list #\d char-numeric? ireader2 + (lambda (val object) + (struct-copy date* object [day #:parent date val]))) + (list #\e char-fail eireader2 + (lambda (val object) + (struct-copy date* object [day #:parent date val]))) (list #\h char-alphabetic? locale-reader-abbr-month (lambda (val object) - (tm:set-date-month! object val))) - (list #\H char-numeric? ireader2 (lambda (val object) - (tm:set-date-hour! object val))) - (list #\k char-fail eireader2 (lambda (val object) - (tm:set-date-hour! object val))) - (list #\m char-numeric? ireader2 (lambda (val object) - (tm:set-date-month! object val))) - (list #\M char-numeric? ireader2 (lambda (val object) - (tm:set-date-minute! - object val))) - (list #\N char-numeric? fireader9 (lambda (val object) - (tm:set-date-nanosecond! object val))) - (list #\S char-numeric? ireader2 (lambda (val object) - (tm:set-date-second! object val))) + (struct-copy date* object [month #:parent date val]))) + (list #\H char-numeric? ireader2 + (lambda (val object) + (struct-copy date* object [hour #:parent date val]))) + (list #\k char-fail eireader2 + (lambda (val object) + (struct-copy date* object [hour #:parent date val]))) + (list #\m char-numeric? ireader2 + (lambda (val object) + (struct-copy date* object [month #:parent date val]))) + (list #\M char-numeric? ireader2 + (lambda (val object) + (struct-copy date* object [minute #:parent date val]))) + (list #\N char-numeric? fireader9 + (lambda (val object) + (struct-copy date* object [nanosecond val]))) + (list #\S char-numeric? ireader2 + (lambda (val object) + (struct-copy date* object [second #:parent date val]))) (list #\y char-fail eireader2 (lambda (val object) - (tm:set-date-year! object (tm:natural-year val)))) - (list #\Y char-numeric? ireader4 (lambda (val object) - (tm:set-date-year! object val))) + (struct-copy date* object + [year #:parent date (tm:natural-year val)]))) + (list #\Y char-numeric? ireader4 + (lambda (val object) + (struct-copy date* object [year #:parent date val]))) (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) - tm:zone-reader (lambda (val object) - (tm:set-date-zone-offset! object val))) + tm:zone-reader + (lambda (val object) + (struct-copy date* object + [time-zone-offset #:parent date val]))) ; PLT-specific extension for 2- or 4-digit years: - (list #\? char-numeric? ireader4 (lambda (val object) - (tm:set-date-year! object (tm:natural-year val)))) + (list #\? char-numeric? ireader4 + (lambda (val object) + (struct-copy date* object + [year #:parent date (tm:natural-year val)]))) ))) (define (tm:string->date date index format-string str-len port template-string) @@ -1505,8 +1492,7 @@ (read-char port) (skip-until port skipper))))) (if (>= index str-len) - (begin - (values)) + date (let ( (current-char (string-ref format-string index)) ) (if (not (char=? current-char #\~)) (let ((port-char (read-char port))) @@ -1526,11 +1512,13 @@ (reader (caddr format-info)) (actor (cadddr format-info))) (skip-until port skipper) - (let ((val (reader port))) - (if (eof-object? val) - (tm:time-error 'string->date 'bad-date-format-string template-string) - (actor val date))) - (tm:string->date date (+ index 2) format-string str-len port template-string)))))))))) + (define new-date + (let ((val (reader port))) + (if (eof-object? val) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (actor val date)))) + (tm:string->date new-date (+ index 2) format-string str-len port template-string)))))))))) + (define (string->date input-string template-string) (define (tm:date-ok? date) @@ -1542,13 +1530,24 @@ (srfi:date-month date) (srfi:date-year date) (date-zone-offset date))) - (let ( (newdate (srfi:make-date 0 0 0 0 #t #t #t (tm:local-tz-offset))) ) - (tm:string->date newdate + (let* ([initial (srfi:make-date 0 0 0 0 1 1 1970 (tm:local-tz-offset))] + [read-date (tm:string->date + initial 0 template-string (string-length template-string) (open-input-string input-string) - template-string) + template-string)] + ;; re-compute week & year + [week-day (tm:week-day (date-day read-date) + (date-month read-date) + (date-year read-date))] + [year-day (tm:year-day (date-day read-date) + (date-month read-date) + (date-year read-date))] + [newdate (struct-copy date* read-date + [week-day #:parent date week-day] + [year-day #:parent date year-day])]) (if (tm:date-ok? newdate) newdate (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) diff --git a/collects/tests/srfi/19/tests.rkt b/collects/tests/srfi/19/tests.rkt index cdd3b63..2cd7357 100644 --- a/collects/tests/srfi/19/tests.rkt +++ b/collects/tests/srfi/19/tests.rkt @@ -161,24 +161,24 @@ (check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 0) "~N") "000000001")) (test-case "string->date conversions of dates with nanosecond components" - (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t cur-tz) "check 1") - (check-equal? (string->date "12:00:00.12345678" "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 #t #t #t cur-tz) "check 2") - (check-equal? (string->date "12:00:00.1234567" "~H:~M:~S.~N") (srfi:make-date 123456700 0 0 12 #t #t #t cur-tz) "check 3") - (check-equal? (string->date "12:00:00.123456" "~H:~M:~S.~N") (srfi:make-date 123456000 0 0 12 #t #t #t cur-tz) "check 4") - (check-equal? (string->date "12:00:00.12345" "~H:~M:~S.~N") (srfi:make-date 123450000 0 0 12 #t #t #t cur-tz) "check 5") - (check-equal? (string->date "12:00:00.1234" "~H:~M:~S.~N") (srfi:make-date 123400000 0 0 12 #t #t #t cur-tz) "check 6") - (check-equal? (string->date "12:00:00.123" "~H:~M:~S.~N") (srfi:make-date 123000000 0 0 12 #t #t #t cur-tz) "check 7") - (check-equal? (string->date "12:00:00.12" "~H:~M:~S.~N") (srfi:make-date 120000000 0 0 12 #t #t #t cur-tz) "check 8") - (check-equal? (string->date "12:00:00.1" "~H:~M:~S.~N") (srfi:make-date 100000000 0 0 12 #t #t #t cur-tz) "check 9") - (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t cur-tz) "check 10") - (check-equal? (string->date "12:00:00.012345678" "~H:~M:~S.~N") (srfi:make-date 12345678 0 0 12 #t #t #t cur-tz) "check 11") - (check-equal? (string->date "12:00:00.001234567" "~H:~M:~S.~N") (srfi:make-date 1234567 0 0 12 #t #t #t cur-tz) "check 12") - (check-equal? (string->date "12:00:00.000123456" "~H:~M:~S.~N") (srfi:make-date 123456 0 0 12 #t #t #t cur-tz) "check 13") - (check-equal? (string->date "12:00:00.000012345" "~H:~M:~S.~N") (srfi:make-date 12345 0 0 12 #t #t #t cur-tz) "check 14") - (check-equal? (string->date "12:00:00.000001234" "~H:~M:~S.~N") (srfi:make-date 1234 0 0 12 #t #t #t cur-tz) "check 15") - (check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (srfi:make-date 123 0 0 12 #t #t #t cur-tz) "check 16") - (check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (srfi:make-date 12 0 0 12 #t #t #t cur-tz) "check 17") - (check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (srfi:make-date 1 0 0 12 #t #t #t cur-tz) "check 18")) + (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 1 1 1970 cur-tz) "check 1") + (check-equal? (string->date "12:00:00.12345678" "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 1 1 1970 cur-tz) "check 2") + (check-equal? (string->date "12:00:00.1234567" "~H:~M:~S.~N") (srfi:make-date 123456700 0 0 12 1 1 1970 cur-tz) "check 3") + (check-equal? (string->date "12:00:00.123456" "~H:~M:~S.~N") (srfi:make-date 123456000 0 0 12 1 1 1970 cur-tz) "check 4") + (check-equal? (string->date "12:00:00.12345" "~H:~M:~S.~N") (srfi:make-date 123450000 0 0 12 1 1 1970 cur-tz) "check 5") + (check-equal? (string->date "12:00:00.1234" "~H:~M:~S.~N") (srfi:make-date 123400000 0 0 12 1 1 1970 cur-tz) "check 6") + (check-equal? (string->date "12:00:00.123" "~H:~M:~S.~N") (srfi:make-date 123000000 0 0 12 1 1 1970 cur-tz) "check 7") + (check-equal? (string->date "12:00:00.12" "~H:~M:~S.~N") (srfi:make-date 120000000 0 0 12 1 1 1970 cur-tz) "check 8") + (check-equal? (string->date "12:00:00.1" "~H:~M:~S.~N") (srfi:make-date 100000000 0 0 12 1 1 1970 cur-tz) "check 9") + (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 1 1 1970 cur-tz) "check 10") + (check-equal? (string->date "12:00:00.012345678" "~H:~M:~S.~N") (srfi:make-date 12345678 0 0 12 1 1 1970 cur-tz) "check 11") + (check-equal? (string->date "12:00:00.001234567" "~H:~M:~S.~N") (srfi:make-date 1234567 0 0 12 1 1 1970 cur-tz) "check 12") + (check-equal? (string->date "12:00:00.000123456" "~H:~M:~S.~N") (srfi:make-date 123456 0 0 12 1 1 1970 cur-tz) "check 13") + (check-equal? (string->date "12:00:00.000012345" "~H:~M:~S.~N") (srfi:make-date 12345 0 0 12 1 1 1970 cur-tz) "check 14") + (check-equal? (string->date "12:00:00.000001234" "~H:~M:~S.~N") (srfi:make-date 1234 0 0 12 1 1 1970 cur-tz) "check 15") + (check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (srfi:make-date 123 0 0 12 1 1 1970 cur-tz) "check 16") + (check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (srfi:make-date 12 0 0 12 1 1 1970 cur-tz) "check 17") + (check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (srfi:make-date 1 0 0 12 1 1 1970 cur-tz) "check 18")) (test-case "interpretation of 1- to 4-digit years by ~y, ~Y and ~?:" ; ~y: -- 1.7.10.4
_________________________ Racket Developers list: http://lists.racket-lang.org/dev