Delete trailing whitespace
This commit is contained in:
Asumu Takikawa
parent
8d1c56cb6f
commit
1ae216ec94
|
|
@ -12,30 +12,30 @@
|
|||
;;; Based on a corrected version by Will F. Feb/2003
|
||||
|
||||
;; SRFI-19: Time Data Types and Procedures.
|
||||
;;
|
||||
;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
|
||||
;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
|
||||
;;
|
||||
;; 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
|
||||
;; implementation may be prepared, copied, published and distributed, in whole or
|
||||
;; 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.
|
||||
;; 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
|
||||
;; Implementation process or editors, except as needed for the purpose of
|
||||
;; 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
|
||||
;; than English.
|
||||
;;
|
||||
;; The limited permissions granted above are perpetual and will not be revoked
|
||||
;; by the authors or their successors or assigns.
|
||||
;;
|
||||
;; 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
|
||||
;; 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
|
||||
;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
|
||||
;;
|
||||
;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
|
||||
;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
|
||||
;;
|
||||
;; 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
|
||||
;; implementation may be prepared, copied, published and distributed, in whole or
|
||||
;; 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.
|
||||
;; 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
|
||||
;; Implementation process or editors, except as needed for the purpose of
|
||||
;; 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
|
||||
;; than English.
|
||||
;;
|
||||
;; The limited permissions granted above are perpetual and will not be revoked
|
||||
;; by the authors or their successors or assigns.
|
||||
;;
|
||||
;; 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
|
||||
;; 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
|
||||
;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
;; -- Racket implementation
|
||||
;;
|
||||
|
|
@ -43,13 +43,13 @@
|
|||
;; CURRENT-SECONDS, the DEFINE-STRUCT procedure (SRFI 9: Defining Record Types
|
||||
;; 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.
|
||||
;;
|
||||
;; 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
|
||||
;; is copied below.
|
||||
;;
|
||||
; 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
|
||||
; (syntax-rules ()
|
||||
|
|
@ -68,7 +68,7 @@
|
|||
(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
|
||||
;; Time object and accessors
|
||||
make-time time? time-type time-nanosecond
|
||||
make-time time? time-type time-nanosecond
|
||||
deserialize-info:tm:time-v0
|
||||
time-second set-time-type! set-time-nanosecond! set-time-second!
|
||||
copy-time
|
||||
|
|
@ -84,9 +84,9 @@
|
|||
srfi:date-year date-zone-offset
|
||||
;; 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
|
||||
|
||||
|
||||
;; The following procedures work with this modified version.
|
||||
|
||||
|
||||
;; Time/Date/Julian Day/Modified Julian Day Converters
|
||||
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
|
||||
|
|
@ -119,7 +119,7 @@
|
|||
;; the least specific one (this one *does* exist!, it comes with this srfi) don't worry:
|
||||
(load-bundle! (list 'srfi-19)))
|
||||
(set! localized? #t))
|
||||
|
||||
|
||||
(localized-template 'srfi-19 message-name)))
|
||||
|
||||
;; Constants
|
||||
|
|
@ -141,7 +141,7 @@
|
|||
(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
|
||||
'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
|
||||
'apr 'may 'jun 'jul
|
||||
'aug 'sep 'oct 'nov
|
||||
|
|
@ -151,7 +151,7 @@
|
|||
'march 'april 'may
|
||||
'june 'july 'august
|
||||
'september 'october
|
||||
'november 'december))
|
||||
'november 'december))
|
||||
|
||||
(define tm:locale-pm 'pm)
|
||||
(define tm:locale-am 'am)
|
||||
|
|
@ -171,7 +171,7 @@
|
|||
(define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
|
||||
|
||||
;; A Very simple Error system for the time procedures
|
||||
;;
|
||||
;;
|
||||
(define tm:time-error-types
|
||||
'(invalid-clock-type
|
||||
unsupported-clock-type
|
||||
|
|
@ -195,7 +195,7 @@
|
|||
;; and update as necessary.
|
||||
;; this procedures reads the file in the abover
|
||||
;; 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
|
||||
;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat"))
|
||||
|
||||
|
|
@ -208,7 +208,7 @@
|
|||
(table '()) )
|
||||
(let loop ((line (read-line port)))
|
||||
(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))
|
||||
(jd (cadddr (cdr data)))
|
||||
(secs (cadddr (cdddr data))) )
|
||||
|
|
@ -260,7 +260,7 @@
|
|||
(if (< utc-seconds (* (- 1972 1970) 365 tm:sid)) 0
|
||||
(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)
|
||||
(letrec ( (lsd (lambda (table)
|
||||
(cond ((null? table) 0)
|
||||
|
|
@ -271,7 +271,7 @@
|
|||
(lsd tm:leap-second-table))))
|
||||
|
||||
(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
|
||||
(list (cons prop:serializable
|
||||
(make-serialize-info
|
||||
|
|
@ -281,7 +281,7 @@
|
|||
(time-second t)))
|
||||
#'deserialize-info:tm:time-v0
|
||||
#f
|
||||
(or (current-load-relative-directory)
|
||||
(or (current-load-relative-directory)
|
||||
(current-directory)))))
|
||||
(make-inspector) #f null))
|
||||
|
||||
|
|
@ -315,10 +315,10 @@
|
|||
;;; These should be rewritten to be OS specific.
|
||||
;;
|
||||
;; -- using GNU gettimeofday() would be useful here -- gets
|
||||
;; second + millisecond
|
||||
;; second + millisecond
|
||||
;; let's pretend we do, using Racket's current-seconds & current-milliseconds
|
||||
;; this is supposed to return UTC.
|
||||
;;
|
||||
;;
|
||||
|
||||
(define (tm:get-time-of-day)
|
||||
(let* ((total-msecs (inexact->exact (floor (current-inexact-milliseconds)))))
|
||||
|
|
@ -337,7 +337,7 @@
|
|||
|
||||
(define (tm:current-time-ms-time time-type proc)
|
||||
(let ((current-ms (proc)))
|
||||
(make-time time-type
|
||||
(make-time time-type
|
||||
(* (remainder current-ms 1000) 1000000)
|
||||
(quotient current-ms 1000000)
|
||||
)))
|
||||
|
|
@ -448,7 +448,7 @@
|
|||
(begin
|
||||
(set-time-second! time3 0)
|
||||
(set-time-nanosecond! time3 0))
|
||||
(receive
|
||||
(receive
|
||||
(nanos secs)
|
||||
(tm:nanoseconds->values (- (tm:time->nanoseconds time1)
|
||||
(tm:time->nanoseconds time2)))
|
||||
|
|
@ -520,7 +520,7 @@
|
|||
(set-time-type! time-out time-utc)
|
||||
(set-time-nanosecond! time-out (time-nanosecond 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-out)
|
||||
|
||||
|
|
@ -538,7 +538,7 @@
|
|||
(set-time-type! time-out time-tai)
|
||||
(set-time-nanosecond! time-out (time-nanosecond time-in))
|
||||
(set-time-second! time-out (+ (time-second time-in)
|
||||
(tm:leap-second-delta
|
||||
(tm:leap-second-delta
|
||||
(time-second time-in))))
|
||||
time-out)
|
||||
|
||||
|
|
@ -617,7 +617,7 @@
|
|||
(with-handlers ([exn:fail:contract?
|
||||
(lambda (e)
|
||||
(lax-date nanosecond second minute hour
|
||||
day month year zone-offset))])
|
||||
day month year zone-offset))])
|
||||
(date* second minute hour
|
||||
day month year
|
||||
;; compute derived fields
|
||||
|
|
@ -707,7 +707,7 @@
|
|||
(else
|
||||
(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
|
||||
(define (tm:decimal-expansion r precision)
|
||||
(let loop ([num (- r (round r))]
|
||||
|
|
@ -715,7 +715,7 @@
|
|||
(if (or (= p 0) (= num 0))
|
||||
""
|
||||
(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))
|
||||
(loop (- num-times-10 round-num-times-10) (- p 1)))))))
|
||||
|
||||
|
|
@ -818,7 +818,7 @@
|
|||
(offset (date-zone-offset date)) )
|
||||
(let ( (jdays (- (tm:encode-julian-day-number day month year)
|
||||
tm:tai-epoch-in-jd)) )
|
||||
(make-time
|
||||
(make-time
|
||||
time-utc
|
||||
nanosecond
|
||||
(+ (* (- jdays 1/2) 24 60 60)
|
||||
|
|
@ -845,7 +845,7 @@
|
|||
(tm:leap-year? (srfi:date-year date)))
|
||||
|
||||
;; 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)
|
||||
(9 . 273) (10 . 304) (11 . 334)))
|
||||
|
||||
|
|
@ -860,7 +860,7 @@
|
|||
(define (srfi:date-year-day 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)
|
||||
(let* ((a (quotient (- 14 month) 12))
|
||||
(y (- year a))
|
||||
|
|
@ -887,7 +887,7 @@
|
|||
(tm:days-before-first-week date day-of-week-starting-week))
|
||||
7))
|
||||
|
||||
(define (current-date . tz-offset)
|
||||
(define (current-date . tz-offset)
|
||||
(time-utc->date (current-time time-utc)
|
||||
(:optional tz-offset (tm:local-tz-offset))))
|
||||
|
||||
|
|
@ -940,7 +940,7 @@
|
|||
(define (time-tai->julian-day time)
|
||||
(unless (eq? (time-type time) time-tai)
|
||||
(tm:time-error 'time->date 'incompatible-time-types time))
|
||||
(+ (/ (+ (- (time-second time)
|
||||
(+ (/ (+ (- (time-second time)
|
||||
(tm:leap-second-delta (time-second time)))
|
||||
(/ (time-nanosecond time) tm:nano))
|
||||
tm:sid)
|
||||
|
|
@ -954,7 +954,7 @@
|
|||
(define (time-monotonic->julian-day time)
|
||||
(unless (eq? (time-type time) time-monotonic)
|
||||
(tm:time-error 'time->date 'incompatible-time-types time))
|
||||
(+ (/ (+ (- (time-second time)
|
||||
(+ (/ (+ (- (time-second time)
|
||||
(tm:leap-second-delta (time-second time)))
|
||||
(/ (time-nanosecond time) tm:nano))
|
||||
tm:sid)
|
||||
|
|
@ -1002,7 +1002,7 @@
|
|||
(time-utc->modified-julian-day (current-time time-utc)))
|
||||
|
||||
;; 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.
|
||||
;; if string is longer than LENGTH, it's as if number->string was used.
|
||||
(define (tm:padding n pad-with length)
|
||||
|
|
@ -1016,14 +1016,14 @@
|
|||
str-len)) )
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i (string-length str)))
|
||||
(string-set! new-str (+ new-str-offset i)
|
||||
(string-set! new-str (+ new-str-offset i)
|
||||
(string-ref str i)))
|
||||
new-str))))
|
||||
|
||||
(define (tm:last-n-digits i 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)))
|
||||
|
||||
(define (tm:locale-long-weekday n)
|
||||
|
|
@ -1058,9 +1058,9 @@
|
|||
|
||||
|
||||
|
||||
;; do nothing.
|
||||
;; do nothing.
|
||||
;; Your implementation might want to do something...
|
||||
;;
|
||||
;;
|
||||
(define (tm:locale-print-time-zone date port)
|
||||
(values))
|
||||
|
||||
|
|
@ -1084,10 +1084,10 @@
|
|||
;; the second is a procedure that takes the date, a padding character
|
||||
;; (which might be #f), and the output port.
|
||||
;;
|
||||
(define tm:directives
|
||||
(define tm:directives
|
||||
(list
|
||||
(cons #\~ (lambda (date pad-with port) (display #\~ port)))
|
||||
|
||||
|
||||
(cons #\a (lambda (date pad-with port)
|
||||
(display (tm:locale-abbr-weekday (srfi:date-week-day date))
|
||||
port)))
|
||||
|
|
@ -1208,7 +1208,7 @@
|
|||
(display (tm:padding (date-week-number date 1)
|
||||
#\0 2) 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)
|
||||
pad-with
|
||||
2)
|
||||
|
|
@ -1245,45 +1245,45 @@
|
|||
(display current-char port)
|
||||
(tm:date-printer date (+ index 1) format-string str-len port))
|
||||
(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)
|
||||
(let ( (pad-char? (string-ref format-string (+ index 1))) )
|
||||
(cond
|
||||
((char=? pad-char? #\-)
|
||||
(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)
|
||||
(let ( (formatter (tm:get-formatter
|
||||
(let ( (formatter (tm:get-formatter
|
||||
(string-ref format-string
|
||||
(+ index 2)))) )
|
||||
(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)
|
||||
(begin
|
||||
(formatter date #f port)
|
||||
(tm:date-printer date (+ index 3)
|
||||
format-string str-len port))))))
|
||||
|
||||
|
||||
((char=? pad-char? #\_)
|
||||
(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)
|
||||
(let ( (formatter (tm:get-formatter
|
||||
(let ( (formatter (tm:get-formatter
|
||||
(string-ref format-string
|
||||
(+ index 2)))) )
|
||||
(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)
|
||||
(begin
|
||||
(formatter date #\Space port)
|
||||
(tm:date-printer date (+ index 3)
|
||||
format-string str-len port))))))
|
||||
(else
|
||||
(let ( (formatter (tm:get-formatter
|
||||
(let ( (formatter (tm:get-formatter
|
||||
(string-ref format-string
|
||||
(+ index 1)))) )
|
||||
(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)
|
||||
(begin
|
||||
(formatter date #\0 port)
|
||||
|
|
@ -1331,7 +1331,7 @@
|
|||
|
||||
;; 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.
|
||||
(define (tm:fractional-integer-reader upto port)
|
||||
(define (accum-int port accum nchars)
|
||||
|
|
@ -1354,8 +1354,8 @@
|
|||
(let ((ch (peek-char port)))
|
||||
(cond
|
||||
((>= nchars n) accum)
|
||||
((eof-object? ch)
|
||||
(tm:time-error 'string->date 'bad-date-template-string
|
||||
((eof-object? ch)
|
||||
(tm:time-error 'string->date 'bad-date-template-string
|
||||
"Premature ending to integer read."))
|
||||
((char-numeric? ch)
|
||||
(set! padding-ok #f)
|
||||
|
|
@ -1365,7 +1365,7 @@
|
|||
(read-char port) ; consume padding
|
||||
(accum-int port accum (+ nchars 1)))
|
||||
(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.")))))
|
||||
(accum-int port 0 0)))
|
||||
|
||||
|
|
@ -1374,8 +1374,8 @@
|
|||
(lambda (port)
|
||||
(tm:integer-reader-exact n port)))
|
||||
|
||||
(define (tm:zone-reader port)
|
||||
(let ( (offset 0)
|
||||
(define (tm:zone-reader port)
|
||||
(let ( (offset 0)
|
||||
(positive? #f) )
|
||||
(let ( (ch (read-char port)) )
|
||||
(when (eof-object? ch)
|
||||
|
|
@ -1418,10 +1418,10 @@
|
|||
(define (read-char-string)
|
||||
(let ((ch (peek-char port)))
|
||||
(if (char-alphabetic? ch)
|
||||
(begin (write-char (read-char port) string-port)
|
||||
(begin (write-char (read-char port) string-port)
|
||||
(read-char-string))
|
||||
(get-output-string string-port))))
|
||||
(let* ( (str (read-char-string))
|
||||
(let* ( (str (read-char-string))
|
||||
(index (indexer str)) )
|
||||
(if index index (tm:time-error 'string->date
|
||||
'bad-date-template-string
|
||||
|
|
@ -1441,7 +1441,7 @@
|
|||
|
||||
;; A List of formatted read directives.
|
||||
;; Each entry is a list.
|
||||
;; 1. the character directive;
|
||||
;; 1. the character directive;
|
||||
;; a procedure, which takes a character as input & returns
|
||||
;; 2. #t as soon as a character on the input port is acceptable
|
||||
;; for input,
|
||||
|
|
@ -1450,7 +1450,7 @@
|
|||
;; 4. a action procedure, that takes the value (from 3.) and some
|
||||
;; object (here, always the date) and (probably) side-effects it.
|
||||
;; 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))
|
||||
(ireader2 (tm:make-integer-reader 2))
|
||||
(fireader9 (tm:make-fractional-integer-reader 9))
|
||||
|
|
@ -1468,7 +1468,7 @@
|
|||
(char-fail (lambda (ch) #t))
|
||||
(do-nothing (lambda (val object) (values)))
|
||||
)
|
||||
|
||||
|
||||
(list
|
||||
(list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing)
|
||||
(list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
|
||||
|
|
@ -1506,7 +1506,7 @@
|
|||
(list #\S char-numeric? ireader2
|
||||
(lambda (val object)
|
||||
(struct-copy lax-date object [second val])))
|
||||
(list #\y char-fail eireader2
|
||||
(list #\y char-fail eireader2
|
||||
(lambda (val object)
|
||||
(struct-copy lax-date object
|
||||
[year (tm:natural-year val)])))
|
||||
|
|
@ -1586,6 +1586,6 @@
|
|||
(if (tm:date-ok? newdate)
|
||||
(lax-date->date* newdate)
|
||||
(tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;; Tests by Will Fitzgerald, augmented by:
|
||||
;; 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
|
||||
;; John Clements (nanoseconds off by x100) -- 2009-12-15
|
||||
;; Dave Gurnell (serializable dates and times) -- 2010-03-03
|
||||
|
|
@ -31,7 +31,7 @@
|
|||
|
||||
(define srfi-19-test-suite
|
||||
(test-suite "Tests for SRFI 19"
|
||||
|
||||
|
||||
(test-not-exn "Creating time structures"
|
||||
(lambda ()
|
||||
(list (current-time 'time-tai)
|
||||
|
|
@ -39,7 +39,7 @@
|
|||
(current-time 'time-monotonic)
|
||||
(current-time 'time-thread)
|
||||
(current-time 'time-process))))
|
||||
|
||||
|
||||
(test-not-exn "Testing time resolutions"
|
||||
(lambda ()
|
||||
(list (time-resolution 'time-tai)
|
||||
|
|
@ -47,7 +47,7 @@
|
|||
(time-resolution 'time-monotonic)
|
||||
(time-resolution 'time-thread)
|
||||
(time-resolution 'time-process))))
|
||||
|
||||
|
||||
(test-case "Time comparisons (time=?, etc.)"
|
||||
(let ([t0 (make-time 'time-utc 0 1)]
|
||||
[t1 (make-time 'time-utc 0 1)]
|
||||
|
|
@ -73,7 +73,7 @@
|
|||
(#t #t #f #f)
|
||||
(#t #t #t #f)
|
||||
(#t #t #t #t)))))
|
||||
|
||||
|
||||
(test-case "Time difference"
|
||||
(let ((t1 (make-time 'time-utc 0 3000))
|
||||
(t2 (make-time 'time-utc 0 1000))
|
||||
|
|
@ -81,7 +81,7 @@
|
|||
(t4 (make-time 'time-duration 0 -2000)))
|
||||
(check time=? t3 (time-difference t1 t2))
|
||||
(check time=? t4 (time-difference t2 t1))))
|
||||
|
||||
|
||||
(test-case "TAI-UTC Conversions"
|
||||
(check-one-utc-tai-edge 915148800 32 31)
|
||||
(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 10 0 0) ;; close to it ...
|
||||
(check-one-utc-tai-edge 1045789645 32 32)) ;; about now ...
|
||||
|
||||
|
||||
(test-case "TAI-Date Conversions"
|
||||
(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))
|
||||
|
|
@ -119,7 +119,7 @@
|
|||
(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)
|
||||
(srfi:make-date 0 0 0 0 1 1 1999 0)))
|
||||
|
||||
|
||||
(test-case "Date-UTC Conversions"
|
||||
(check time=? (make-time time-utc 0 (- 915148800 2))
|
||||
(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)))
|
||||
(check time=? (make-time time-utc 0 (+ 915148800 1))
|
||||
(date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0))))
|
||||
|
||||
|
||||
(test-case "TZ Offset conversions"
|
||||
(let ((ct-utc (make-time time-utc 6320000 1045944859))
|
||||
(ct-tai (make-time time-tai 6320000 1045944891))
|
||||
(cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000)))
|
||||
(check time=? ct-utc (date->time-utc 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...
|
||||
(test-case "date->string conversions"
|
||||
(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")
|
||||
"~ @ 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"
|
||||
(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")
|
||||
|
|
@ -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 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"))
|
||||
|
||||
|
||||
(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")
|
||||
|
|
@ -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.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"))
|
||||
|
||||
|
||||
(test-case "interpretation of 1- to 4-digit years by ~y, ~Y and ~?:"
|
||||
; ~y:
|
||||
(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 "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)))))
|
||||
|
||||
|
||||
(test-case "type-like error on date->string"
|
||||
(check-exn
|
||||
(lambda (exn)
|
||||
(check-exn
|
||||
(lambda (exn)
|
||||
(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))))
|
||||
|
||||
|
||||
|
||||
|
||||
(test-case "date<->julian-day conversion"
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
|
||||
(test-case "date->modified-julian-day conversion"
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
|
||||
(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-tai 2 3))) (make-time time-tai 2 3))
|
||||
|
|
@ -248,7 +248,7 @@
|
|||
2004)
|
||||
(check-equal? (srfi:date-year (srfi:make-date 0 0 0 0 1 1 2004 0))
|
||||
2004))
|
||||
|
||||
|
||||
;; nanoseconds off by a factor of 100...
|
||||
(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)
|
||||
|
|
@ -269,19 +269,19 @@
|
|||
(tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
|
||||
(utc->tai-basic (time-utc->time-tai utc-basic))
|
||||
(tai->utc-basic (time-tai->time-utc tai-basic))
|
||||
|
||||
|
||||
;; a second before they should be the old diff
|
||||
(utc-basic-1 (make-time 'time-utc 0 (- utc 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))
|
||||
(tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
|
||||
|
||||
|
||||
;; a second later they should be the new diff
|
||||
(utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
|
||||
(tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
|
||||
(utc->tai-basic+1 (time-utc->time-tai utc-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
|
||||
(shy (* 15 24 60 60))
|
||||
(hs (/ (expt 10 9) 2))
|
||||
|
|
@ -290,7 +290,7 @@
|
|||
(tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
|
||||
(utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
|
||||
(tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
|
||||
|
||||
|
||||
(check time=? utc-basic tai->utc-basic)
|
||||
(check time=? tai-basic utc->tai-basic)
|
||||
(check time=? utc-basic-1 tai->utc-basic-1)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user