[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
--NKoe5XOeduwbEQHU--
![[logo]](/logo.png){kind=logo}