source: project/release/4/srfi-19/tags/3.6.0/srfi-19-io.scm @ 35411

Last change on this file since 35411 was 35411, checked in by Kon Lovett, 3 years ago

rel 3.6.0

File size: 24.4 KB
Line 
1;;;; srfi-19-io.scm
2;;;; Chicken port, Kon Lovett, Dec '05
3
4;; SRFI-19: Time Data Types and Procedures.
5;;
6;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
7;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
8;;
9;; This document and translations of it may be copied and furnished to others,
10;; and derivative works that comment on or otherwise explain it or assist in its
11;; implementation may be prepared, copied, published and distributed, in whole or
12;; in part, without restriction of any kind, provided that the above copyright
13;; notice and this paragraph are included on all such copies and derivative works.
14;; However, this document itself may not be modified in any way, such as by
15;; removing the copyright notice or references to the Scheme Request For
16;; Implementation process or editors, except as needed for the purpose of
17;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
18;; process must be followed, or as required to translate it into languages other
19;; than English.
20;;
21;; The limited permissions granted above are perpetual and will not be revoked
22;; by the authors or their successors or assigns.
23;;
24;; This document and the information contained herein is provided on an "AS IS"
25;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
26;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
27;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
28;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
29
30(module srfi-19-io
31
32(;export
33  ;; SRFI-19
34  date->string
35  string->date
36  ;; SRFI-19 extensions
37  format-date
38  scan-date)
39
40(import (except scheme + / > exact->inexact number->string))
41
42(import chicken)
43
44(use (only numbers + / > exact->inexact number->string))
45
46(use
47  #;srfi-6
48  (only srfi-1 drop)
49  (only srfi-13 string-pad)
50  (only ports with-output-to-string)
51  (only data-structures reverse-string-append alist-ref)
52  srfi-29
53  type-checks
54  srfi-19-support
55  srfi-19-timezone)
56
57;;;
58
59(include "srfi-19-common")
60
61;;;
62
63(define (error-bad-date-format loc obj)
64  (error loc "bad date format" obj) )
65
66(define (error-bad-date-template loc msg . args)
67  (apply error
68    loc
69    (if (string=? "" msg)
70      "bad date template"
71      (string-append "bad date template - " msg))
72    args) )
73
74;;;
75
76;; -- Locale bundle item keys
77
78(define LOCALE-NUMBER-SEPARATOR 'separator)
79
80(define LOCALE-ABRV-WEEKDAYS '#(#f sun mon tue wed thu fri sat))
81(define LOCALE-LONG-WEEKDAYS '#(#f sunday monday tuesday wednesday thursday friday saturday))
82
83(define LOCALE-ABRV-MONTHS '#(#f jan feb mar apr may jun jul aug sep oct nov dec))
84(define LOCALE-LONG-MONTHS '#(#f january february march april may-long june july august september october november december))
85
86(define LOCALE-PM 'pm)
87(define LOCALE-AM 'am)
88
89;; See date->string
90
91(define LOCALE-DATE-TIME-FORMAT 'date-time)
92(define LOCALE-SHORT-DATE-FORMAT 'date)
93(define LOCALE-TIME-FORMAT 'time)
94
95;; SRFI-29 Helper
96
97(define-inline (item@ key) (localized-template/default 'srfi-19 key))
98
99;;; Date & Time Formatted I/O
100
101;; Return a string representing the decimal expansion of the fractional
102;; portion of a number, limited by a specified precision
103
104(define (decimal-expansion frac prec)
105  (let loop ((n (- frac (round frac))) (p prec) (ls '()))
106    (if (or (fx= 0 p) (zero? n))
107      (reverse-string-append ls)
108      (let* ((n*10 (* 10 n))
109             (rn*10 (round n*10)))
110        (loop
111          (- n*10 rn*10)
112          (fx- p 1)
113          (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) )
114
115;; Returns a string rep. of number N, of minimum LENGTH,
116;; padded with character PAD-WITH. If PAD-WITH if #f,
117;; no padding is done, and it's as if number->string was used.
118;; if string is longer than LENGTH, it's as if number->string was used.
119
120(define (padding n pad-with length)
121  (let* ((str (number->string n))
122         (len (string-length str)))
123    (define (trailing-dotzero?)
124      (and
125        (fx<= 2 len)
126        (char=? #\. (string-ref str (fx- len 2)))
127        (char=? #\0 (string-ref str (fx- len 1))) ) )
128    (let ((str
129            (if (not (trailing-dotzero?))
130              str
131              (substring str 0 (fx- len 2)) ) ) )
132      (if (or (not pad-with) (fx> len length))
133        str
134        (string-pad str length pad-with)) ) ) )
135
136(define fxtake-right-digits
137  (let ((nth '#(0 10 100 1000 100000 1000000 10000000 100000000 1000000000)))
138    (lambda (i n)
139      (fxmod (fxabs i) (vector-ref nth n)) ) ) )
140
141(define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS (fx+ n 1))))
142(define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS (fx+ n 1))))
143(define (locale-abbr-month n) (item@ (vector-ref LOCALE-ABRV-MONTHS n)))
144(define (locale-long-month n) (item@ (vector-ref LOCALE-LONG-MONTHS n)))
145
146(define (locale-find-string str vec)
147  (let loop ((idx (fx- (vector-length vec) 1)))
148    (and
149      (fx< 0 idx)
150      (or
151        (and
152          (string=? str (item@ (vector-ref vec idx)))
153          idx)
154        (loop (fx- idx 1))) ) ) )
155
156(define (locale-abbr-weekday->index str) (locale-find-string str LOCALE-ABRV-WEEKDAYS))
157(define (locale-long-weekday->index str) (locale-find-string str LOCALE-LONG-WEEKDAYS))
158(define (locale-abbr-month->index str) (locale-find-string str LOCALE-ABRV-MONTHS))
159(define (locale-long-month->index str) (locale-find-string str LOCALE-LONG-MONTHS))
160
161;; There is no unique way to map a timezone offset to a political timezone!
162
163(define (locale-print-time-zone date port)
164  (when (tm:date-zone-name date)
165    (display (tm:date-zone-name date) port)) )
166
167;; Again, locale specific.
168
169(define (locale-am/pm hr) (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)))
170
171(define (tz-printer offset port)
172  (if (fx= 0 offset)
173    (display "Z" port)
174    (let ((isneg (fx< offset 0)))
175      (display (if isneg #\- #\+) port)
176      (let ((offset (if isneg (fxneg offset) offset)))
177        (display (padding (fx/ offset SEC/HR) #\0 2) port)
178        (display (padding (fx/ (fxmod offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
179
180;; A table of output formatting directives.
181;; the first time is the format char.
182;; the second is a procedure that takes the date, a padding character
183;; (which might be #f), and the output port.
184
185(define tm:display-directives
186  (list
187    (cons #\~
188      (lambda (date pad-with port)
189        (display #\~ port)))
190
191    (cons #\a
192      (lambda (date pad-with port)
193        (display (locale-abbr-weekday (tm:date-week-day date)) port)))
194
195    (cons #\A
196      (lambda (date pad-with port)
197        (display (locale-long-weekday (tm:date-week-day date)) port)))
198
199    (cons #\b
200      (lambda (date pad-with port)
201        (display (locale-abbr-month (tm:date-month date)) port)))
202
203    (cons #\B
204      (lambda (date pad-with port)
205        (display (locale-long-month (tm:date-month date)) port)))
206
207    (cons #\c
208      (lambda (date pad-with port)
209        (display (date->string date (item@ LOCALE-DATE-TIME-FORMAT)) port)))
210
211    (cons #\d
212      (lambda (date pad-with port)
213        (display (padding (tm:date-day date) #\0 2) port)))
214
215    (cons #\D
216      (lambda (date pad-with port)
217        (display (date->string date "~m/~d/~y") port)))
218
219    (cons #\e
220      (lambda (date pad-with port)
221        (display (padding (tm:date-day date) #\space 2) port)))
222
223    (cons #\f
224      (lambda (date pad-with port)
225        (let ((ns (tm:date-nanosecond date))
226              (sec (tm:date-second date)))
227          (if (> ns NS/S) ;This shouldn't happen!
228            (display (padding (+ sec 1) pad-with 2) port)
229            (display (padding sec pad-with 2) port))
230          ;ns must be inexact for 'decimal-expansion'
231          (let ((f (decimal-expansion (/ (exact->inexact ns) NS/S) 6)))
232            (when (fx< 0 (string-length f))
233              (display (item@ LOCALE-NUMBER-SEPARATOR) port)
234              (display f port))))))
235
236    (cons #\h
237      (lambda (date pad-with port)
238        (display (date->string date "~b") port)))
239
240    (cons #\H
241      (lambda (date pad-with port)
242        (display (padding (tm:date-hour date) pad-with 2) port)))
243
244    (cons #\I
245      (lambda (date pad-with port)
246        (let ((hr (tm:date-hour date)))
247          (if (fx> hr 12)
248            (display (padding (fx- hr 12) pad-with 2) port)
249            (display (padding hr pad-with 2) port)))))
250
251    (cons #\j
252      (lambda (date pad-with port)
253        (display (padding (tm:date-year-day date) pad-with 3) port)))
254
255    (cons #\k
256      (lambda (date pad-with port)
257        (display (padding (tm:date-hour date) #\space 2) port)))
258
259    (cons #\l
260      (lambda (date pad-with port)
261        (let ((hr (tm:date-hour date)))
262          (display (padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))
263
264    (cons #\m
265      (lambda (date pad-with port)
266        (display (padding (tm:date-month date) pad-with 2) port)))
267
268    (cons #\M
269      (lambda (date pad-with port)
270        (display (padding (tm:date-minute date) pad-with 2) port)))
271
272    (cons #\n
273      (lambda (date pad-with port)
274        (newline port)))
275
276    (cons #\N
277      (lambda (date pad-with port)
278        (display (padding (tm:date-nanosecond date) pad-with 7) port)))
279
280    (cons #\p
281      (lambda (date pad-with port)
282        (display (locale-am/pm (tm:date-hour date)) port)))
283
284    (cons #\r
285      (lambda (date pad-with port)
286        (display (date->string date "~I:~M:~S ~p") port)))
287
288    (cons #\s
289      (lambda (date pad-with port)
290        (display (tm:time-second (tm:date->time-utc date)) port)))
291
292    (cons #\S
293      (lambda (date pad-with port)
294        (let ((sec (tm:date-second date)))
295          (if (> (tm:date-nanosecond date) NS/S) ;This shouldn't happen!
296            (display (padding (+ sec 1) pad-with 2) port)
297            (display (padding sec pad-with 2) port)))))
298
299    (cons #\t
300      (lambda (date pad-with port)
301        (display #\tab port)))
302
303    (cons #\T
304      (lambda (date pad-with port)
305        (display (date->string date "~H:~M:~S") port)))
306
307    (cons #\U
308      (lambda (date pad-with port)
309        (let ((wkno (tm:date-week-number date 0)))
310          (if (fx> (tm:days-before-first-week date 0) 0)
311            (display (padding (fx+ wkno 1) #\0 2) port)
312            (display (padding wkno #\0 2) port)))))
313
314    (cons #\V
315      (lambda (date pad-with port)
316        (display (padding (tm:date-week-number date 1) #\0 2) port)))
317
318    (cons #\w
319      (lambda (date pad-with port)
320        (display (tm:date-week-day date) port)))
321
322    (cons #\W
323      (lambda (date pad-with port)
324        (let ((wkno (tm:date-week-number date 1)))
325          (if (fx> (tm:days-before-first-week date 1) 0)
326            (display (padding (fx+ wkno 1) #\0 2) port)
327            (display (padding wkno #\0 2) port)))))
328
329    (cons #\x
330      (lambda (date pad-with port)
331        (display (date->string date (item@ LOCALE-SHORT-DATE-FORMAT)) port)))
332
333    (cons #\X
334      (lambda (date pad-with port)
335        (display (date->string date (item@ LOCALE-TIME-FORMAT)) port)))
336
337    (cons #\y
338      (lambda (date pad-with port)
339        (display (padding (fxtake-right-digits (tm:date-year date) 2) pad-with 2) port)))
340
341    (cons #\Y
342      (lambda (date pad-with port)
343        (display (tm:date-year date) port)))
344
345    (cons #\z
346      (lambda (date pad-with port)
347        (tz-printer (tm:date-zone-offset date) port)))
348
349    (cons #\Z
350      (lambda (date pad-with port)
351        (locale-print-time-zone date port)))
352
353    (cons #\1
354      (lambda (date pad-with port)
355        (display (date->string date "~Y-~m-~d") port)))
356
357    (cons #\2
358      (lambda (date pad-with port)
359        (display (date->string date "~H:~M:~S~z") port)))
360
361    (cons #\3
362      (lambda (date pad-with port)
363        (display (date->string date "~H:~M:~S") port)))
364
365    (cons #\4
366      (lambda (date pad-with port)
367        (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
368
369    (cons #\5
370      (lambda (date pad-with port)
371        (display (date->string date "~Y-~m-~dT~H:~M:~S") port))) ) )
372
373(define (date-printer loc date fmt-rem len-rem port)
374
375  ;Check enough format characters
376  (define (need-fmt-len amt)
377    (when (fx< len-rem amt)
378      (error-bad-date-format loc (list->string fmt-rem)) ) )
379
380  ;Perform the conversion
381  (define (form-it pad-with key)
382    (define (get-formatter)
383      (or
384        (alist-ref key tm:display-directives)
385        (error-bad-date-format loc (list->string fmt-rem))) )
386    ((get-formatter) date pad-with port)
387    ;account for conversion character
388    (set! fmt-rem (cdr fmt-rem))
389    (set! len-rem (fx- len-rem 1)) )
390
391  ;Conversion w/ padding override
392  (define (form-it+ pad-with)
393    ;the 3rd char is the conversion character
394    (need-fmt-len 3) ;tilde+padochar+convchar
395    (form-it pad-with (caddr fmt-rem))
396    ;account for padding override character
397    ;must be done after the format
398    (set! fmt-rem (cdr fmt-rem))
399    (set! len-rem (fx- len-rem 1)) )
400
401  ;Any formatting left to do?
402  (when (fx< 0 len-rem)
403    ;Decide what to do with it
404    (let ((1st-ch (car fmt-rem)))
405      (cond
406        ;Not a directive, then just display
407        ((not (char=? 1st-ch #\~))
408          (display 1st-ch port) )
409        ;A directive so need the kind
410        (else
411          (need-fmt-len 2) ;tilde+convchar
412          ;Could be a padding override
413          (let ((2nd-ch (cadr fmt-rem)))
414            (cond
415              ;Override w/ no padding
416              ((char=? 2nd-ch #\-)  (form-it+ #f) )
417              ;Override w/ space padding
418              ((char=? 2nd-ch #\_)  (form-it+ #\space) )
419              ;Default 0 padding
420              (else                 (form-it #\0 2nd-ch) ) ) ) ) ) )
421    ;Remaining formatting
422    (date-printer loc date (cdr fmt-rem) (fx- len-rem 1) port) ) )
423
424(define (format-date dest fmtstr . r)
425  (let ((port #f)
426        (date (optional r #f)) )
427    (cond
428      ((not dest)       (set! port (open-output-string)) )
429      ((string? dest)
430        (set! date fmtstr)
431        (set! fmtstr dest)
432        (set! port (open-output-string)) )
433      ((number? dest)   (set! port (current-error-port)) )
434      ((port? dest)     (set! port dest) )
435      (else             (set! port (current-output-port)) ) )
436    (check-date 'format-date date)
437    (check-string 'format-date fmtstr)
438    (check-output-port 'format-date port)
439    (date-printer 'format-date date (string->list fmtstr) (string-length fmtstr) port)
440    (or (and dest (not (string? dest)))
441        (get-output-string port)) ) )
442
443(define (date->string date . args)
444  (let-optionals args ((fmtstr "~c"))
445    (check-date 'date->string date)
446    (check-string 'date->string fmtstr)
447    (let ((port (open-output-string)))
448      (date-printer 'date->string date (string->list fmtstr) (string-length fmtstr) port)
449      (get-output-string port) ) ) )
450
451;;; Input
452
453(define (digit->int ch)
454  (case ch
455    ((#\0) 0)
456    ((#\1) 1)
457    ((#\2) 2)
458    ((#\3) 3)
459    ((#\4) 4)
460    ((#\5) 5)
461    ((#\6) 6)
462    ((#\7) 7)
463    ((#\8) 8)
464    ((#\9) 9)
465    (else
466     (error-bad-date-template 'date-read "not a decimal digit" ch))) )
467
468;; Read an integer upto n characters long on port;
469;; upto -> #f if any length
470
471(define (integer-reader upto port)
472  (define (eoi? ch nchars)
473    (or
474      (eof-object? ch)
475      (not (char-numeric? ch))
476      (and upto (fx>= nchars upto))) )
477  (let loop ((accum 0) (nchars 0))
478    (if (eoi? (peek-char port) nchars)
479      accum
480      (loop
481        (fx+ (fx* accum 10) (digit->int (read-char port)))
482        (fx+ nchars 1))) ) )
483
484(define (make-integer-reader upto)
485  (lambda (port)
486    (integer-reader upto port) ) )
487
488;; Read *exactly* n characters and convert to integer; could be padded
489
490(define (integer-reader-exact n port)
491  (let ((padding-ok #t))
492    (let loop ((accum 0) (nchars 0))
493      (let ((ch (peek-char port)))
494        (cond
495          ((fx>= nchars n)
496            accum)
497          ((eof-object? ch)
498            (error-bad-date-template 'string->date
499              "premature ending to integer read" 'eof-object))
500          ((char-numeric? ch)
501            (set! padding-ok #f)
502            (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1)))
503          (padding-ok
504            (read-char port)    ;consume padding
505            (loop accum (fx+ nchars 1)))
506          (else                ;padding where it shouldn't be
507            (error-bad-date-template 'string->date
508              "non-numeric characters in integer read" ch))) ) ) ) )
509
510(define (make-integer-exact-reader n)
511  (lambda (port)
512    (integer-reader-exact n port)) )
513
514(define (zone-reader port)
515  (let ((offset 0)
516        (is-pos #t)
517        (ch (read-char port)) )
518    (when (eof-object? ch)
519      (error-bad-date-template 'string->date
520       "invalid time zone +/-" 'eof-object))
521    (if (or (char=? ch #\Z) (char=? ch #\z))
522      0
523      (begin
524        (cond
525          ((char=? ch #\+) (set! is-pos #t))
526          ((char=? ch #\-) (set! is-pos #f))
527          (else
528            (error-bad-date-template 'string->date "invalid time zone +/-" ch)))
529        (let ((ch (read-char port)))
530          (when (eof-object? ch)
531            (error-bad-date-template 'string->date
532             "invalid time zone number" 'eof-object))
533          (set! offset (fx* (digit->int ch) (fx* 10 SEC/HR))))
534        ;non-existing values are considered zero
535        (let ((ch (read-char port)))
536          (unless (eof-object? ch)
537            (set! offset (fx+ offset (fx* (digit->int ch) SEC/HR)))))
538        (let ((ch (read-char port)))
539          (unless (eof-object? ch)
540            (set! offset (fx+ offset (fx* (digit->int ch) 600)))))
541        (let ((ch (read-char port)))
542          (unless (eof-object? ch)
543            (set! offset (fx+ offset (fx* (digit->int ch) 60)))))
544        (if is-pos offset (fxneg offset)))) ) )
545
546;; Looking at a char, read the char string, run thru indexer, return index
547
548(define (locale-reader port indexer)
549  (letrec (
550    (read-char-string
551      (lambda ()
552        (let ((ch (peek-char port)))
553          (when (char-alphabetic? ch)
554            (write-char (read-char port))
555            (read-char-string)) ) )))
556    (let* ((str (with-output-to-string read-char-string))
557           (index (indexer str)))
558      (unless index
559        (error-bad-date-template 'string->date "invalid string for indexer" str))
560      index ) ) )
561
562(define (make-locale-reader indexer)
563  (lambda (port)
564    (locale-reader port indexer)) )
565
566(define (make-char-id-reader char)
567  (lambda (port)
568    (let ((rch (read-char port)))
569      (if (char=? char rch) char
570        (error-bad-date-template 'string->date "invalid character match" rch) ) ) ) )
571
572;; A List of formatted read directives.
573;; Each entry is a list.
574;; 1. the character directive;
575;; a procedure, which takes a character as input & returns
576;; 2. #t as soon as a character on the input port is acceptable
577;; for input,
578;; 3. a port reader procedure that knows how to read the current port
579;; for a value. Its one parameter is the port.
580;; 4. a action procedure, that takes the value (from 3.) and some
581;; object (here, always the date) and (probably) side-effects it.
582;; In some cases (e.g., ~A) the action is to do nothing
583
584(define read-directives
585  (let ((ireader4 (make-integer-reader 4))
586        (ireader2 (make-integer-reader 2))
587        (ireader7 (make-integer-reader 7))
588        (ireaderf (make-integer-reader #f))
589        (eireader2 (make-integer-exact-reader 2))
590        (eireader4 (make-integer-exact-reader 4))
591        (locale-reader-abbr-weekday (make-locale-reader locale-abbr-weekday->index))
592        (locale-reader-long-weekday (make-locale-reader locale-long-weekday->index))
593        (locale-reader-abbr-month   (make-locale-reader locale-abbr-month->index))
594        (locale-reader-long-month   (make-locale-reader locale-long-month->index))
595        (char-fail (lambda (ch) #t))
596        (do-nothing (lambda _ (void))) )
597
598    (list
599      (list #\~ char-fail (make-char-id-reader #\~) do-nothing)
600
601      (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
602
603      (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
604
605      (list #\b char-alphabetic? locale-reader-abbr-month
606        (lambda (val dat) (tm:date-month-set! dat val)))
607
608      (list #\B char-alphabetic? locale-reader-long-month
609        (lambda (val dat) (tm:date-month-set! dat val)))
610
611      (list #\d char-numeric? ireader2
612        (lambda (val dat) (tm:date-day-set! dat val)))
613
614      (list #\e char-fail eireader2
615        (lambda (val dat) (tm:date-day-set! dat val)))
616
617      (list #\h char-alphabetic? locale-reader-abbr-month
618        (lambda (val dat) (tm:date-month-set! dat val)))
619
620      (list #\H char-numeric? ireader2
621        (lambda (val dat) (tm:date-hour-set! dat val)))
622
623      (list #\k char-fail eireader2
624        (lambda (val dat) (tm:date-hour-set! dat val)))
625
626      (list #\m char-numeric? ireader2
627        (lambda (val dat) (tm:date-month-set! dat val)))
628
629      (list #\M char-numeric? ireader2
630        (lambda (val dat) (tm:date-minute-set! dat val)))
631
632      (list #\N char-numeric? ireader7
633        (lambda (val dat) (tm:date-nanosecond-set! dat val)))
634
635      (list #\S char-numeric? ireader2
636        (lambda (val dat) (tm:date-second-set! dat val)))
637
638      ;Note that the target date zone-offset value is used!
639      (list #\y char-fail eireader2
640        (lambda (val dat)
641          (tm:date-year-set! dat (tm:natural-year val (tm:date-zone-offset dat)))))
642
643      (list #\Y char-numeric? ireader4
644        (lambda (val dat) (tm:date-year-set! dat val)))
645
646      (list #\z
647        (lambda (c)
648          (or
649            (char=? c #\Z)
650            (char=? c #\z)
651            (char=? c #\+)
652            (char=? c #\-)))
653        zone-reader
654        (lambda (val dat) (tm:date-zone-offset-set! dat val))) ) ) )
655
656(define (date-reader date fmt-rem len-rem port)
657  (let loop ((fmt-rem fmt-rem) (len-rem len-rem))
658    (let ((skip-until
659           (lambda (skipper)
660             (let loop ((ch (peek-char port)))
661               (if (eof-object? ch)
662                 (error-bad-date-template 'scan-date "" (list->string fmt-rem))
663                 (unless (skipper ch)
664                   (read-char port)
665                   (loop (peek-char port))))))))
666      (when (fx< 0 len-rem)
667        (let ((cur-ch (car fmt-rem)))
668          (cond
669            ((not (char=? cur-ch #\~))
670              (let ((port-char (read-char port)))
671                (when (or (eof-object? port-char)
672                          (not (char=? cur-ch port-char)))
673                  (error-bad-date-template 'scan-date "" (list->string fmt-rem))))
674              (loop (cdr fmt-rem) (fx- len-rem 1)))
675            ;otherwise, it's an escape, we hope
676            ((fx< len-rem 2)
677              (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
678            (else
679              (let* ((format-char (cadr fmt-rem))
680                     (format-info (assoc format-char read-directives)))
681                (unless format-info
682                  (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
683                (let ((skipper (cadr format-info))
684                      (reader (caddr format-info))
685                      (actor (cadddr format-info)))
686                  (skip-until skipper)
687                  (let ((val (reader port)))
688                    (if (eof-object? val)
689                      (error-bad-date-template 'scan-date "" (list->string fmt-rem))
690                      (actor val date))))
691                (loop (cddr fmt-rem) (fx- len-rem 2))))) ) ) ) ) )
692
693(define (scan-date src fmtstr)
694  (let ((port #f)
695        (newdate (tm:make-incomplete-date)))
696    (let ((date-complete?
697            (lambda ()
698              (and
699                (tm:date-nanosecond newdate)
700                (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
701                (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
702                (tm:date-zone-offset newdate))))
703          (date-ok
704           (lambda ()
705             (check-date-elements
706               'scan-date
707               (tm:date-nanosecond newdate)
708               (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
709               (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
710               (tm:date-zone-offset newdate)
711               (tm:date-zone-name newdate)))))
712      (cond
713        ((string? src)  (set! port (open-input-string src)))
714        ((port? src)    (set! port src))
715        (src            (set! port (current-input-port))))
716      (check-input-port 'scan-date port)
717      (check-string 'scan-date fmtstr)
718      (date-reader newdate (string->list fmtstr) (string-length fmtstr) port)
719      (unless (date-complete?)
720        (error-bad-date-template 'scan-date "date read incomplete" fmtstr newdate))
721      (date-ok)
722      newdate ) ) )
723
724(define (string->date src . fmtstr)
725  (scan-date src (optional fmtstr (item@ LOCALE-DATE-TIME-FORMAT))) )
726
727;;;
728;;; Module Init
729;;;
730
731;; SRFI-29: Localization initialization
732
733(reset-locale-parameters)
734(load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19))
735
736) ;module srfi-19-io
Note: See TracBrowser for help on using the repository browser.