[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        |  229 ++++++++++++++++++++++----------------
 collects/tests/srfi/19/tests.rkt |    8 ++
 2 files changed, 141 insertions(+), 96 deletions(-)

diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt
index bac5a33..323d7d8 100644
--- a/collects/srfi/19/time.rkt
+++ b/collects/srfi/19/time.rkt
@@ -608,40 +608,46 @@
   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)
+  (if (or (eq? day #t) (eq? month #t) (eq? year #t))
+      (srfi-19-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
+             "")))
+
+;; A struct type that emulates the old srfi/19 type
+;; In particular, allows '#t' as day, month, year
+(struct srfi-19-date (nanosecond second minute
+                      hour day month
+                      year zone-offset)
+        #:transparent)
+
+;; Convert srfi-19 date to date*
+(define (srfi-19-date->date* date)
+  (srfi:make-date (srfi-19-date-nanosecond date)
+                  (srfi-19-date-second date)
+                  (srfi-19-date-minute date)
+                  (srfi-19-date-hour date)
+                  (srfi-19-date-day date)
+                  (srfi-19-date-month date)
+                  (srfi-19-date-year date)
+                  (srfi-19-date-zone-offset date)))
+
+;; Predicate for dates
+(define (srfi:date? d)
+  (or (srfi-19-date? d) (date? d)))
 
 ;; Racket's date structure has the following:
 ;;   * second : 0 to 61 (60 and 61 are for unusual leap-seconds)
@@ -655,23 +661,29 @@
 ;;   * 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))
+;; These accessors work over either style of date
+(define-syntax-rule (define-date-accessor accessor srfi-19-accessor date-accessor)
+  (define (accessor d)
+    (if (srfi-19-date? d)
+        (srfi-19-accessor d)
+        (date-accessor d))))
+
+(define-date-accessor date-nanosecond srfi-19-date-nanosecond date*-nanosecond)
+(define-date-accessor srfi:date-second srfi-19-date-second date-second)
+(define-date-accessor srfi:date-minute srfi-19-date-minute date-minute)
+(define-date-accessor srfi:date-hour srfi-19-date-hour date-hour)
+(define-date-accessor srfi:date-day srfi-19-date-day date-day)
+(define-date-accessor srfi:date-month srfi-19-date-month date-month)
+(define-date-accessor srfi:date-year srfi-19-date-year date-year)
+(define-date-accessor date-zone-offset
+  srfi-19-date-zone-offset date-time-zone-offset)
+
+;; Serialization support for old srfi-19 structs
+(define deserialize-info:tm:date-v0
+  (make-deserialize-info
+   srfi:make-date
+   (lambda ()
+     (error 'deserialize-info:tm:date-v0 "cycles not allowed"))))
 
 ;; gives the julian day which starts at noon.
 (define (tm:encode-julian-day-number day month year)
@@ -774,9 +786,17 @@
 (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)))
+        (srfi:make-date (date-nanosecond d)
+                        60
+                        (srfi:date-minute d)
+                        (srfi:date-hour d)
+                        (srfi:date-day d)
+                        (srfi:date-month d)
+                        (srfi:date-year d)
+                        (date-zone-offset d)))
       (tm:time->date (time-tai->time-utc time) tz-offset time-utc)))
 
 (define (time-utc->date time . tz-offset)
@@ -1454,46 +1474,57 @@
      (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 srfi-19-date object [month 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 srfi-19-date object [month val])))
+     (list #\d char-numeric? ireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [day val])))
+     (list #\e char-fail eireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [day 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 srfi-19-date object [month val])))
+     (list #\H char-numeric? ireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [hour val])))
+     (list #\k char-fail eireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [hour val])))
+     (list #\m char-numeric? ireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [month val])))
+     (list #\M char-numeric? ireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [minute val])))
+     (list #\N char-numeric? fireader9
+           (lambda (val object)
+             (struct-copy srfi-19-date object [nanosecond val])))
+     (list #\S char-numeric? ireader2
+           (lambda (val object)
+             (struct-copy srfi-19-date object [second 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 srfi-19-date object
+                          [year (tm:natural-year val)])))
+     (list #\Y char-numeric? ireader4
+           (lambda (val object)
+             (struct-copy srfi-19-date object [year 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 srfi-19-date object [zone-offset 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 srfi-19-date object
+                          [year (tm:natural-year val)])))
      )))
 
 (define (tm:string->date date index format-string str-len port template-string)
@@ -1505,8 +1536,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 +1556,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,15 +1574,20 @@
          (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
-                     0
-                     template-string
-                     (string-length template-string)
-                     (open-input-string input-string)
-                     template-string)
+  (let* ([initial (srfi-19-date 0 0 0 0 #t #t #t (tm:local-tz-offset))]
+         [newdate (tm:string->date
+                   initial
+                   0
+                   template-string
+                   (string-length template-string)
+                   (open-input-string input-string)
+                   template-string)])
     (if (tm:date-ok? newdate)
-        newdate
+        (if (or (eq? (srfi-19-date-day newdate) #t)
+                (eq? (srfi-19-date-month newdate) #t)
+                (eq? (srfi-19-date-year newdate) #t))
+            newdate
+            (srfi-19-date->date* 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..2981ed9 100644
--- a/collects/tests/srfi/19/tests.rkt
+++ b/collects/tests/srfi/19/tests.rkt
@@ -221,6 +221,14 @@
       (check-equal? (deserialize (serialize (make-time time-utc 0 1))) (make-time time-utc 0 1))
       (check-equal? (deserialize (serialize (make-time time-tai 2 3))) (make-time time-tai 2 3))
       (check-equal? (deserialize (serialize (srfi:make-date 0 1 2 3 4 5 6 7))) (srfi:make-date 0 1 2 3 4 5 6 7)))
+
+    (test-case "old deserialization"
+      (check-equal? (deserialize '((3) 1 (((lib "srfi/19/time.rkt") . deserialize-info:tm:date-v0))
+                                   0 () () (0 0 1 2 3 4 5 6 7)))
+                    (srfi:make-date 0 1 2 3 4 5 6 7))
+      (check-equal? (deserialize '((3) 1 (((lib "srfi/19/time.rkt") . deserialize-info:tm:date-v0))
+                                   0 () () (0 0 0 0 0 1 1 2004 0)))
+                    (srfi:make-date 0 0 0 0 1 1 2004 0)))
     
     ;; nanosecnds off by a factor of 100...
     (test-case "nanosecond order-of-magnitude"
-- 
1.7.10.4


--tNQTSEo8WG/FKZ8E--

Posted on the dev mailing list.