suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Delete trailing whitespace

Browse Source
This commit is contained in:
Asumu Takikawa 2013-01-14 10:26:37 -05:00
parent 8d1c56cb6f
commit 1ae216ec94
2 changed files with 116 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
collects/srfi/19/time.rkt
View File

@ -12,30 +12,30 @@
;;; Based on a corrected version by Will F. Feb/2003 ;;; Based on a corrected version by Will F. Feb/2003
;; SRFI-19: Time Data Types and Procedures. ;; SRFI-19: Time Data Types and Procedures.
;; ;;
;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. ;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved. ;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
;; ;;
;; This document and translations of it may be copied and furnished to others, ;; This document and translations of it may be copied and furnished to others,
;; and derivative works that comment on or otherwise explain it or assist in its ;; and derivative works that comment on or otherwise explain it or assist in its
;; implementation may be prepared, copied, published and distributed, in whole or ;; implementation may be prepared, copied, published and distributed, in whole or
;; in part, without restriction of any kind, provided that the above copyright ;; in part, without restriction of any kind, provided that the above copyright
;; notice and this paragraph are included on all such copies and derivative works. ;; notice and this paragraph are included on all such copies and derivative works.
;; However, this document itself may not be modified in any way, such as by ;; However, this document itself may not be modified in any way, such as by
;; removing the copyright notice or references to the Scheme Request For ;; removing the copyright notice or references to the Scheme Request For
;; Implementation process or editors, except as needed for the purpose of ;; Implementation process or editors, except as needed for the purpose of
;; developing SRFIs in which case the procedures for copyrights defined in the SRFI ;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
;; process must be followed, or as required to translate it into languages other ;; process must be followed, or as required to translate it into languages other
;; than English. ;; than English.
;; ;;
;; The limited permissions granted above are perpetual and will not be revoked ;; The limited permissions granted above are perpetual and will not be revoked
;; by the authors or their successors or assigns. ;; by the authors or their successors or assigns.
;; ;;
;; This document and the information contained herein is provided on an "AS IS" ;; This document and the information contained herein is provided on an "AS IS"
;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR ;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE ;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF ;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. ;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
;; -- Racket implementation ;; -- Racket implementation
;; ;;
@ -43,13 +43,13 @@
;; CURRENT-SECONDS, the DEFINE-STRUCT procedure (SRFI 9: Defining Record Types ;; CURRENT-SECONDS, the DEFINE-STRUCT procedure (SRFI 9: Defining Record Types
;; could be used), and the constants tm:time-at-zero-seconds ;; could be used), and the constants tm:time-at-zero-seconds
;; and tm:julian-day-at-zero-seconds, which refer to the '0' of CURRENT-SECONDS. ;; and tm:julian-day-at-zero-seconds, which refer to the '0' of CURRENT-SECONDS.
;; ;;
;; SRFI-6, String Ports, and SRFI-8, RECEIVE: Binding Multiple Values, ;; SRFI-6, String Ports, and SRFI-8, RECEIVE: Binding Multiple Values,
;; are also used. Racket has String Ports built-in. The RECEIVE form ;; are also used. Racket has String Ports built-in. The RECEIVE form
;; is copied below. ;; is copied below.
;; ;;
; srfi-8: receive ; srfi-8: receive
;(require-library "synrule.rkt") -- PLT doesn't like DEFINE-SYNTAX. ;(require-library "synrule.rkt") -- PLT doesn't like DEFINE-SYNTAX.
;(define-syntax receive ;(define-syntax receive
; (syntax-rules () ; (syntax-rules ()
@ -68,7 +68,7 @@
(provide time-tai time-utc time-monotonic time-thread time-process time-duration time-gc (provide time-tai time-utc time-monotonic time-thread time-process time-duration time-gc
current-date current-julian-day current-modified-julian-day current-time time-resolution current-date current-julian-day current-modified-julian-day current-time time-resolution
;; Time object and accessors ;; Time object and accessors
make-time time? time-type time-nanosecond make-time time? time-type time-nanosecond
deserialize-info:tm:time-v0 deserialize-info:tm:time-v0
time-second set-time-type! set-time-nanosecond! set-time-second! time-second set-time-type! set-time-nanosecond! set-time-second!
copy-time copy-time
@ -84,9 +84,9 @@
srfi:date-year date-zone-offset srfi:date-year date-zone-offset
;; This are not part of the date structure (as they are in the original Racket's date) ;; This are not part of the date structure (as they are in the original Racket's date)
srfi:date-year-day srfi:date-week-day date-week-number srfi:date-year-day srfi:date-week-day date-week-number
;; The following procedures work with this modified version. ;; The following procedures work with this modified version.
;; Time/Date/Julian Day/Modified Julian Day Converters ;; Time/Date/Julian Day/Modified Julian Day Converters
date->julian-day date->modified-julian-day date->time-monotonic date->time-tai date->time-utc date->julian-day date->modified-julian-day date->time-monotonic date->time-tai date->time-utc
julian-day->date julian-day->time-monotonic julian-day->time-tai julian-day->time-utc modified-julian-day->date julian-day->date julian-day->time-monotonic julian-day->time-tai julian-day->time-utc modified-julian-day->date
@ -119,7 +119,7 @@
;; the least specific one (this one *does* exist!, it comes with this srfi) don't worry: ;; the least specific one (this one *does* exist!, it comes with this srfi) don't worry:
(load-bundle! (list 'srfi-19))) (load-bundle! (list 'srfi-19)))
(set! localized? #t)) (set! localized? #t))
(localized-template 'srfi-19 message-name))) (localized-template 'srfi-19 message-name)))
;; Constants ;; Constants
@ -141,7 +141,7 @@
(define tm:locale-abbr-weekday-vector (vector 'sun 'mon 'tue 'wed 'thu 'fri 'sat)) (define tm:locale-abbr-weekday-vector (vector 'sun 'mon 'tue 'wed 'thu 'fri 'sat))
(define tm:locale-long-weekday-vector (vector 'sunday 'monday 'tuesday 'wednesday (define tm:locale-long-weekday-vector (vector 'sunday 'monday 'tuesday 'wednesday
'thursday 'friday 'saturday)) 'thursday 'friday 'saturday))
;; note empty string in 0th place. ;; note empty string in 0th place.
(define tm:locale-abbr-month-vector (vector 'jan 'feb 'mar (define tm:locale-abbr-month-vector (vector 'jan 'feb 'mar
'apr 'may 'jun 'jul 'apr 'may 'jun 'jul
'aug 'sep 'oct 'nov 'aug 'sep 'oct 'nov
@ -151,7 +151,7 @@
'march 'april 'may 'march 'april 'may
'june 'july 'august 'june 'july 'august
'september 'october 'september 'october
'november 'december)) 'november 'december))
(define tm:locale-pm 'pm) (define tm:locale-pm 'pm)
(define tm:locale-am 'am) (define tm:locale-am 'am)
@ -171,7 +171,7 @@
(define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' (define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
;; A Very simple Error system for the time procedures ;; A Very simple Error system for the time procedures
;; ;;
(define tm:time-error-types (define tm:time-error-types
'(invalid-clock-type '(invalid-clock-type
unsupported-clock-type unsupported-clock-type
@ -195,7 +195,7 @@
;; and update as necessary. ;; and update as necessary.
;; this procedures reads the file in the abover ;; this procedures reads the file in the abover
;; format and creates the leap second table ;; format and creates the leap second table
;; it also calls the almost standard, but not R5 procedures read-line ;; it also calls the almost standard, but not R5 procedures read-line
;; & open-input-string ;; & open-input-string
;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat")) ;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat"))
@ -208,7 +208,7 @@
(table '()) ) (table '()) )
(let loop ((line (read-line port))) (let loop ((line (read-line port)))
(unless (eq? line eof) (unless (eq? line eof)
(let* ( (data (read (open-input-string (string-append "(" line ")")))) (let* ( (data (read (open-input-string (string-append "(" line ")"))))
(year (car data)) (year (car data))
(jd (cadddr (cdr data))) (jd (cadddr (cdr data)))
(secs (cadddr (cdddr data))) ) (secs (cadddr (cdddr data))) )
@ -260,7 +260,7 @@
(if (< utc-seconds (* (- 1972 1970) 365 tm:sid)) 0 (if (< utc-seconds (* (- 1972 1970) 365 tm:sid)) 0
(lsd tm:leap-second-table)))) (lsd tm:leap-second-table))))
;; going from tai seconds to utc seconds ... ;; going from tai seconds to utc seconds ...
(define (tm:leap-second-neg-delta tai-seconds) (define (tm:leap-second-neg-delta tai-seconds)
(letrec ( (lsd (lambda (table) (letrec ( (lsd (lambda (table)
(cond ((null? table) 0) (cond ((null? table) 0)
@ -271,7 +271,7 @@
(lsd tm:leap-second-table)))) (lsd tm:leap-second-table))))
(define-values (tm:time make-time time? tm:time-ref tm:time-set!) (define-values (tm:time make-time time? tm:time-ref tm:time-set!)
(make-struct-type (make-struct-type
'tm:time #f 3 0 #f 'tm:time #f 3 0 #f
(list (cons prop:serializable (list (cons prop:serializable
(make-serialize-info (make-serialize-info
@ -281,7 +281,7 @@
(time-second t))) (time-second t)))
#'deserialize-info:tm:time-v0 #'deserialize-info:tm:time-v0
#f #f
(or (current-load-relative-directory) (or (current-load-relative-directory)
(current-directory))))) (current-directory)))))
(make-inspector) #f null)) (make-inspector) #f null))
@ -315,10 +315,10 @@
;;; These should be rewritten to be OS specific. ;;; These should be rewritten to be OS specific.
;; ;;
;; -- using GNU gettimeofday() would be useful here -- gets ;; -- using GNU gettimeofday() would be useful here -- gets
;; second + millisecond ;; second + millisecond
;; let's pretend we do, using Racket's current-seconds & current-milliseconds ;; let's pretend we do, using Racket's current-seconds & current-milliseconds
;; this is supposed to return UTC. ;; this is supposed to return UTC.
;; ;;
(define (tm:get-time-of-day) (define (tm:get-time-of-day)
(let* ((total-msecs (inexact->exact (floor (current-inexact-milliseconds))))) (let* ((total-msecs (inexact->exact (floor (current-inexact-milliseconds)))))
@ -337,7 +337,7 @@
(define (tm:current-time-ms-time time-type proc) (define (tm:current-time-ms-time time-type proc)
(let ((current-ms (proc))) (let ((current-ms (proc)))
(make-time time-type (make-time time-type
(* (remainder current-ms 1000) 1000000) (* (remainder current-ms 1000) 1000000)
(quotient current-ms 1000000) (quotient current-ms 1000000)
))) )))
@ -448,7 +448,7 @@
(begin (begin
(set-time-second! time3 0) (set-time-second! time3 0)
(set-time-nanosecond! time3 0)) (set-time-nanosecond! time3 0))
(receive (receive
(nanos secs) (nanos secs)
(tm:nanoseconds->values (- (tm:time->nanoseconds time1) (tm:nanoseconds->values (- (tm:time->nanoseconds time1)
(tm:time->nanoseconds time2))) (tm:time->nanoseconds time2)))
@ -520,7 +520,7 @@
(set-time-type! time-out time-utc) (set-time-type! time-out time-utc)
(set-time-nanosecond! time-out (time-nanosecond time-in)) (set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (- (time-second time-in) (set-time-second! time-out (- (time-second time-in)
(tm:leap-second-neg-delta (tm:leap-second-neg-delta
(time-second time-in)))) (time-second time-in))))
time-out) time-out)
@ -538,7 +538,7 @@
(set-time-type! time-out time-tai) (set-time-type! time-out time-tai)
(set-time-nanosecond! time-out (time-nanosecond time-in)) (set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (+ (time-second time-in) (set-time-second! time-out (+ (time-second time-in)
(tm:leap-second-delta (tm:leap-second-delta
(time-second time-in)))) (time-second time-in))))
time-out) time-out)
@ -617,7 +617,7 @@
(with-handlers ([exn:fail:contract? (with-handlers ([exn:fail:contract?
(lambda (e) (lambda (e)
(lax-date nanosecond second minute hour (lax-date nanosecond second minute hour
day month year zone-offset))]) day month year zone-offset))])
(date* second minute hour (date* second minute hour
day month year day month year
;; compute derived fields ;; compute derived fields
@ -707,7 +707,7 @@
(else (else
(tm:char-pos char str (+ index 1) len)))) (tm:char-pos char str (+ index 1) len))))
; return a string representing the decimal expansion of the fractional ; return a string representing the decimal expansion of the fractional
; portion of a number, limited by a specified precision ; portion of a number, limited by a specified precision
(define (tm:decimal-expansion r precision) (define (tm:decimal-expansion r precision)
(let loop ([num (- r (round r))] (let loop ([num (- r (round r))]
@ -715,7 +715,7 @@
(if (or (= p 0) (= num 0)) (if (or (= p 0) (= num 0))
"" ""
(let* ([num-times-10 (* 10 num)] (let* ([num-times-10 (* 10 num)]
[round-num-times-10 (round num-times-10)]) [round-num-times-10 (round num-times-10)])
(string-append (number->string (inexact->exact round-num-times-10)) (string-append (number->string (inexact->exact round-num-times-10))
(loop (- num-times-10 round-num-times-10) (- p 1))))))) (loop (- num-times-10 round-num-times-10) (- p 1)))))))
@ -818,7 +818,7 @@
(offset (date-zone-offset date)) ) (offset (date-zone-offset date)) )
(let ( (jdays (- (tm:encode-julian-day-number day month year) (let ( (jdays (- (tm:encode-julian-day-number day month year)
tm:tai-epoch-in-jd)) ) tm:tai-epoch-in-jd)) )
(make-time (make-time
time-utc time-utc
nanosecond nanosecond
(+ (* (- jdays 1/2) 24 60 60) (+ (* (- jdays 1/2) 24 60 60)
@ -845,7 +845,7 @@
(tm:leap-year? (srfi:date-year date))) (tm:leap-year? (srfi:date-year date)))
;; tm:year-day fixed: adding wrong number of days. ;; tm:year-day fixed: adding wrong number of days.
(define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120) (define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120)
(5 . 151) (6 . 181) (7 . 212) (8 . 243) (5 . 151) (6 . 181) (7 . 212) (8 . 243)
(9 . 273) (10 . 304) (11 . 334))) (9 . 273) (10 . 304) (11 . 334)))
@ -860,7 +860,7 @@
(define (srfi:date-year-day date) (define (srfi:date-year-day date)
(tm:year-day (srfi:date-day date) (srfi:date-month date) (srfi:date-year date))) (tm:year-day (srfi:date-day date) (srfi:date-month date) (srfi:date-year date)))
;; from calendar faq ;; from calendar faq
(define (tm:week-day day month year) (define (tm:week-day day month year)
(let* ((a (quotient (- 14 month) 12)) (let* ((a (quotient (- 14 month) 12))
(y (- year a)) (y (- year a))
@ -887,7 +887,7 @@
(tm:days-before-first-week date day-of-week-starting-week)) (tm:days-before-first-week date day-of-week-starting-week))
7)) 7))
(define (current-date . tz-offset) (define (current-date . tz-offset)
(time-utc->date (current-time time-utc) (time-utc->date (current-time time-utc)
(:optional tz-offset (tm:local-tz-offset)))) (:optional tz-offset (tm:local-tz-offset))))
@ -940,7 +940,7 @@
(define (time-tai->julian-day time) (define (time-tai->julian-day time)
(unless (eq? (time-type time) time-tai) (unless (eq? (time-type time) time-tai)
(tm:time-error 'time->date 'incompatible-time-types time)) (tm:time-error 'time->date 'incompatible-time-types time))
(+ (/ (+ (- (time-second time) (+ (/ (+ (- (time-second time)
(tm:leap-second-delta (time-second time))) (tm:leap-second-delta (time-second time)))
(/ (time-nanosecond time) tm:nano)) (/ (time-nanosecond time) tm:nano))
tm:sid) tm:sid)
@ -954,7 +954,7 @@
(define (time-monotonic->julian-day time) (define (time-monotonic->julian-day time)
(unless (eq? (time-type time) time-monotonic) (unless (eq? (time-type time) time-monotonic)
(tm:time-error 'time->date 'incompatible-time-types time)) (tm:time-error 'time->date 'incompatible-time-types time))
(+ (/ (+ (- (time-second time) (+ (/ (+ (- (time-second time)
(tm:leap-second-delta (time-second time))) (tm:leap-second-delta (time-second time)))
(/ (time-nanosecond time) tm:nano)) (/ (time-nanosecond time) tm:nano))
tm:sid) tm:sid)
@ -1002,7 +1002,7 @@
(time-utc->modified-julian-day (current-time time-utc))) (time-utc->modified-julian-day (current-time time-utc)))
;; returns a string rep. of number N, of minimum LENGTH, ;; returns a string rep. of number N, of minimum LENGTH,
;; padded with character PAD-WITH. If PAD-WITH if #f, ;; padded with character PAD-WITH. If PAD-WITH if #f,
;; no padding is done, and it's as if number->string was used. ;; no padding is done, and it's as if number->string was used.
;; if string is longer than LENGTH, it's as if number->string was used. ;; if string is longer than LENGTH, it's as if number->string was used.
(define (tm:padding n pad-with length) (define (tm:padding n pad-with length)
@ -1016,14 +1016,14 @@
str-len)) ) str-len)) )
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((>= i (string-length str))) ((>= i (string-length str)))
(string-set! new-str (+ new-str-offset i) (string-set! new-str (+ new-str-offset i)
(string-ref str i))) (string-ref str i)))
new-str)))) new-str))))
(define (tm:last-n-digits i n) (define (tm:last-n-digits i n)
(abs (remainder i (expt 10 n)))) (abs (remainder i (expt 10 n))))
(define (tm:locale-abbr-weekday n) (define (tm:locale-abbr-weekday n)
(localized-message (vector-ref tm:locale-abbr-weekday-vector n))) (localized-message (vector-ref tm:locale-abbr-weekday-vector n)))
(define (tm:locale-long-weekday n) (define (tm:locale-long-weekday n)
@ -1058,9 +1058,9 @@
;; do nothing. ;; do nothing.
;; Your implementation might want to do something... ;; Your implementation might want to do something...
;; ;;
(define (tm:locale-print-time-zone date port) (define (tm:locale-print-time-zone date port)
(values)) (values))
@ -1084,10 +1084,10 @@
;; the second is a procedure that takes the date, a padding character ;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port. ;; (which might be #f), and the output port.
;; ;;
(define tm:directives (define tm:directives
(list (list
(cons #\~ (lambda (date pad-with port) (display #\~ port))) (cons #\~ (lambda (date pad-with port) (display #\~ port)))
(cons #\a (lambda (date pad-with port) (cons #\a (lambda (date pad-with port)
(display (tm:locale-abbr-weekday (srfi:date-week-day date)) (display (tm:locale-abbr-weekday (srfi:date-week-day date))
port))) port)))
@ -1208,7 +1208,7 @@
(display (tm:padding (date-week-number date 1) (display (tm:padding (date-week-number date 1)
#\0 2) port)))) #\0 2) port))))
(cons #\y (lambda (date pad-with port) (cons #\y (lambda (date pad-with port)
(display (tm:padding (tm:last-n-digits (display (tm:padding (tm:last-n-digits
(srfi:date-year date) 2) (srfi:date-year date) 2)
pad-with pad-with
2) 2)
@ -1245,45 +1245,45 @@
(display current-char port) (display current-char port)
(tm:date-printer date (+ index 1) format-string str-len port)) (tm:date-printer date (+ index 1) format-string str-len port))
(if (= (+ index 1) str-len) ; bad format string. (if (= (+ index 1) str-len) ; bad format string.
(tm:time-error 'tm:date-printer 'bad-date-format-string (tm:time-error 'tm:date-printer 'bad-date-format-string
format-string) format-string)
(let ( (pad-char? (string-ref format-string (+ index 1))) ) (let ( (pad-char? (string-ref format-string (+ index 1))) )
(cond (cond
((char=? pad-char? #\-) ((char=? pad-char? #\-)
(if (= (+ index 2) str-len) ; bad format string. (if (= (+ index 2) str-len) ; bad format string.
(tm:time-error 'tm:date-printer 'bad-date-format-string (tm:time-error 'tm:date-printer 'bad-date-format-string
format-string) format-string)
(let ( (formatter (tm:get-formatter (let ( (formatter (tm:get-formatter
(string-ref format-string (string-ref format-string
(+ index 2)))) ) (+ index 2)))) )
(if (not formatter) (if (not formatter)
(tm:time-error 'tm:date-printer 'bad-date-format-string (tm:time-error 'tm:date-printer 'bad-date-format-string
format-string) format-string)
(begin (begin
(formatter date #f port) (formatter date #f port)
(tm:date-printer date (+ index 3) (tm:date-printer date (+ index 3)
format-string str-len port)))))) format-string str-len port))))))
((char=? pad-char? #\_) ((char=? pad-char? #\_)
(if (= (+ index 2) str-len) ; bad format string. (if (= (+ index 2) str-len) ; bad format string.
(tm:time-error 'tm:date-printer 'bad-date-format-string (tm:time-error 'tm:date-printer 'bad-date-format-string
format-string) format-string)
(let ( (formatter (tm:get-formatter (let ( (formatter (tm:get-formatter
(string-ref format-string (string-ref format-string
(+ index 2)))) ) (+ index 2)))) )
(if (not formatter) (if (not formatter)
(tm:time-error 'tm:date-printer 'bad-date-format-string (tm:time-error 'tm:date-printer 'bad-date-format-string
format-string) format-string)
(begin (begin
(formatter date #\Space port) (formatter date #\Space port)
(tm:date-printer date (+ index 3) (tm:date-printer date (+ index 3)
format-string str-len port)))))) format-string str-len port))))))
(else (else
(let ( (formatter (tm:get-formatter (let ( (formatter (tm:get-formatter
(string-ref format-string (string-ref format-string
(+ index 1)))) ) (+ index 1)))) )
(if (not formatter) (if (not formatter)
(tm:time-error 'tm:date-printer 'bad-date-format-string (tm:time-error 'tm:date-printer 'bad-date-format-string
format-string) format-string)
(begin (begin
(formatter date #\0 port) (formatter date #\0 port)
@ -1331,7 +1331,7 @@
;; read an fractional integer upto n characters long on port; upto -> #f if any length ;; read an fractional integer upto n characters long on port; upto -> #f if any length
;; ;;
;; The return value is normalized to upto decimal places. For example, if upto is 9 and ;; The return value is normalized to upto decimal places. For example, if upto is 9 and
;; the string read is "123", the return value is 123000000. ;; the string read is "123", the return value is 123000000.
(define (tm:fractional-integer-reader upto port) (define (tm:fractional-integer-reader upto port)
(define (accum-int port accum nchars) (define (accum-int port accum nchars)
@ -1354,8 +1354,8 @@
(let ((ch (peek-char port))) (let ((ch (peek-char port)))
(cond (cond
((>= nchars n) accum) ((>= nchars n) accum)
((eof-object? ch) ((eof-object? ch)
(tm:time-error 'string->date 'bad-date-template-string (tm:time-error 'string->date 'bad-date-template-string
"Premature ending to integer read.")) "Premature ending to integer read."))
((char-numeric? ch) ((char-numeric? ch)
(set! padding-ok #f) (set! padding-ok #f)
@ -1365,7 +1365,7 @@
(read-char port) ; consume padding (read-char port) ; consume padding
(accum-int port accum (+ nchars 1))) (accum-int port accum (+ nchars 1)))
(else ; padding where it shouldn't be (else ; padding where it shouldn't be
(tm:time-error 'string->date 'bad-date-template-string (tm:time-error 'string->date 'bad-date-template-string
"Non-numeric characters in integer read."))))) "Non-numeric characters in integer read.")))))
(accum-int port 0 0))) (accum-int port 0 0)))
@ -1374,8 +1374,8 @@
(lambda (port) (lambda (port)
(tm:integer-reader-exact n port))) (tm:integer-reader-exact n port)))
(define (tm:zone-reader port) (define (tm:zone-reader port)
(let ( (offset 0) (let ( (offset 0)
(positive? #f) ) (positive? #f) )
(let ( (ch (read-char port)) ) (let ( (ch (read-char port)) )
(when (eof-object? ch) (when (eof-object? ch)
@ -1418,10 +1418,10 @@
(define (read-char-string) (define (read-char-string)
(let ((ch (peek-char port))) (let ((ch (peek-char port)))
(if (char-alphabetic? ch) (if (char-alphabetic? ch)
(begin (write-char (read-char port) string-port) (begin (write-char (read-char port) string-port)
(read-char-string)) (read-char-string))
(get-output-string string-port)))) (get-output-string string-port))))
(let* ( (str (read-char-string)) (let* ( (str (read-char-string))
(index (indexer str)) ) (index (indexer str)) )
(if index index (tm:time-error 'string->date (if index index (tm:time-error 'string->date
'bad-date-template-string 'bad-date-template-string
@ -1441,7 +1441,7 @@
;; A List of formatted read directives. ;; A List of formatted read directives.
;; Each entry is a list. ;; Each entry is a list.
;; 1. the character directive; ;; 1. the character directive;
;; a procedure, which takes a character as input & returns ;; a procedure, which takes a character as input & returns
;; 2. #t as soon as a character on the input port is acceptable ;; 2. #t as soon as a character on the input port is acceptable
;; for input, ;; for input,
@ -1450,7 +1450,7 @@
;; 4. a action procedure, that takes the value (from 3.) and some ;; 4. a action procedure, that takes the value (from 3.) and some
;; object (here, always the date) and (probably) side-effects it. ;; object (here, always the date) and (probably) side-effects it.
;; In some cases (e.g., ~A) the action is to do nothing ;; In some cases (e.g., ~A) the action is to do nothing
(define tm:read-directives (define tm:read-directives
(let ( (ireader4 (tm:make-integer-reader 4)) (let ( (ireader4 (tm:make-integer-reader 4))
(ireader2 (tm:make-integer-reader 2)) (ireader2 (tm:make-integer-reader 2))
(fireader9 (tm:make-fractional-integer-reader 9)) (fireader9 (tm:make-fractional-integer-reader 9))
@ -1468,7 +1468,7 @@
(char-fail (lambda (ch) #t)) (char-fail (lambda (ch) #t))
(do-nothing (lambda (val object) (values))) (do-nothing (lambda (val object) (values)))
) )
(list (list
(list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing) (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing)
(list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
@ -1506,7 +1506,7 @@
(list #\S char-numeric? ireader2 (list #\S char-numeric? ireader2
(lambda (val object) (lambda (val object)
(struct-copy lax-date object [second val]))) (struct-copy lax-date object [second val])))
(list #\y char-fail eireader2 (list #\y char-fail eireader2
(lambda (val object) (lambda (val object)
(struct-copy lax-date object (struct-copy lax-date object
[year (tm:natural-year val)]))) [year (tm:natural-year val)])))
@ -1586,6 +1586,6 @@
(if (tm:date-ok? newdate) (if (tm:date-ok? newdate)
(lax-date->date* newdate) (lax-date->date* newdate)
(tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string)))))

60
collects/tests/srfi/19/tests.rkt
View File

@ -2,7 +2,7 @@
;; Tests by Will Fitzgerald, augmented by: ;; Tests by Will Fitzgerald, augmented by:
;; John Clements -- 2004-08-16 ;; John Clements -- 2004-08-16
;; Dave Gurnell (string->date, date->string) -- 2007-09-14 ;; Dave Gurnell (string->date, date->string) -- 2007-09-14
;; Dave Gurnell (time{=,<,>,<=,>=}?) -- 2009-11-26 ;; Dave Gurnell (time{=,<,>,<=,>=}?) -- 2009-11-26
;; John Clements (nanoseconds off by x100) -- 2009-12-15 ;; John Clements (nanoseconds off by x100) -- 2009-12-15
;; Dave Gurnell (serializable dates and times) -- 2010-03-03 ;; Dave Gurnell (serializable dates and times) -- 2010-03-03
@ -31,7 +31,7 @@
(define srfi-19-test-suite (define srfi-19-test-suite
(test-suite "Tests for SRFI 19" (test-suite "Tests for SRFI 19"
(test-not-exn "Creating time structures" (test-not-exn "Creating time structures"
(lambda () (lambda ()
(list (current-time 'time-tai) (list (current-time 'time-tai)
@ -39,7 +39,7 @@
(current-time 'time-monotonic) (current-time 'time-monotonic)
(current-time 'time-thread) (current-time 'time-thread)
(current-time 'time-process)))) (current-time 'time-process))))
(test-not-exn "Testing time resolutions" (test-not-exn "Testing time resolutions"
(lambda () (lambda ()
(list (time-resolution 'time-tai) (list (time-resolution 'time-tai)
@ -47,7 +47,7 @@
(time-resolution 'time-monotonic) (time-resolution 'time-monotonic)
(time-resolution 'time-thread) (time-resolution 'time-thread)
(time-resolution 'time-process)))) (time-resolution 'time-process))))
(test-case "Time comparisons (time=?, etc.)" (test-case "Time comparisons (time=?, etc.)"
(let ([t0 (make-time 'time-utc 0 1)] (let ([t0 (make-time 'time-utc 0 1)]
[t1 (make-time 'time-utc 0 1)] [t1 (make-time 'time-utc 0 1)]
@ -73,7 +73,7 @@
(#t #t #f #f) (#t #t #f #f)
(#t #t #t #f) (#t #t #t #f)
(#t #t #t #t))))) (#t #t #t #t)))))
(test-case "Time difference" (test-case "Time difference"
(let ((t1 (make-time 'time-utc 0 3000)) (let ((t1 (make-time 'time-utc 0 3000))
(t2 (make-time 'time-utc 0 1000)) (t2 (make-time 'time-utc 0 1000))
@ -81,7 +81,7 @@
(t4 (make-time 'time-duration 0 -2000))) (t4 (make-time 'time-duration 0 -2000)))
(check time=? t3 (time-difference t1 t2)) (check time=? t3 (time-difference t1 t2))
(check time=? t4 (time-difference t2 t1)))) (check time=? t4 (time-difference t2 t1))))
(test-case "TAI-UTC Conversions" (test-case "TAI-UTC Conversions"
(check-one-utc-tai-edge 915148800 32 31) (check-one-utc-tai-edge 915148800 32 31)
(check-one-utc-tai-edge 867715200 31 30) (check-one-utc-tai-edge 867715200 31 30)
@ -109,7 +109,7 @@
(check-one-utc-tai-edge 0 0 0) ;; at the epoch (check-one-utc-tai-edge 0 0 0) ;; at the epoch
(check-one-utc-tai-edge 10 0 0) ;; close to it ... (check-one-utc-tai-edge 10 0 0) ;; close to it ...
(check-one-utc-tai-edge 1045789645 32 32)) ;; about now ... (check-one-utc-tai-edge 1045789645 32 32)) ;; about now ...
(test-case "TAI-Date Conversions" (test-case "TAI-Date Conversions"
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
(srfi:make-date 0 58 59 23 31 12 1998 0)) (srfi:make-date 0 58 59 23 31 12 1998 0))
@ -119,7 +119,7 @@
(srfi:make-date 0 60 59 23 31 12 1998 0)) (srfi:make-date 0 60 59 23 31 12 1998 0))
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
(srfi:make-date 0 0 0 0 1 1 1999 0))) (srfi:make-date 0 0 0 0 1 1 1999 0)))
(test-case "Date-UTC Conversions" (test-case "Date-UTC Conversions"
(check time=? (make-time time-utc 0 (- 915148800 2)) (check time=? (make-time time-utc 0 (- 915148800 2))
(date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0))) (date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0)))
@ -132,24 +132,24 @@
(date->time-utc (srfi:make-date 0 0 0 0 1 1 1999 0))) (date->time-utc (srfi:make-date 0 0 0 0 1 1 1999 0)))
(check time=? (make-time time-utc 0 (+ 915148800 1)) (check time=? (make-time time-utc 0 (+ 915148800 1))
(date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0)))) (date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0))))
(test-case "TZ Offset conversions" (test-case "TZ Offset conversions"
(let ((ct-utc (make-time time-utc 6320000 1045944859)) (let ((ct-utc (make-time time-utc 6320000 1045944859))
(ct-tai (make-time time-tai 6320000 1045944891)) (ct-tai (make-time time-tai 6320000 1045944891))
(cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000))) (cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000)))
(check time=? ct-utc (date->time-utc cd)) (check time=? ct-utc (date->time-utc cd))
(check time=? ct-tai (date->time-tai cd)))) (check time=? ct-tai (date->time-tai cd))))
;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going
;; to change the test case to match the implementation... ;; to change the test case to match the implementation...
(test-case "date->string conversions" (test-case "date->string conversions"
(check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120)) (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120))
"~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H") "~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H")
"~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04")) "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04"))
(test-case "date->string conversions of dates with nanosecond components" (test-case "date->string conversions of dates with nanosecond components"
(check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 0) "~N") "123456789") (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 0) "~N") "123456789")
(check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 0) "~N") "012345678") (check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 0) "~N") "012345678")
@ -160,7 +160,7 @@
(check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 0) "~N") "000000123") (check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 0) "~N") "000000123")
(check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 0) "~N") "000000012") (check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 0) "~N") "000000012")
(check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 0) "~N") "000000001")) (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" (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.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.12345678" "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 #t #t #t cur-tz) "check 2")
@ -180,7 +180,7 @@
(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.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.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.000000001" "~H:~M:~S.~N") (srfi:make-date 1 0 0 12 #t #t #t cur-tz) "check 18"))
(test-case "interpretation of 1- to 4-digit years by ~y, ~Y and ~?:" (test-case "interpretation of 1- to 4-digit years by ~y, ~Y and ~?:"
; ~y: ; ~y:
(check-exn exn:fail? (lambda () (string->date "1-03-02" "~y-~m-~d"))) (check-exn exn:fail? (lambda () (string->date "1-03-02" "~y-~m-~d")))
@ -197,27 +197,27 @@
(check-not-exn (lambda () (check-equal? (string->date "10-03-02" "~?-~m-~d") (srfi:make-date 0 0 0 0 2 3 2010 cur-tz)))) (check-not-exn (lambda () (check-equal? (string->date "10-03-02" "~?-~m-~d") (srfi:make-date 0 0 0 0 2 3 2010 cur-tz))))
(check-not-exn (lambda () (check-equal? (string->date "100-03-02" "~?-~m-~d") (srfi:make-date 0 0 0 0 2 3 100 cur-tz)))) (check-not-exn (lambda () (check-equal? (string->date "100-03-02" "~?-~m-~d") (srfi:make-date 0 0 0 0 2 3 100 cur-tz))))
(check-not-exn (lambda () (check-equal? (string->date "1000-03-02" "~?-~m-~d") (srfi:make-date 0 0 0 0 2 3 1000 cur-tz))))) (check-not-exn (lambda () (check-equal? (string->date "1000-03-02" "~?-~m-~d") (srfi:make-date 0 0 0 0 2 3 1000 cur-tz)))))
(test-case "type-like error on date->string" (test-case "type-like error on date->string"
(check-exn (check-exn
(lambda (exn) (lambda (exn)
(regexp-match #px"expects type <string>" (regexp-match #px"expects type <string>"
(exn-message exn))) (exn-message exn)))
(lambda () (date->string (srfi:make-date 1000 2 3 4 2 5 2011 (* 60 -120)) #t)))) (lambda () (date->string (srfi:make-date 1000 2 3 4 2 5 2011 (* 60 -120)) #t))))
(test-case "date<->julian-day conversion" (test-case "date<->julian-day conversion"
(check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
(date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0)))) (date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
(let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)]) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)])
(check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200)))) (check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))))
(test-case "date->modified-julian-day conversion" (test-case "date->modified-julian-day conversion"
(check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
(date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0)))) (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
(let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)]) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)])
(check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))) (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))))
(test-case "serialize and deserialize" (test-case "serialize and deserialize"
(check-equal? (deserialize (serialize (make-time time-utc 0 1))) (make-time time-utc 0 1)) (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 (make-time time-tai 2 3))) (make-time time-tai 2 3))
@ -248,7 +248,7 @@
2004) 2004)
(check-equal? (srfi:date-year (srfi:make-date 0 0 0 0 1 1 2004 0)) (check-equal? (srfi:date-year (srfi:make-date 0 0 0 0 1 1 2004 0))
2004)) 2004))
;; nanoseconds off by a factor of 100... ;; nanoseconds off by a factor of 100...
(test-case "nanosecond order-of-magnitude" (test-case "nanosecond order-of-magnitude"
;; half a second should be within 1/10th of 10^9 / 2 nanoseconds (currently off by a factor of 100) ;; half a second should be within 1/10th of 10^9 / 2 nanoseconds (currently off by a factor of 100)
@ -269,19 +269,19 @@
(tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
(utc->tai-basic (time-utc->time-tai utc-basic)) (utc->tai-basic (time-utc->time-tai utc-basic))
(tai->utc-basic (time-tai->time-utc tai-basic)) (tai->utc-basic (time-tai->time-utc tai-basic))
;; a second before they should be the old diff ;; a second before they should be the old diff
(utc-basic-1 (make-time 'time-utc 0 (- utc 1))) (utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
(tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
(utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
(tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
;; a second later they should be the new diff ;; a second later they should be the new diff
(utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) (utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
(tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
(utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
(tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
;; ok, let's move the clock half a month or so plus half a second ;; ok, let's move the clock half a month or so plus half a second
(shy (* 15 24 60 60)) (shy (* 15 24 60 60))
(hs (/ (expt 10 9) 2)) (hs (/ (expt 10 9) 2))
@ -290,7 +290,7 @@
(tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
(utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
(tai->utc-basic+2 (time-tai->time-utc tai-basic+2))) (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
(check time=? utc-basic tai->utc-basic) (check time=? utc-basic tai->utc-basic)
(check time=? tai-basic utc->tai-basic) (check time=? tai-basic utc->tai-basic)
(check time=? utc-basic-1 tai->utc-basic-1) (check time=? utc-basic-1 tai->utc-basic-1)