source: project/release/4/srfi-19/trunk/srfi-19-io.scm @ 15776

Last change on this file since 15776 was 15776, checked in by Kon Lovett, 11 years ago

Save.

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