@@ -0,0 +1,1533 @@
1+;; DO NOT EDIT THIS FILE!!
2+;; This inlined chez-srfi library code is autogenerated using command:
3+;; $ ./install.chezscheme.sps ../lib
4+;; Source origin: https://github.com/arcfide/chez-srfi
5+;; Please refer to project site for full credits and original code.
6+;;;;;; File header: %3a19/time.sls
7+#!r6rs
8+;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named
9+;; LICENSE from the original collection this file is distributed with.
10+;;;;;; File header: %3a19/srfi-19.scm
11+;; SRFI-19: Time Data Types and Procedures.
12+;;
13+;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
14+;;
15+;; Permission is hereby granted, free of charge, to any person obtaining
16+;; a copy of this software and associated documentation files (the
17+;; "Software"), to deal in the Software without restriction, including
18+;; without limitation the rights to use, copy, modify, merge, publish,
19+;; distribute, sublicense, and/or sell copies of the Software, and to
20+;; permit persons to whom the Software is furnished to do so, subject to
21+;; the following conditions:
22+;;
23+;; The above copyright notice and this permission notice shall be
24+;; included in all copies or substantial portions of the Software.
25+;;
26+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
27+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
28+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
29+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
30+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
31+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
32+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
33+(library (srfi :19 time)
34+ (export time-duration time-monotonic time-process time-tai
35+ time-thread time-utc current-date current-julian-day
36+ current-modified-julian-day current-time time-resolution
37+ make-time time? time-type time-nanosecond time-second
38+ set-time-type! set-time-nanosecond! set-time-second!
39+ copy-time time<=? time<? time=? time>=? time>?
40+ time-difference time-difference! add-duration add-duration!
41+ subtract-duration subtract-duration! make-date date?
42+ date-nanosecond date-second date-minute date-hour date-day
43+ date-month date-year date-zone-offset date-year-day
44+ date-week-day date-week-number date->julian-day
45+ date->modified-julian-day date->time-monotonic
46+ date->time-tai date->time-utc julian-day->date
47+ julian-day->time-monotonic julian-day->time-tai
48+ julian-day->time-utc modified-julian-day->date
49+ modified-julian-day->time-monotonic
50+ modified-julian-day->time-tai modified-julian-day->time-utc
51+ time-monotonic->date time-monotonic->julian-day
52+ time-monotonic->modified-julian-day time-monotonic->time-tai
53+ time-monotonic->time-tai! time-monotonic->time-utc
54+ time-monotonic->time-utc! time-tai->date
55+ time-tai->julian-day time-tai->modified-julian-day
56+ time-tai->time-monotonic time-tai->time-monotonic!
57+ time-tai->time-utc time-tai->time-utc! time-utc->date
58+ time-utc->julian-day time-utc->modified-julian-day
59+ time-utc->time-monotonic time-utc->time-monotonic!
60+ time-utc->time-tai time-utc->time-tai! date->string
61+ string->date)
62+ (import (rnrs) (rnrs r5rs) (rnrs mutable-strings)
63+ (prefix (srfi :19 time compat) host:)
64+ (srfi :6 basic-string-ports)
65+ (for (srfi private vanish) expand) (srfi private include))
66+ (define-syntax define-struct
67+ (lambda (stx)
68+ (define (id-append x . r)
69+ (datum->syntax
70+ x
71+ (string->symbol
72+ (apply
73+ string-append
74+ (map (lambda (y)
75+ (if (identifier? y)
76+ (symbol->string (syntax->datum y))
77+ y))
78+ r)))))
79+ (syntax-case stx ()
80+ [(_ name (field ...) _)
81+ (with-syntax ([(accessor ...) (map (lambda (x)
82+ (id-append x #'name "-" x))
83+ #'(field ...))]
84+ [(mutator ...) (map (lambda (x)
85+ (id-append x "set-" #'name "-"
86+ x "!"))
87+ #'(field ...))])
88+ #'(define-record-type name
89+ (fields (mutable field accessor mutator) ...)))])))
90+ (define read-line get-line)
91+ (define (tm:time-error caller type value)
92+ (define (message x)
93+ (if (symbol? x)
94+ (list->string
95+ (map (lambda (c) (if (char=? #\- c) #\space c))
96+ (string->list (symbol->string x))))
97+ (call-with-string-output-port
98+ (lambda (sop) (write x sop)))))
99+ (apply
100+ assertion-violation
101+ caller
102+ (message type)
103+ (if value (list value) '())))
104+ (define (my:time-helper current-time type proc)
105+ (let ([x (current-time)])
106+ (make-time
107+ type
108+ (host:time-nanosecond x)
109+ (proc (host:time-second x)))))
110+ (define (my:leap-second-helper s)
111+ (+ s (tm:leap-second-delta s)))
112+ (define (tm:current-time-utc)
113+ (my:time-helper host:current-time time-utc values))
114+ (define (tm:current-time-tai)
115+ (my:time-helper
116+ host:current-time
117+ time-tai
118+ my:leap-second-helper))
119+ (define (tm:current-time-monotonic)
120+ (my:time-helper
121+ host:current-time
122+ time-monotonic
123+ my:leap-second-helper))
124+ (define (tm:current-time-thread)
125+ (my:time-helper
126+ host:cumulative-thread-time
127+ time-thread
128+ values))
129+ (define (tm:current-time-process)
130+ (my:time-helper
131+ host:cumulative-process-time
132+ time-process
133+ values))
134+ (define (tm:current-time-gc)
135+ (my:time-helper host:cumulative-gc-time time-gc values))
136+ (define (time-resolution . clock-type) host:time-resolution)
137+ (define (tm:local-tz-offset) host:timezone-offset)
138+ (define eof (eof-object))
139+ (let-syntax ([define (vanish-define
140+ define
141+ (tm:time-error-types tm:time-error tm:get-time-of-day
142+ tm:current-time-utc tm:current-time-tai
143+ tm:current-time-ms-time
144+ tm:current-time-monotonic tm:current-time-thread
145+ tm:current-time-process tm:current-time-gc
146+ time-resolution set-date-nanosecond!
147+ set-date-second! set-date-minute! set-date-hour!
148+ set-date-day! set-date-month! set-date-year!
149+ set-date-zone-offset! tm:local-tz-offset))])
150+ (begin
151+ (define-syntax receive
152+ (syntax-rules ()
153+ [(receive formals expression body ...)
154+ (call-with-values
155+ (lambda () expression)
156+ (lambda formals body ...))]))
157+ (define-syntax :optional
158+ (syntax-rules ()
159+ [(_ val default-value)
160+ (if (null? val) default-value (car val))]))
161+ (define time-tai 'time-tai)
162+ (define time-utc 'time-utc)
163+ (define time-monotonic 'time-monotonic)
164+ (define time-thread 'time-thread)
165+ (define time-process 'time-process)
166+ (define time-duration 'time-duration)
167+ (define time-gc 'time-gc)
168+ (define tm:locale-number-separator ".")
169+ (define tm:locale-abbr-weekday-vector
170+ (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
171+ (define tm:locale-long-weekday-vector
172+ (vector "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday"
173+ "Friday" "Saturday"))
174+ (define tm:locale-abbr-month-vector
175+ (vector "" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
176+ "Sep" "Oct" "Nov" "Dec"))
177+ (define tm:locale-long-month-vector
178+ (vector "" "January" "February" "March" "April" "May" "June"
179+ "July" "August" "September" "October" "November"
180+ "December"))
181+ (define tm:locale-pm "PM")
182+ (define tm:locale-am "AM")
183+ (define tm:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
184+ (define tm:locale-short-date-format "~m/~d/~y")
185+ (define tm:locale-time-format "~H:~M:~S")
186+ (define tm:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
187+ (define tm:nano (expt 10 9))
188+ (define tm:sid 86400)
189+ (define tm:sihd 43200)
190+ (define tm:tai-epoch-in-jd 4881175/2)
191+ (define tm:time-error-types
192+ '(invalid-clock-type unsupported-clock-type incompatible-time-types not-duration
193+ dates-are-immutable bad-date-format-string
194+ bad-date-template-string invalid-month-specification))
195+ (define (tm:time-error caller type value)
196+ (if (member type tm:time-error-types)
197+ (if value
198+ (error caller "TIME-ERROR type ~S: ~S" type value)
199+ (error caller "TIME-ERROR type ~S" type))
200+ (error caller "TIME-ERROR unsupported error type ~S" type)))
201+ (define (tm:read-tai-utc-data filename)
202+ (define (convert-jd jd)
203+ (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid))
204+ (define (convert-sec sec) (inexact->exact sec))
205+ (let ([port (open-input-file filename)] [table '()])
206+ (let loop ([line (read-line port)])
207+ (if (not (eq? line eof))
208+ (begin
209+ (let* ([data (read
210+ (open-input-string
211+ (string-append "(" line ")")))]
212+ [year (car data)]
213+ [jd (cadddr (cdr data))]
214+ [secs (cadddr (cdddr data))])
215+ (if (>= year 1972)
216+ (set! table
217+ (cons
218+ (cons (convert-jd jd) (convert-sec secs))
219+ table)))
220+ (loop (read-line port))))))
221+ table))
222+ (define tm:leap-second-table
223+ '((1483228800 . 37) (1435708800 . 36) (1341100800 . 35)
224+ (1230768000 . 34) (1136073600 . 33) (915148800 . 32)
225+ (867715200 . 31) (820454400 . 30) (773020800 . 29)
226+ (741484800 . 28) (709948800 . 27) (662688000 . 26)
227+ (631152000 . 25) (567993600 . 24) (489024000 . 23)
228+ (425865600 . 22) (394329600 . 21) (362793600 . 20)
229+ (315532800 . 19) (283996800 . 18) (252460800 . 17)
230+ (220924800 . 16) (189302400 . 15) (157766400 . 14)
231+ (126230400 . 13) (94694400 . 12) (78796800 . 11)
232+ (63072000 . 10)))
233+ (define (read-leap-second-table filename)
234+ (set! tm:leap-second-table (tm:read-tai-utc-data filename))
235+ (values))
236+ (define (tm:leap-second-delta utc-seconds)
237+ (letrec ([lsd (lambda (table)
238+ (cond
239+ [(>= utc-seconds (caar table)) (cdar table)]
240+ [else (lsd (cdr table))]))])
241+ (if (< utc-seconds (* (- 1972 1970) 365 tm:sid))
242+ 0
243+ (lsd tm:leap-second-table))))
244+ (define (tm:leap-second-neg-delta tai-seconds)
245+ (letrec ([lsd (lambda (table)
246+ (cond
247+ [(null? table) 0]
248+ [(<= (cdar table) (- tai-seconds (caar table)))
249+ (cdar table)]
250+ [else (lsd (cdr table))]))])
251+ (if (< tai-seconds (* (- 1972 1970) 365 tm:sid))
252+ 0
253+ (lsd tm:leap-second-table))))
254+ (define-struct
255+ time
256+ (type nanosecond second)
257+ (make-inspector))
258+ (define (copy-time time)
259+ (make-time
260+ (time-type time)
261+ (time-nanosecond time)
262+ (time-second time)))
263+ (define (tm:get-time-of-day)
264+ (values
265+ (current-seconds)
266+ (abs (remainder (current-milliseconds) 1000))))
267+ (define (tm:current-time-utc)
268+ (receive
269+ (seconds ms)
270+ (tm:get-time-of-day)
271+ (make-time time-utc (* ms 10000) seconds)))
272+ (define (tm:current-time-tai)
273+ (receive
274+ (seconds ms)
275+ (tm:get-time-of-day)
276+ (make-time
277+ time-tai
278+ (* ms 10000)
279+ (+ seconds (tm:leap-second-delta seconds)))))
280+ (define (tm:current-time-ms-time time-type proc)
281+ (let ([current-ms (proc)])
282+ (make-time
283+ time-type
284+ (* (remainder current-ms 1000) 10000)
285+ (quotient current-ms 10000))))
286+ (define (tm:current-time-monotonic)
287+ (receive
288+ (seconds ms)
289+ (tm:get-time-of-day)
290+ (make-time
291+ time-monotonic
292+ (* ms 10000)
293+ (+ seconds (tm:leap-second-delta seconds)))))
294+ (define (tm:current-time-thread)
295+ (tm:current-time-ms-time
296+ time-process
297+ current-process-milliseconds))
298+ (define (tm:current-time-process)
299+ (tm:current-time-ms-time
300+ time-process
301+ current-process-milliseconds))
302+ (define (tm:current-time-gc)
303+ (tm:current-time-ms-time time-gc current-gc-milliseconds))
304+ (define (current-time . clock-type)
305+ (let ([clock-type (:optional clock-type time-utc)])
306+ (cond
307+ [(eq? clock-type time-tai) (tm:current-time-tai)]
308+ [(eq? clock-type time-utc) (tm:current-time-utc)]
309+ [(eq? clock-type time-monotonic)
310+ (tm:current-time-monotonic)]
311+ [(eq? clock-type time-thread) (tm:current-time-thread)]
312+ [(eq? clock-type time-process) (tm:current-time-process)]
313+ [(eq? clock-type time-gc) (tm:current-time-gc)]
314+ [else
315+ (tm:time-error
316+ 'current-time
317+ 'invalid-clock-type
318+ clock-type)])))
319+ (define (time-resolution . clock-type)
320+ (let ([clock-type (:optional clock-type time-utc)])
321+ (cond
322+ [(eq? clock-type time-tai) 10000]
323+ [(eq? clock-type time-utc) 10000]
324+ [(eq? clock-type time-monotonic) 10000]
325+ [(eq? clock-type time-thread) 10000]
326+ [(eq? clock-type time-process) 10000]
327+ [(eq? clock-type time-gc) 10000]
328+ [else
329+ (tm:time-error
330+ 'time-resolution
331+ 'invalid-clock-type
332+ clock-type)])))
333+ (define (tm:time-compare-check time1 time2 caller)
334+ (if (or (not (and (time? time1) (time? time2)))
335+ (not (eq? (time-type time1) (time-type time2))))
336+ (tm:time-error caller 'incompatible-time-types #f)
337+ #t))
338+ (define (time=? time1 time2)
339+ (tm:time-compare-check time1 time2 'time=?)
340+ (and (= (time-second time1) (time-second time2))
341+ (= (time-nanosecond time1) (time-nanosecond time2))))
342+ (define (time>? time1 time2)
343+ (tm:time-compare-check time1 time2 'time>?)
344+ (or (> (time-second time1) (time-second time2))
345+ (and (= (time-second time1) (time-second time2))
346+ (> (time-nanosecond time1) (time-nanosecond time2)))))
347+ (define (time<? time1 time2)
348+ (tm:time-compare-check time1 time2 'time<?)
349+ (or (< (time-second time1) (time-second time2))
350+ (and (= (time-second time1) (time-second time2))
351+ (< (time-nanosecond time1) (time-nanosecond time2)))))
352+ (define (time>=? time1 time2)
353+ (tm:time-compare-check time1 time2 'time>=?)
354+ (or (> (time-second time1) (time-second time2))
355+ (and (= (time-second time1) (time-second time2))
356+ (>= (time-nanosecond time1) (time-nanosecond time2)))))
357+ (define (time<=? time1 time2)
358+ (tm:time-compare-check time1 time2 'time<=?)
359+ (or (< (time-second time1) (time-second time2))
360+ (and (= (time-second time1) (time-second time2))
361+ (<= (time-nanosecond time1) (time-nanosecond time2)))))
362+ (define (tm:time->nanoseconds time)
363+ (define (sign1 n) (if (negative? n) -1 1))
364+ (+ (* (time-second time) tm:nano) (time-nanosecond time)))
365+ (define (tm:nanoseconds->time time-type nanoseconds)
366+ (make-time
367+ time-type
368+ (remainder nanoseconds tm:nano)
369+ (quotient nanoseconds tm:nano)))
370+ (define (tm:nanoseconds->values nanoseconds)
371+ (values
372+ (abs (remainder nanoseconds tm:nano))
373+ (quotient nanoseconds tm:nano)))
374+ (define (tm:time-difference time1 time2 time3)
375+ (if (or (not (and (time? time1) (time? time2)))
376+ (not (eq? (time-type time1) (time-type time2))))
377+ (tm:time-error
378+ 'time-difference
379+ 'incompatible-time-types
380+ #f))
381+ (set-time-type! time3 time-duration)
382+ (if (time=? time1 time2)
383+ (begin
384+ (set-time-second! time3 0)
385+ (set-time-nanosecond! time3 0))
386+ (receive
387+ (nanos secs)
388+ (tm:nanoseconds->values
389+ (- (tm:time->nanoseconds time1)
390+ (tm:time->nanoseconds time2)))
391+ (set-time-second! time3 secs)
392+ (set-time-nanosecond! time3 nanos)))
393+ time3)
394+ (define (time-difference time1 time2)
395+ (tm:time-difference time1 time2 (make-time #f #f #f)))
396+ (define (time-difference! time1 time2)
397+ (tm:time-difference time1 time2 time1))
398+ (define (tm:add-duration time1 duration time3)
399+ (if (not (and (time? time1) (time? duration)))
400+ (tm:time-error 'add-duration 'incompatible-time-types #f))
401+ (if (not (eq? (time-type duration) time-duration))
402+ (tm:time-error 'add-duration 'not-duration duration)
403+ (let ([sec-plus (+ (time-second time1)
404+ (time-second duration))]
405+ [nsec-plus (+ (time-nanosecond time1)
406+ (time-nanosecond duration))])
407+ (let ([r (remainder nsec-plus tm:nano)]
408+ [q (quotient nsec-plus tm:nano)])
409+ (if (negative? r)
410+ (begin
411+ (set-time-second! time3 (+ sec-plus q -1))
412+ (set-time-nanosecond! time3 (+ tm:nano r)))
413+ (begin
414+ (set-time-second! time3 (+ sec-plus q))
415+ (set-time-nanosecond! time3 r)))
416+ time3))))
417+ (define (add-duration time1 duration)
418+ (tm:add-duration
419+ time1
420+ duration
421+ (make-time (time-type time1) #f #f)))
422+ (define (add-duration! time1 duration)
423+ (tm:add-duration time1 duration time1))
424+ (define (tm:subtract-duration time1 duration time3)
425+ (if (not (and (time? time1) (time? duration)))
426+ (tm:time-error 'add-duration 'incompatible-time-types #f))
427+ (if (not (eq? (time-type duration) time-duration))
428+ (tm:time-error 'tm:subtract-duration 'not-duration duration)
429+ (let ([sec-minus (- (time-second time1)
430+ (time-second duration))]
431+ [nsec-minus (- (time-nanosecond time1)
432+ (time-nanosecond duration))])
433+ (let ([r (remainder nsec-minus tm:nano)]
434+ [q (quotient nsec-minus tm:nano)])
435+ (if (negative? r)
436+ (begin
437+ (set-time-second! time3 (- sec-minus q 1))
438+ (set-time-nanosecond! time3 (+ tm:nano r)))
439+ (begin
440+ (set-time-second! time3 (- sec-minus q))
441+ (set-time-nanosecond! time3 r)))
442+ time3))))
443+ (define (subtract-duration time1 duration)
444+ (tm:subtract-duration
445+ time1
446+ duration
447+ (make-time (time-type time1) #f #f)))
448+ (define (subtract-duration! time1 duration)
449+ (tm:subtract-duration time1 duration time1))
450+ (define (tm:time-tai->time-utc! time-in time-out caller)
451+ (if (not (eq? (time-type time-in) time-tai))
452+ (tm:time-error caller 'incompatible-time-types time-in))
453+ (set-time-type! time-out time-utc)
454+ (set-time-nanosecond! time-out (time-nanosecond time-in))
455+ (set-time-second!
456+ time-out
457+ (- (time-second time-in)
458+ (tm:leap-second-neg-delta (time-second time-in))))
459+ time-out)
460+ (define (time-tai->time-utc time-in)
461+ (tm:time-tai->time-utc!
462+ time-in
463+ (make-time #f #f #f)
464+ 'time-tai->time-utc))
465+ (define (time-tai->time-utc! time-in)
466+ (tm:time-tai->time-utc!
467+ time-in
468+ time-in
469+ 'time-tai->time-utc!))
470+ (define (tm:time-utc->time-tai! time-in time-out caller)
471+ (if (not (eq? (time-type time-in) time-utc))
472+ (tm:time-error caller 'incompatible-time-types time-in))
473+ (set-time-type! time-out time-tai)
474+ (set-time-nanosecond! time-out (time-nanosecond time-in))
475+ (set-time-second!
476+ time-out
477+ (+ (time-second time-in)
478+ (tm:leap-second-delta (time-second time-in))))
479+ time-out)
480+ (define (time-utc->time-tai time-in)
481+ (tm:time-utc->time-tai!
482+ time-in
483+ (make-time #f #f #f)
484+ 'time-utc->time-tai))
485+ (define (time-utc->time-tai! time-in)
486+ (tm:time-utc->time-tai!
487+ time-in
488+ time-in
489+ 'time-utc->time-tai!))
490+ (define (time-monotonic->time-utc time-in)
491+ (if (not (eq? (time-type time-in) time-monotonic))
492+ (tm:time-error
493+ 'time-monotoinc->time-utc
494+ 'incompatible-time-types
495+ time-in))
496+ (let ([ntime (copy-time time-in)])
497+ (set-time-type! ntime time-tai)
498+ (tm:time-tai->time-utc!
499+ ntime
500+ ntime
501+ 'time-monotonic->time-utc)))
502+ (define (time-monotonic->time-utc! time-in)
503+ (if (not (eq? (time-type time-in) time-monotonic))
504+ (tm:time-error
505+ 'time-monotonic->time-utc!
506+ 'incompatible-time-types
507+ time-in))
508+ (set-time-type! time-in time-tai)
509+ (tm:time-tai->time-utc!
510+ time-in
511+ time-in
512+ 'time-monotonic->time-utc))
513+ (define (time-monotonic->time-tai time-in)
514+ (if (not (eq? (time-type time-in) time-monotonic))
515+ (tm:time-error
516+ 'time-monotonic->time-tai
517+ 'incompatible-time-types
518+ time-in))
519+ (let ([ntime (copy-time time-in)])
520+ (set-time-type! ntime time-tai)
521+ ntime))
522+ (define (time-monotonic->time-tai! time-in)
523+ (if (not (eq? (time-type time-in) time-monotonic))
524+ (tm:time-error
525+ 'time-monotonic->time-tai!
526+ 'incompatible-time-types
527+ time-in))
528+ (set-time-type! time-in time-tai)
529+ time-in)
530+ (define (time-utc->time-monotonic time-in)
531+ (if (not (eq? (time-type time-in) time-utc))
532+ (tm:time-error
533+ 'time-utc->time-monotonic
534+ 'incompatible-time-types
535+ time-in))
536+ (let ([ntime (tm:time-utc->time-tai!
537+ time-in
538+ (make-time #f #f #f)
539+ 'time-utc->time-monotonic)])
540+ (set-time-type! ntime time-monotonic)
541+ ntime))
542+ (define (time-utc->time-monotonic! time-in)
543+ (if (not (eq? (time-type time-in) time-utc))
544+ (tm:time-error
545+ 'time-utc->time-montonic!
546+ 'incompatible-time-types
547+ time-in))
548+ (let ([ntime (tm:time-utc->time-tai!
549+ time-in
550+ time-in
551+ 'time-utc->time-monotonic!)])
552+ (set-time-type! ntime time-monotonic)
553+ ntime))
554+ (define (time-tai->time-monotonic time-in)
555+ (if (not (eq? (time-type time-in) time-tai))
556+ (tm:time-error
557+ 'time-tai->time-monotonic
558+ 'incompatible-time-types
559+ time-in))
560+ (let ([ntime (copy-time time-in)])
561+ (set-time-type! ntime time-monotonic)
562+ ntime))
563+ (define (time-tai->time-monotonic! time-in)
564+ (if (not (eq? (time-type time-in) time-tai))
565+ (tm:time-error
566+ 'time-tai->time-monotonic!
567+ 'incompatible-time-types
568+ time-in))
569+ (set-time-type! time-in time-monotonic)
570+ time-in)
571+ (define-struct
572+ date
573+ (nanosecond second minute hour day month year zone-offset)
574+ (make-inspector))
575+ (define tm:set-date-nanosecond! set-date-nanosecond!)
576+ (define tm:set-date-second! set-date-second!)
577+ (define tm:set-date-minute! set-date-minute!)
578+ (define tm:set-date-hour! set-date-hour!)
579+ (define tm:set-date-day! set-date-day!)
580+ (define tm:set-date-month! set-date-month!)
581+ (define tm:set-date-year! set-date-year!)
582+ (define tm:set-date-zone-offset! set-date-zone-offset!)
583+ (define (set-date-second! date val)
584+ (tm:time-error 'set-date-second! 'dates-are-immutable date))
585+ (define (set-date-minute! date val)
586+ (tm:time-error 'set-date-minute! 'dates-are-immutable date))
587+ (define (set-date-day! date val)
588+ (tm:time-error 'set-date-day! 'dates-are-immutable date))
589+ (define (set-date-month! date val)
590+ (tm:time-error 'set-date-month! 'dates-are-immutable date))
591+ (define (set-date-year! date val)
592+ (tm:time-error 'set-date-year! 'dates-are-immutable date))
593+ (define (set-date-zone-offset! date val)
594+ (tm:time-error
595+ 'set-date-zone-offset!
596+ 'dates-are-immutable
597+ date))
598+ (define (tm:encode-julian-day-number day month year)
599+ (let* ([a (quotient (- 14 month) 12)]
600+ [y (- (- (+ year 4800) a) (if (negative? year) -1 0))]
601+ [m (- (+ month (* 12 a)) 3)])
602+ (+ day (quotient (+ (* 153 m) 2) 5) (* 365 y) (quotient y 4)
603+ (- (quotient y 100)) (quotient y 400) -32045)))
604+ (define (tm:char-pos char str index len)
605+ (cond
606+ [(>= index len) #f]
607+ [(char=? (string-ref str index) char) index]
608+ [else (tm:char-pos char str (+ index 1) len)]))
609+ (define (tm:fractional-part r)
610+ (if (integer? r)
611+ "0"
612+ (let ([str (number->string (exact->inexact r))])
613+ (let ([ppos (tm:char-pos #\. str 0 (string-length str))])
614+ (substring str (+ ppos 1) (string-length str))))))
615+ (define (tm:decode-julian-day-number jdn)
616+ (let* ([days (truncate jdn)]
617+ [a (+ days 32044)]
618+ [b (quotient (+ (* 4 a) 3) 146097)]
619+ [c (- a (quotient (* 146097 b) 4))]
620+ [d (quotient (+ (* 4 c) 3) 1461)]
621+ [e (- c (quotient (* 1461 d) 4))]
622+ [m (quotient (+ (* 5 e) 2) 153)]
623+ [y (+ (* 100 b) d -4800 (quotient m 10))])
624+ (values
625+ (* (- jdn days) tm:sid)
626+ (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
627+ (+ m 3 (* -12 (quotient m 10)))
628+ (if (>= 0 y) (- y 1) y))))
629+ (define (tm:local-tz-offset)
630+ (date-time-zone-offset (seconds->date (current-seconds))))
631+ (define (tm:time->julian-day-number seconds tz-offset)
632+ (+ (/ (+ seconds tz-offset tm:sihd) tm:sid)
633+ tm:tai-epoch-in-jd))
634+ (define (tm:find proc l)
635+ (if (null? l)
636+ #f
637+ (if (proc (car l)) #t (tm:find proc (cdr l)))))
638+ (define (tm:tai-before-leap-second? second)
639+ (tm:find
640+ (lambda (x) (= second (- (+ (car x) (cdr x)) 1)))
641+ tm:leap-second-table))
642+ (define (tm:time->date time tz-offset ttype)
643+ (if (not (eq? (time-type time) ttype))
644+ (tm:time-error 'time->date 'incompatible-time-types time))
645+ (let* ([offset (:optional tz-offset (tm:local-tz-offset))])
646+ (receive
647+ (secs date month year)
648+ (tm:decode-julian-day-number
649+ (tm:time->julian-day-number (time-second time) offset))
650+ (let* ([hours (quotient secs (* 60 60))]
651+ [rem (remainder secs (* 60 60))]
652+ [minutes (quotient rem 60)]
653+ [seconds (remainder rem 60)])
654+ (make-date (time-nanosecond time) seconds minutes hours date
655+ month year offset)))))
656+ (define (time-tai->date time . tz-offset)
657+ (if (tm:tai-before-leap-second? (time-second time))
658+ (let ([d (tm:time->date
659+ (subtract-duration!
660+ (time-tai->time-utc time)
661+ (make-time time-duration 0 1))
662+ tz-offset
663+ time-utc)])
664+ (tm:set-date-second! d 60)
665+ d)
666+ (tm:time->date
667+ (time-tai->time-utc time)
668+ tz-offset
669+ time-utc)))
670+ (define (time-utc->date time . tz-offset)
671+ (tm:time->date time tz-offset time-utc))
672+ (define (time-monotonic->date time . tz-offset)
673+ (tm:time->date time tz-offset time-monotonic))
674+ (define (date->time-utc date)
675+ (let ([nanosecond (date-nanosecond date)]
676+ [second (date-second date)]
677+ [minute (date-minute date)]
678+ [hour (date-hour date)]
679+ [day (date-day date)]
680+ [month (date-month date)]
681+ [year (date-year date)]
682+ [offset (date-zone-offset date)])
683+ (let ([jdays (- (tm:encode-julian-day-number day month year)
684+ tm:tai-epoch-in-jd)])
685+ (make-time
686+ time-utc
687+ nanosecond
688+ (+ (* (- jdays 1/2) 24 60 60) (* hour 60 60) (* minute 60)
689+ second (- offset))))))
690+ (define (date->time-tai d)
691+ (if (= (date-second d) 60)
692+ (subtract-duration!
693+ (time-utc->time-tai! (date->time-utc d))
694+ (make-time time-duration 0 1))
695+ (time-utc->time-tai! (date->time-utc d))))
696+ (define (date->time-monotonic date)
697+ (time-utc->time-monotonic! (date->time-utc date)))
698+ (define (tm:leap-year? year)
699+ (or (= (modulo year 400) 0)
700+ (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
701+ (define (leap-year? date) (tm:leap-year? (date-year date)))
702+ (define tm:month-assoc
703+ '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120) (5 . 151)
704+ (6 . 181) (7 . 212) (8 . 243) (9 . 273) (10 . 304)
705+ (11 . 334)))
706+ (define (tm:year-day day month year)
707+ (let ([days-pr (assoc (- month 1) tm:month-assoc)])
708+ (if (not days-pr)
709+ (tm:time-error
710+ 'date-year-day
711+ 'invalid-month-specification
712+ month))
713+ (if (and (tm:leap-year? year) (> month 2))
714+ (+ day (cdr days-pr) 1)
715+ (+ day (cdr days-pr)))))
716+ (define (date-year-day date)
717+ (tm:year-day
718+ (date-day date)
719+ (date-month date)
720+ (date-year date)))
721+ (define (tm:week-day day month year)
722+ (let* ([a (quotient (- 14 month) 12)]
723+ [y (- year a)]
724+ [m (+ month (* 12 a) -2)])
725+ (modulo
726+ (+ day y (quotient y 4) (- (quotient y 100))
727+ (quotient y 400) (quotient (* 31 m) 12))
728+ 7)))
729+ (define (date-week-day date)
730+ (tm:week-day
731+ (date-day date)
732+ (date-month date)
733+ (date-year date)))
734+ (define (tm:days-before-first-week date
735+ day-of-week-starting-week)
736+ (let* ([first-day (make-date 0 0 0 0 1 1 (date-year date)
737+ #f)]
738+ [fdweek-day (date-week-day first-day)])
739+ (modulo (- day-of-week-starting-week fdweek-day) 7)))
740+ (define (date-week-number date day-of-week-starting-week)
741+ (quotient
742+ (- (date-year-day date)
743+ (tm:days-before-first-week date day-of-week-starting-week))
744+ 7))
745+ (define (current-date . tz-offset)
746+ (time-utc->date
747+ (current-time time-utc)
748+ (:optional tz-offset (tm:local-tz-offset))))
749+ (define (tm:natural-year n)
750+ (let* ([current-year (date-year (current-date))]
751+ [current-century (* (quotient current-year 100) 100)])
752+ (cond
753+ [(>= n 100) n]
754+ [(< n 0) n]
755+ [(<= (- (+ current-century n) current-year) 50)
756+ (+ current-century n)]
757+ [else (+ (- current-century 100) n)])))
758+ (define (date->julian-day date)
759+ (let ([nanosecond (date-nanosecond date)]
760+ [second (date-second date)]
761+ [minute (date-minute date)]
762+ [hour (date-hour date)]
763+ [day (date-day date)]
764+ [month (date-month date)]
765+ [year (date-year date)]
766+ [offset (date-zone-offset date)])
767+ (+ (tm:encode-julian-day-number day month year)
768+ (- 1/2)
769+ (+ (/ (/ (+ (* hour 60 60)
770+ (* minute 60)
771+ second
772+ (/ nanosecond tm:nano))
773+ tm:sid)
774+ (- offset))))))
775+ (define (date->modified-julian-day date)
776+ (- (date->julian-day date) 4800001/2))
777+ (define (time-utc->julian-day time)
778+ (if (not (eq? (time-type time) time-utc))
779+ (tm:time-error
780+ 'time-utc->julian-day
781+ 'incompatible-time-types
782+ time))
783+ (+ (/ (+ (time-second time)
784+ (/ (time-nanosecond time) tm:nano))
785+ tm:sid)
786+ tm:tai-epoch-in-jd))
787+ (define (time-utc->modified-julian-day time)
788+ (- (time-utc->julian-day time) 4800001/2))
789+ (define (time-tai->julian-day time)
790+ (if (not (eq? (time-type time) time-tai))
791+ (tm:time-error
792+ 'time-tai->julian-day
793+ 'incompatible-time-types
794+ time))
795+ (+ (/ (+ (- (time-second time)
796+ (tm:leap-second-delta (time-second time)))
797+ (/ (time-nanosecond time) tm:nano))
798+ tm:sid)
799+ tm:tai-epoch-in-jd))
800+ (define (time-tai->modified-julian-day time)
801+ (- (time-tai->julian-day time) 4800001/2))
802+ (define (time-monotonic->julian-day time)
803+ (if (not (eq? (time-type time) time-monotonic))
804+ (tm:time-error
805+ 'time-monotonic->julian-day
806+ 'incompatible-time-types
807+ time))
808+ (+ (/ (+ (- (time-second time)
809+ (tm:leap-second-delta (time-second time)))
810+ (/ (time-nanosecond time) tm:nano))
811+ tm:sid)
812+ tm:tai-epoch-in-jd))
813+ (define (time-monotonic->modified-julian-day time)
814+ (- (time-monotonic->julian-day time) 4800001/2))
815+ (define (julian-day->time-utc jdn)
816+ (let ([nanosecs (* tm:nano
817+ tm:sid
818+ (- jdn tm:tai-epoch-in-jd))])
819+ (make-time
820+ time-utc
821+ (remainder nanosecs tm:nano)
822+ (floor (/ nanosecs tm:nano)))))
823+ (define (julian-day->time-tai jdn)
824+ (time-utc->time-tai! (julian-day->time-utc jdn)))
825+ (define (julian-day->time-monotonic jdn)
826+ (time-utc->time-monotonic! (julian-day->time-utc jdn)))
827+ (define (julian-day->date jdn . tz-offset)
828+ (let ([offset (:optional tz-offset (tm:local-tz-offset))])
829+ (time-utc->date (julian-day->time-utc jdn) offset)))
830+ (define (modified-julian-day->date jdn . tz-offset)
831+ (let ([offset (:optional tz-offset (tm:local-tz-offset))])
832+ (julian-day->date (+ jdn 4800001/2) offset)))
833+ (define (modified-julian-day->time-utc jdn)
834+ (julian-day->time-utc (+ jdn 4800001/2)))
835+ (define (modified-julian-day->time-tai jdn)
836+ (julian-day->time-tai (+ jdn 4800001/2)))
837+ (define (modified-julian-day->time-monotonic jdn)
838+ (julian-day->time-monotonic (+ jdn 4800001/2)))
839+ (define (current-julian-day)
840+ (time-utc->julian-day (current-time time-utc)))
841+ (define (current-modified-julian-day)
842+ (time-utc->modified-julian-day (current-time time-utc)))
843+ (define (tm:padding n pad-with length)
844+ (let* ([str (number->string n)]
845+ [str-len (string-length str)])
846+ (if (or (> str-len length) (not pad-with))
847+ str
848+ (let* ([new-str (make-string length pad-with)]
849+ [new-str-offset (- (string-length new-str) str-len)])
850+ (do ([i 0 (+ i 1)])
851+ ((>= i (string-length str)))
852+ (string-set!
853+ new-str
854+ (+ new-str-offset i)
855+ (string-ref str i)))
856+ new-str))))
857+ (define (tm:last-n-digits i n)
858+ (abs (remainder i (expt 10 n))))
859+ (define (tm:locale-abbr-weekday n)
860+ (vector-ref tm:locale-abbr-weekday-vector n))
861+ (define (tm:locale-long-weekday n)
862+ (vector-ref tm:locale-long-weekday-vector n))
863+ (define (tm:locale-abbr-month n)
864+ (vector-ref tm:locale-abbr-month-vector n))
865+ (define (tm:locale-long-month n)
866+ (vector-ref tm:locale-long-month-vector n))
867+ (define (tm:vector-find needle haystack comparator)
868+ (let ([len (vector-length haystack)])
869+ (define (tm:vector-find-int index)
870+ (cond
871+ [(>= index len) #f]
872+ [(comparator needle (vector-ref haystack index)) index]
873+ [else (tm:vector-find-int (+ index 1))]))
874+ (tm:vector-find-int 0)))
875+ (define (tm:locale-abbr-weekday->index string)
876+ (tm:vector-find
877+ string
878+ tm:locale-abbr-weekday-vector
879+ string=?))
880+ (define (tm:locale-long-weekday->index string)
881+ (tm:vector-find
882+ string
883+ tm:locale-long-weekday-vector
884+ string=?))
885+ (define (tm:locale-abbr-month->index string)
886+ (tm:vector-find
887+ string
888+ tm:locale-abbr-month-vector
889+ string=?))
890+ (define (tm:locale-long-month->index string)
891+ (tm:vector-find
892+ string
893+ tm:locale-long-month-vector
894+ string=?))
895+ (define (tm:locale-print-time-zone date port) (values))
896+ (define (tm:locale-am/pm hr)
897+ (if (> hr 11) tm:locale-pm tm:locale-am))
898+ (define (tm:tz-printer offset port)
899+ (cond
900+ [(= offset 0) (display "Z" port)]
901+ [(negative? offset) (display "-" port)]
902+ [else (display "+" port)])
903+ (if (not (= offset 0))
904+ (let ([hours (abs (quotient offset (* 60 60)))]
905+ [minutes (abs (quotient
906+ (remainder offset (* 60 60))
907+ 60))])
908+ (display (tm:padding hours #\0 2) port)
909+ (display (tm:padding minutes #\0 2) port))))
910+ (define tm:directives
911+ (list
912+ (cons #\~ (lambda (date pad-with port) (display #\~ port)))
913+ (cons
914+ #\a
915+ (lambda (date pad-with port)
916+ (display
917+ (tm:locale-abbr-weekday (date-week-day date))
918+ port)))
919+ (cons
920+ #\A
921+ (lambda (date pad-with port)
922+ (display
923+ (tm:locale-long-weekday (date-week-day date))
924+ port)))
925+ (cons
926+ #\b
927+ (lambda (date pad-with port)
928+ (display (tm:locale-abbr-month (date-month date)) port)))
929+ (cons
930+ #\B
931+ (lambda (date pad-with port)
932+ (display (tm:locale-long-month (date-month date)) port)))
933+ (cons
934+ #\c
935+ (lambda (date pad-with port)
936+ (display
937+ (date->string date tm:locale-date-time-format)
938+ port)))
939+ (cons
940+ #\d
941+ (lambda (date pad-with port)
942+ (display (tm:padding (date-day date) #\0 2) port)))
943+ (cons
944+ #\D
945+ (lambda (date pad-with port)
946+ (display (date->string date "~m/~d/~y") port)))
947+ (cons
948+ #\e
949+ (lambda (date pad-with port)
950+ (display (tm:padding (date-day date) #\space 2) port)))
951+ (cons
952+ #\f
953+ (lambda (date pad-with port)
954+ (if (> (date-nanosecond date) tm:nano)
955+ (display
956+ (tm:padding (+ (date-second date) 1) pad-with 2)
957+ port)
958+ (display (tm:padding (date-second date) pad-with 2) port))
959+ (let* ([ns (tm:fractional-part
960+ (/ (date-nanosecond date) tm:nano 1.0))]
961+ [le (string-length ns)])
962+ (if (> le 2)
963+ (begin
964+ (display tm:locale-number-separator port)
965+ (display (substring ns 2 le) port))))))
966+ (cons
967+ #\h
968+ (lambda (date pad-with port)
969+ (display (date->string date "~b") port)))
970+ (cons
971+ #\H
972+ (lambda (date pad-with port)
973+ (display (tm:padding (date-hour date) pad-with 2) port)))
974+ (cons
975+ #\I
976+ (lambda (date pad-with port)
977+ (let ([hr (date-hour date)])
978+ (if (> hr 12)
979+ (display (tm:padding (- hr 12) pad-with 2) port)
980+ (display (tm:padding hr pad-with 2) port)))))
981+ (cons
982+ #\j
983+ (lambda (date pad-with port)
984+ (display
985+ (tm:padding (date-year-day date) pad-with 3)
986+ port)))
987+ (cons
988+ #\k
989+ (lambda (date pad-with port)
990+ (display (tm:padding (date-hour date) #\space 2) port)))
991+ (cons
992+ #\l
993+ (lambda (date pad-with port)
994+ (let ([hr (if (> (date-hour date) 12)
995+ (- (date-hour date) 12)
996+ (date-hour date))])
997+ (display (tm:padding hr #\space 2) port))))
998+ (cons
999+ #\m
1000+ (lambda (date pad-with port)
1001+ (display (tm:padding (date-month date) pad-with 2) port)))
1002+ (cons
1003+ #\M
1004+ (lambda (date pad-with port)
1005+ (display (tm:padding (date-minute date) pad-with 2) port)))
1006+ (cons #\n (lambda (date pad-with port) (newline port)))
1007+ (cons
1008+ #\N
1009+ (lambda (date pad-with port)
1010+ (display
1011+ (tm:padding (date-nanosecond date) pad-with 9)
1012+ port)))
1013+ (cons
1014+ #\p
1015+ (lambda (date pad-with port)
1016+ (display (tm:locale-am/pm (date-hour date)) port)))
1017+ (cons
1018+ #\r
1019+ (lambda (date pad-with port)
1020+ (display (date->string date "~I:~M:~S ~p") port)))
1021+ (cons
1022+ #\s
1023+ (lambda (date pad-with port)
1024+ (display (time-second (date->time-utc date)) port)))
1025+ (cons
1026+ #\S
1027+ (lambda (date pad-with port)
1028+ (if (> (date-nanosecond date) tm:nano)
1029+ (display
1030+ (tm:padding (+ (date-second date) 1) pad-with 2)
1031+ port)
1032+ (display
1033+ (tm:padding (date-second date) pad-with 2)
1034+ port))))
1035+ (cons
1036+ #\t
1037+ (lambda (date pad-with port)
1038+ (display (integer->char 9) port)))
1039+ (cons
1040+ #\T
1041+ (lambda (date pad-with port)
1042+ (display (date->string date "~H:~M:~S") port)))
1043+ (cons
1044+ #\U
1045+ (lambda (date pad-with port)
1046+ (if (> (tm:days-before-first-week date 0) 0)
1047+ (display
1048+ (tm:padding (+ (date-week-number date 0) 1) #\0 2)
1049+ port)
1050+ (display
1051+ (tm:padding (date-week-number date 0) #\0 2)
1052+ port))))
1053+ (cons
1054+ #\V
1055+ (lambda (date pad-with port)
1056+ (display
1057+ (tm:padding (date-week-number date 1) #\0 2)
1058+ port)))
1059+ (cons
1060+ #\w
1061+ (lambda (date pad-with port)
1062+ (display (date-week-day date) port)))
1063+ (cons
1064+ #\x
1065+ (lambda (date pad-with port)
1066+ (display
1067+ (date->string date tm:locale-short-date-format)
1068+ port)))
1069+ (cons
1070+ #\X
1071+ (lambda (date pad-with port)
1072+ (display (date->string date tm:locale-time-format) port)))
1073+ (cons
1074+ #\W
1075+ (lambda (date pad-with port)
1076+ (if (> (tm:days-before-first-week date 1) 0)
1077+ (display
1078+ (tm:padding (+ (date-week-number date 1) 1) #\0 2)
1079+ port)
1080+ (display
1081+ (tm:padding (date-week-number date 1) #\0 2)
1082+ port))))
1083+ (cons
1084+ #\y
1085+ (lambda (date pad-with port)
1086+ (display
1087+ (tm:padding
1088+ (tm:last-n-digits (date-year date) 2)
1089+ pad-with
1090+ 2)
1091+ port)))
1092+ (cons
1093+ #\Y
1094+ (lambda (date pad-with port)
1095+ (display (tm:padding (date-year date) pad-with 4) port)))
1096+ (cons
1097+ #\z
1098+ (lambda (date pad-with port)
1099+ (tm:tz-printer (date-zone-offset date) port)))
1100+ (cons
1101+ #\Z
1102+ (lambda (date pad-with port)
1103+ (tm:locale-print-time-zone date port)))
1104+ (cons
1105+ #\1
1106+ (lambda (date pad-with port)
1107+ (display (date->string date "~Y-~m-~d") port)))
1108+ (cons
1109+ #\2
1110+ (lambda (date pad-with port)
1111+ (display (date->string date "~k:~M:~S~z") port)))
1112+ (cons
1113+ #\3
1114+ (lambda (date pad-with port)
1115+ (display (date->string date "~k:~M:~S") port)))
1116+ (cons
1117+ #\4
1118+ (lambda (date pad-with port)
1119+ (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
1120+ (cons
1121+ #\5
1122+ (lambda (date pad-with port)
1123+ (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
1124+ (define (tm:get-formatter char)
1125+ (let ([associated (assoc char tm:directives)])
1126+ (if associated (cdr associated) #f)))
1127+ (define (tm:date-printer date index format-string str-len
1128+ port)
1129+ (if (>= index str-len)
1130+ (values)
1131+ (let ([current-char (string-ref format-string index)])
1132+ (if (not (char=? current-char #\~))
1133+ (begin
1134+ (display current-char port)
1135+ (tm:date-printer date (+ index 1) format-string str-len
1136+ port))
1137+ (if (= (+ index 1) str-len)
1138+ (tm:time-error
1139+ 'tm:date-printer
1140+ 'bad-date-format-string
1141+ format-string)
1142+ (let ([pad-char? (string-ref
1143+ format-string
1144+ (+ index 1))])
1145+ (cond
1146+ [(char=? pad-char? #\-)
1147+ (if (= (+ index 2) str-len)
1148+ (tm:time-error
1149+ 'tm:date-printer
1150+ 'bad-date-format-string
1151+ format-string)
1152+ (let ([formatter (tm:get-formatter
1153+ (string-ref
1154+ format-string
1155+ (+ index 2)))])
1156+ (if (not formatter)
1157+ (tm:time-error
1158+ 'tm:date-printer
1159+ 'bad-date-format-string
1160+ format-string)
1161+ (begin
1162+ (formatter date #f port)
1163+ (tm:date-printer date (+ index 3)
1164+ format-string str-len port)))))]
1165+ [(char=? pad-char? #\_)
1166+ (if (= (+ index 2) str-len)
1167+ (tm:time-error
1168+ 'tm:date-printer
1169+ 'bad-date-format-string
1170+ format-string)
1171+ (let ([formatter (tm:get-formatter
1172+ (string-ref
1173+ format-string
1174+ (+ index 2)))])
1175+ (if (not formatter)
1176+ (tm:time-error
1177+ 'tm:date-printer
1178+ 'bad-date-format-string
1179+ format-string)
1180+ (begin
1181+ (formatter date #\space port)
1182+ (tm:date-printer date (+ index 3)
1183+ format-string str-len port)))))]
1184+ [else
1185+ (let ([formatter (tm:get-formatter
1186+ (string-ref
1187+ format-string
1188+ (+ index 1)))])
1189+ (if (not formatter)
1190+ (tm:time-error
1191+ 'tm:date-printer
1192+ 'bad-date-format-string
1193+ format-string)
1194+ (begin
1195+ (formatter date #\0 port)
1196+ (tm:date-printer date (+ index 2)
1197+ format-string str-len port))))])))))))
1198+ (define (date->string date . format-string)
1199+ (let ([str-port (open-output-string)]
1200+ [fmt-str (:optional format-string "~c")])
1201+ (tm:date-printer date 0 fmt-str (string-length fmt-str)
1202+ str-port)
1203+ (get-output-string str-port)))
1204+ (define (tm:char->int ch)
1205+ (cond
1206+ [(char=? ch #\0) 0]
1207+ [(char=? ch #\1) 1]
1208+ [(char=? ch #\2) 2]
1209+ [(char=? ch #\3) 3]
1210+ [(char=? ch #\4) 4]
1211+ [(char=? ch #\5) 5]
1212+ [(char=? ch #\6) 6]
1213+ [(char=? ch #\7) 7]
1214+ [(char=? ch #\8) 8]
1215+ [(char=? ch #\9) 9]
1216+ [else
1217+ (tm:time-error
1218+ 'string->date
1219+ 'bad-date-template-string
1220+ (list "Non-integer character" ch))]))
1221+ (define (tm:integer-reader upto port)
1222+ (define (accum-int port accum nchars)
1223+ (let ([ch (peek-char port)])
1224+ (if (or (eof-object? ch)
1225+ (not (char-numeric? ch))
1226+ (and upto (>= nchars upto)))
1227+ accum
1228+ (accum-int
1229+ port
1230+ (+ (* accum 10) (tm:char->int (read-char port)))
1231+ (+ nchars 1)))))
1232+ (accum-int port 0 0))
1233+ (define (tm:make-integer-reader upto)
1234+ (lambda (port) (tm:integer-reader upto port)))
1235+ (define (tm:fractional-integer-reader upto port)
1236+ (define (accum-int port accum nchars)
1237+ (let ([ch (peek-char port)])
1238+ (if (or (eof-object? ch)
1239+ (not (char-numeric? ch))
1240+ (and upto (>= nchars upto)))
1241+ (* accum (expt 10 (- upto nchars)))
1242+ (accum-int
1243+ port
1244+ (+ (* accum 10) (tm:char->int (read-char port)))
1245+ (+ nchars 1)))))
1246+ (accum-int port 0 0))
1247+ (define (tm:make-fractional-integer-reader upto)
1248+ (lambda (port) (tm:fractional-integer-reader upto port)))
1249+ (define (tm:integer-reader-exact n port)
1250+ (let ([padding-ok #t])
1251+ (define (accum-int port accum nchars)
1252+ (let ([ch (peek-char port)])
1253+ (cond
1254+ [(>= nchars n) accum]
1255+ [(eof-object? ch)
1256+ (tm:time-error
1257+ 'string->date
1258+ 'bad-date-template-string
1259+ "Premature ending to integer read.")]
1260+ [(char-numeric? ch)
1261+ (set! padding-ok #f)
1262+ (accum-int
1263+ port
1264+ (+ (* accum 10) (tm:char->int (read-char port)))
1265+ (+ nchars 1))]
1266+ [padding-ok
1267+ (read-char port)
1268+ (accum-int port accum (+ nchars 1))]
1269+ [else
1270+ (tm:time-error
1271+ 'string->date
1272+ 'bad-date-template-string
1273+ "Non-numeric characters in integer read.")])))
1274+ (accum-int port 0 0)))
1275+ (define (tm:make-integer-exact-reader n)
1276+ (lambda (port) (tm:integer-reader-exact n port)))
1277+ (define (tm:zone-reader port)
1278+ (let ([offset 0] [positive? #f])
1279+ (let ([ch (read-char port)])
1280+ (if (eof-object? ch)
1281+ (tm:time-error
1282+ 'string->date
1283+ 'bad-date-template-string
1284+ (list "Invalid time zone +/-" ch)))
1285+ (if (or (char=? ch #\Z) (char=? ch #\z))
1286+ 0
1287+ (begin
1288+ (cond
1289+ [(char=? ch #\+) (set! positive? #t)]
1290+ [(char=? ch #\-) (set! positive? #f)]
1291+ [else
1292+ (tm:time-error
1293+ 'string->date
1294+ 'bad-date-template-string
1295+ (list "Invalid time zone +/-" ch))])
1296+ (let ([ch (read-char port)])
1297+ (if (eof-object? ch)
1298+ (tm:time-error
1299+ 'string->date
1300+ 'bad-date-template-string
1301+ (list "Invalid time zone number" ch)))
1302+ (set! offset (* (tm:char->int ch) 10 60 60)))
1303+ (let ([ch (read-char port)])
1304+ (if (eof-object? ch)
1305+ (tm:time-error
1306+ 'string->date
1307+ 'bad-date-template-string
1308+ (list "Invalid time zone number" ch)))
1309+ (set! offset (+ offset (* (tm:char->int ch) 60 60))))
1310+ (let ([ch (read-char port)])
1311+ (if (eof-object? ch)
1312+ (tm:time-error
1313+ 'string->date
1314+ 'bad-date-template-string
1315+ (list "Invalid time zone number" ch)))
1316+ (set! offset (+ offset (* (tm:char->int ch) 10 60))))
1317+ (let ([ch (read-char port)])
1318+ (if (eof-object? ch)
1319+ (tm:time-error
1320+ 'string->date
1321+ 'bad-date-template-string
1322+ (list "Invalid time zone number" ch)))
1323+ (set! offset (+ offset (* (tm:char->int ch) 60))))
1324+ (if positive? offset (- offset)))))))
1325+ (define (tm:locale-reader port indexer)
1326+ (let ([string-port (open-output-string)])
1327+ (define (read-char-string)
1328+ (let ([ch (peek-char port)])
1329+ (if (char-alphabetic? ch)
1330+ (begin
1331+ (write-char (read-char port) string-port)
1332+ (read-char-string))
1333+ (get-output-string string-port))))
1334+ (let* ([str (read-char-string)] [index (indexer str)])
1335+ (if index
1336+ index
1337+ (tm:time-error
1338+ 'string->date
1339+ 'bad-date-template-string
1340+ (list "Invalid string for " indexer))))))
1341+ (define (tm:make-locale-reader indexer)
1342+ (lambda (port) (tm:locale-reader port indexer)))
1343+ (define (tm:make-char-id-reader char)
1344+ (lambda (port)
1345+ (if (char=? char (read-char port))
1346+ char
1347+ (tm:time-error
1348+ 'string->date
1349+ 'bad-date-template-string
1350+ "Invalid character match."))))
1351+ (define tm:read-directives
1352+ (let ([ireader4 (tm:make-integer-reader 4)]
1353+ [ireader2 (tm:make-integer-reader 2)]
1354+ [fireader9 (tm:make-fractional-integer-reader 9)]
1355+ [ireaderf (tm:make-integer-reader #f)]
1356+ [eireader2 (tm:make-integer-exact-reader 2)]
1357+ [eireader4 (tm:make-integer-exact-reader 4)]
1358+ [locale-reader-abbr-weekday (tm:make-locale-reader
1359+ tm:locale-abbr-weekday->index)]
1360+ [locale-reader-long-weekday (tm:make-locale-reader
1361+ tm:locale-long-weekday->index)]
1362+ [locale-reader-abbr-month (tm:make-locale-reader
1363+ tm:locale-abbr-month->index)]
1364+ [locale-reader-long-month (tm:make-locale-reader
1365+ tm:locale-long-month->index)]
1366+ [char-fail (lambda (ch) #t)]
1367+ [do-nothing (lambda (val object) (values))])
1368+ (list
1369+ (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing)
1370+ (list
1371+ #\a
1372+ char-alphabetic?
1373+ locale-reader-abbr-weekday
1374+ do-nothing)
1375+ (list
1376+ #\A
1377+ char-alphabetic?
1378+ locale-reader-long-weekday
1379+ do-nothing)
1380+ (list
1381+ #\b
1382+ char-alphabetic?
1383+ locale-reader-abbr-month
1384+ (lambda (val object) (tm:set-date-month! object val)))
1385+ (list
1386+ #\B
1387+ char-alphabetic?
1388+ locale-reader-long-month
1389+ (lambda (val object) (tm:set-date-month! object val)))
1390+ (list
1391+ #\d
1392+ char-numeric?
1393+ ireader2
1394+ (lambda (val object) (tm:set-date-day! object val)))
1395+ (list
1396+ #\e
1397+ char-fail
1398+ eireader2
1399+ (lambda (val object) (tm:set-date-day! object val)))
1400+ (list
1401+ #\h
1402+ char-alphabetic?
1403+ locale-reader-abbr-month
1404+ (lambda (val object) (tm:set-date-month! object val)))
1405+ (list
1406+ #\H
1407+ char-numeric?
1408+ ireader2
1409+ (lambda (val object) (tm:set-date-hour! object val)))
1410+ (list
1411+ #\k
1412+ char-fail
1413+ eireader2
1414+ (lambda (val object) (tm:set-date-hour! object val)))
1415+ (list
1416+ #\m
1417+ char-numeric?
1418+ ireader2
1419+ (lambda (val object) (tm:set-date-month! object val)))
1420+ (list
1421+ #\M
1422+ char-numeric?
1423+ ireader2
1424+ (lambda (val object) (tm:set-date-minute! object val)))
1425+ (list
1426+ #\N
1427+ char-numeric?
1428+ fireader9
1429+ (lambda (val object) (tm:set-date-nanosecond! object val)))
1430+ (list
1431+ #\S
1432+ char-numeric?
1433+ ireader2
1434+ (lambda (val object) (tm:set-date-second! object val)))
1435+ (list
1436+ #\y
1437+ char-fail
1438+ eireader2
1439+ (lambda (val object)
1440+ (tm:set-date-year! object (tm:natural-year val))))
1441+ (list
1442+ #\Y
1443+ char-numeric?
1444+ ireader4
1445+ (lambda (val object) (tm:set-date-year! object val)))
1446+ (list
1447+ #\z
1448+ (lambda (c)
1449+ (or (char=? c #\Z)
1450+ (char=? c #\z)
1451+ (char=? c #\+)
1452+ (char=? c #\-)))
1453+ tm:zone-reader
1454+ (lambda (val object)
1455+ (tm:set-date-zone-offset! object val))))))
1456+ (define (tm:string->date date index format-string str-len
1457+ port template-string)
1458+ (define (skip-until port skipper)
1459+ (let ([ch (peek-char port)])
1460+ (if (eof-object? ch)
1461+ (tm:time-error
1462+ 'string->date
1463+ 'bad-date-format-string
1464+ template-string)
1465+ (if (not (skipper ch))
1466+ (begin (read-char port) (skip-until port skipper))))))
1467+ (if (>= index str-len)
1468+ (begin (values))
1469+ (let ([current-char (string-ref format-string index)])
1470+ (if (not (char=? current-char #\~))
1471+ (let ([port-char (read-char port)])
1472+ (if (or (eof-object? port-char)
1473+ (not (char=? current-char port-char)))
1474+ (tm:time-error
1475+ 'string->date
1476+ 'bad-date-format-string
1477+ template-string))
1478+ (tm:string->date date (+ index 1) format-string str-len
1479+ port template-string))
1480+ (if (> (+ index 1) str-len)
1481+ (tm:time-error
1482+ 'string->date
1483+ 'bad-date-format-string
1484+ template-string)
1485+ (let* ([format-char (string-ref
1486+ format-string
1487+ (+ index 1))]
1488+ [format-info (assoc
1489+ format-char
1490+ tm:read-directives)])
1491+ (if (not format-info)
1492+ (tm:time-error
1493+ 'string->date
1494+ 'bad-date-format-string
1495+ template-string)
1496+ (begin
1497+ (let ([skipper (cadr format-info)]
1498+ [reader (caddr format-info)]
1499+ [actor (cadddr format-info)])
1500+ (skip-until port skipper)
1501+ (let ([val (reader port)])
1502+ (if (eof-object? val)
1503+ (tm:time-error
1504+ 'string->date
1505+ 'bad-date-format-string
1506+ template-string)
1507+ (actor val date)))
1508+ (tm:string->date date (+ index 2)
1509+ format-string str-len port
1510+ template-string))))))))))
1511+ (define (string->date input-string template-string)
1512+ (define (tm:date-ok? date)
1513+ (and (date-nanosecond date)
1514+ (date-second date)
1515+ (date-minute date)
1516+ (date-hour date)
1517+ (date-day date)
1518+ (date-month date)
1519+ (date-year date)
1520+ (date-zone-offset date)))
1521+ (let ([newdate (make-date 0 0 0 0 #f #f #f
1522+ (tm:local-tz-offset))])
1523+ (tm:string->date newdate 0 template-string (string-length template-string)
1524+ (open-input-string input-string) template-string)
1525+ (if (tm:date-ok? newdate)
1526+ newdate
1527+ (tm:time-error
1528+ 'string->date
1529+ 'bad-date-format-string
1530+ (list
1531+ "Incomplete date read. "
1532+ newdate
1533+ template-string))))))))