[PATCH] Make srfi/19 compatible with date* structs

From: Asumu Takikawa (asumu at ccs.neu.edu)
Date: Fri Jan 11 21:06:01 EST 2013

---
 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


--NKoe5XOeduwbEQHU--

Posted on the dev mailing list.