;;;; srfi-19-io.scm
;;;; Chicken port, Kon Lovett, Dec '05

;; SRFI-19: Time Data Types and Procedures.
;;
;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
;;
;; This document and translations of it may be copied and furnished to others,
;; and derivative works that comment on or otherwise explain it or assist in its
;; implementation may be prepared, copied, published and distributed, in whole or
;; in part, without restriction of any kind, provided that the above copyright
;; notice and this paragraph are included on all such copies and derivative works.
;; However, this document itself may not be modified in any way, such as by
;; removing the copyright notice or references to the Scheme Request For
;; Implementation process or editors, except as needed for the purpose of
;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
;; process must be followed, or as required to translate it into languages other
;; than English.
;;
;; The limited permissions granted above are perpetual and will not be revoked
;; by the authors or their successors or assigns.
;;
;; This document and the information contained herein is provided on an "AS IS"
;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.

(module srfi-19-io

  (;export
    ;; SRFI-19
    date->string
    string->date
    ;; SRFI-19 extensions
    format-date
    scan-date)

  (import
    (except scheme
      + / > exact->inexact number->string)
    chicken
    #;srfi-6
    (only srfi-1 drop)
    (only srfi-13 string-pad)
    (only ports with-output-to-string)
    (only data-structures
      reverse-string-append alist-ref)
    (only numbers
      + / > exact->inexact number->string)
    srfi-29
    type-checks
    srfi-19-support
    srfi-19-timezone)

  (require-library
    srfi-1 #;srfi-6 srfi-13
    ports data-structures
    numbers srfi-29 type-checks
    srfi-19-support srfi-19-timezone)

;;;

(include "srfi-19-common")

;;;

(define (error-bad-date-format loc obj)
  (error loc "bad date format" obj) )

(define (error-bad-date-template loc msg . args)
  (apply error
    loc
    (if (string=? "" msg) "bad date template"
      (string-append "bad date template - " msg))
    args) )

;;;

;; -- Locale bundle item keys

(define LOCALE-NUMBER-SEPARATOR 'separator)

(define LOCALE-ABRV-WEEKDAYS '#(sun mon tue wed thu fri sat))
(define LOCALE-LONG-WEEKDAYS '#(sunday monday tuesday wednesday thursday friday saturday))

(define LOCALE-ABRV-MONTHS '#(#f jan feb mar apr may jun jul aug sep oct nov dec))
(define LOCALE-LONG-MONTHS '#(#f january february march april may-long june july august september october november december))

(define LOCALE-PM 'pm)
(define LOCALE-AM 'am)

;; See date->string

(define LOCALE-DATE-TIME-FORMAT 'date-time)
(define LOCALE-SHORT-DATE-FORMAT 'date)
(define LOCALE-TIME-FORMAT 'time)

;; SRFI-29: Localization initialization

(reset-locale-parameters)
(load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19))

;; SRFI-29 Helper

(define-inline (item@ key) (localized-template/default 'srfi-19 key))

;;; Date & Time Formatted I/O

;; Return a string representing the decimal expansion of the fractional
;; portion of a number, limited by a specified precision

(define (decimal-expansion frac prec)
  (let loop ((n (- frac (round frac))) (p prec) (ls '()))
    (if (or (fx= 0 p) (zero? n)) (reverse-string-append ls)
      (let* ((n*10 (* 10 n))
             (rn*10 (round n*10)))
        (loop (- n*10 rn*10) (fx- p 1) (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) )

;; Returns a string rep. of number N, of minimum LENGTH,
;; padded with character PAD-WITH. If PAD-WITH if #f,
;; no padding is done, and it's as if number->string was used.
;; if string is longer than LENGTH, it's as if number->string was used.

(define (padding n pad-with length)
  (let* ((str (number->string n))
         (len (string-length str)))
    (define (trailing-dotzero?)
      (and (fx<= 2 len)
           (char=? #\. (string-ref str (fx- len 2)))
           (char=? #\0 (string-ref str (fx- len 1))) ) )
    (let ((str (if (not (trailing-dotzero?)) str
                   (substring str 0 (fx- len 2)) ) ) )
      (if (or (not pad-with) (fx> len length)) str
        (string-pad str length pad-with)) ) ) )

(define fxtake-right-digits
  (let ((nth '#(0 10 100 1000 100000 1000000 10000000 100000000 1000000000)))
    (lambda (i n)
      (fxmod (fxabs i) (vector-ref nth n)) ) ) )

(define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS n)))
(define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS n)))
(define (locale-abbr-month n) (item@ (vector-ref LOCALE-ABRV-MONTHS n)))
(define (locale-long-month n) (item@ (vector-ref LOCALE-LONG-MONTHS n)))

(define (locale-find-string str vec)
  (let loop ((idx (fx- (vector-length vec) 1)))
    (and (fx< 0 idx)
         (or (and (string=? str (item@ (vector-ref vec idx)))
                  idx)
             (loop (fx- idx 1))) ) ) )

(define (locale-abbr-weekday->index str) (locale-find-string str LOCALE-ABRV-WEEKDAYS))
(define (locale-long-weekday->index str) (locale-find-string str LOCALE-LONG-WEEKDAYS))
(define (locale-abbr-month->index str) (locale-find-string str LOCALE-ABRV-MONTHS))
(define (locale-long-month->index str) (locale-find-string str LOCALE-LONG-MONTHS))

;; There is no unique way to map a timezone offset to a political timezone!

(define (locale-print-time-zone date port)
  (when (tm:date-zone-name date)
    (display (tm:date-zone-name date) port)) )

;; Again, locale specific.

(define (locale-am/pm hr) (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)))

(define (tz-printer offset port)
  (if (fx= 0 offset) (display "Z" port)
    (let ((isneg (fx< offset 0)))
      (display (if isneg #\- #\+) port)
      (let ((offset (if isneg (fxneg offset) offset)))
        (display (padding (fx/ offset SEC/HR) #\0 2) port)
        (display (padding (fx/ (fxmod offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )

;; A table of output formatting directives.
;; the first time is the format char.
;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port.

(define tm:display-directives
  (list
    (cons #\~
      (lambda (date pad-with port)
        (display #\~ port)))

    (cons #\a
      (lambda (date pad-with port)
        (display (locale-abbr-weekday (tm:date-week-day date)) port)))

    (cons #\A
      (lambda (date pad-with port)
        (display (locale-long-weekday (tm:date-week-day date)) port)))

    (cons #\b
      (lambda (date pad-with port)
        (display (locale-abbr-month (tm:date-month date)) port)))

    (cons #\B
      (lambda (date pad-with port)
        (display (locale-long-month (tm:date-month date)) port)))

    (cons #\c
      (lambda (date pad-with port)
        (display (date->string date (item@ LOCALE-DATE-TIME-FORMAT)) port)))

    (cons #\d
      (lambda (date pad-with port)
        (display (padding (tm:date-day date) #\0 2) port)))

    (cons #\D
      (lambda (date pad-with port)
        (display (date->string date "~m/~d/~y") port)))

    (cons #\e
      (lambda (date pad-with port)
        (display (padding (tm:date-day date) #\space 2) port)))

    (cons #\f
      (lambda (date pad-with port)
        (let ((ns (tm:date-nanosecond date))
              (sec (tm:date-second date)))
          (if (> ns NS/S) ;This shouldn't happen!
              (display (padding (+ sec 1) pad-with 2) port)
              (display (padding sec pad-with 2) port))
          ;ns must be inexact for 'decimal-expansion'
          (let ((f (decimal-expansion (/ (exact->inexact ns) NS/S) 6)))
            (when (fx< 0 (string-length f))
              (display (item@ LOCALE-NUMBER-SEPARATOR) port)
              (display f port))))))

    (cons #\h
      (lambda (date pad-with port)
        (display (date->string date "~b") port)))

    (cons #\H
      (lambda (date pad-with port)
        (display (padding (tm:date-hour date) pad-with 2) port)))

    (cons #\I
      (lambda (date pad-with port)
        (let ((hr (tm:date-hour date)))
          (if (fx> hr 12)
              (display (padding (fx- hr 12) pad-with 2) port)
              (display (padding hr pad-with 2) port)))))

    (cons #\j
      (lambda (date pad-with port)
        (display (padding (tm:date-year-day date) pad-with 3) port)))

    (cons #\k
      (lambda (date pad-with port)
        (display (padding (tm:date-hour date) #\space 2) port)))

    (cons #\l
      (lambda (date pad-with port)
        (let ((hr (tm:date-hour date)))
          (display (padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))

    (cons #\m
      (lambda (date pad-with port)
        (display (padding (tm:date-month date) pad-with 2) port)))

    (cons #\M
      (lambda (date pad-with port)
        (display (padding (tm:date-minute date) pad-with 2) port)))

    (cons #\n
      (lambda (date pad-with port)
        (newline port)))

    (cons #\N
      (lambda (date pad-with port)
        (display (padding (tm:date-nanosecond date) pad-with 7) port)))

    (cons #\p
      (lambda (date pad-with port)
        (display (locale-am/pm (tm:date-hour date)) port)))

    (cons #\r
      (lambda (date pad-with port)
        (display (date->string date "~I:~M:~S ~p") port)))

    (cons #\s
      (lambda (date pad-with port)
        (display (tm:time-second (tm:date->time-utc date)) port)))

    (cons #\S
      (lambda (date pad-with port)
        (let ((sec (tm:date-second date)))
          (if (> (tm:date-nanosecond date) NS/S) ;This shouldn't happen!
              (display (padding (+ sec 1) pad-with 2) port)
              (display (padding sec pad-with 2) port)))))

    (cons #\t
      (lambda (date pad-with port)
        (display #\tab port)))

    (cons #\T
      (lambda (date pad-with port)
        (display (date->string date "~H:~M:~S") port)))

    (cons #\U
      (lambda (date pad-with port)
        (let ((wkno (tm:date-week-number date 0)))
          (if (fx> (tm:days-before-first-week date 0) 0)
              (display (padding (fx+ wkno 1) #\0 2) port)
              (display (padding wkno #\0 2) port)))))

    (cons #\V
      (lambda (date pad-with port)
        (display (padding (tm:date-week-number date 1) #\0 2) port)))

    (cons #\w
      (lambda (date pad-with port)
        (display (tm:date-week-day date) port)))

    (cons #\W
      (lambda (date pad-with port)
        (let ((wkno (tm:date-week-number date 1)))
          (if (fx> (tm:days-before-first-week date 1) 0)
              (display (padding (fx+ wkno 1) #\0 2) port)
              (display (padding wkno #\0 2) port)))))

    (cons #\x
      (lambda (date pad-with port)
        (display (date->string date (item@ LOCALE-SHORT-DATE-FORMAT)) port)))

    (cons #\X
      (lambda (date pad-with port)
        (display (date->string date (item@ LOCALE-TIME-FORMAT)) port)))

    (cons #\y
      (lambda (date pad-with port)
        (display (padding (fxtake-right-digits (tm:date-year date) 2) pad-with 2) port)))

    (cons #\Y
      (lambda (date pad-with port)
        (display (tm:date-year date) port)))

    (cons #\z
      (lambda (date pad-with port)
        (tz-printer (tm:date-zone-offset date) port)))

    (cons #\Z
      (lambda (date pad-with port)
        (locale-print-time-zone date port)))

    (cons #\1
      (lambda (date pad-with port)
        (display (date->string date "~Y-~m-~d") port)))

    (cons #\2
      (lambda (date pad-with port)
        (display (date->string date "~H:~M:~S~z") port)))

    (cons #\3
      (lambda (date pad-with port)
        (display (date->string date "~H:~M:~S") port)))

    (cons #\4
      (lambda (date pad-with port)
        (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))

    (cons #\5
      (lambda (date pad-with port)
        (display (date->string date "~Y-~m-~dT~H:~M:~S") port))) ) )

(define (date-printer loc date fmt-rem len-rem port)

  ;Check enough format characters
  (define (need-fmt-len amt)
    (when (fx< len-rem amt)
      (error-bad-date-format loc (list->string fmt-rem)) ) )

  ;Perform the conversion
  (define (form-it pad-with key)
    (define (get-formatter)
      (or (alist-ref key tm:display-directives)
          (error-bad-date-format loc (list->string fmt-rem))) )
    ((get-formatter) date pad-with port)
    ;account for conversion character
    (set! fmt-rem (cdr fmt-rem))
    (set! len-rem (fx- len-rem 1)) )

  ;Conversion w/ padding override
  (define (form-it+ pad-with)
    ;the 3rd char is the conversion character
    (need-fmt-len 3) ;tilde+padochar+convchar
    (form-it pad-with (caddr fmt-rem))
    ;account for padding override character
    ;must be done after the format
    (set! fmt-rem (cdr fmt-rem))
    (set! len-rem (fx- len-rem 1)) )

  ;Any formatting left to do?
  (when (fx< 0 len-rem)
    ;Decide what to do with it
    (let ((1st-ch (car fmt-rem)))
      (cond
        ;Not a directive, then just display
        ((not (char=? 1st-ch #\~))
          (display 1st-ch port) )
        ;A directive so need the kind
        (else
          (need-fmt-len 2) ;tilde+convchar
          ;Could be a padding override
          (let ((2nd-ch (cadr fmt-rem)))
            (cond
              ;Override w/ no padding
              ((char=? 2nd-ch #\-)  (form-it+ #f) )
              ;Override w/ space padding
              ((char=? 2nd-ch #\_)  (form-it+ #\space) )
              ;Default 0 padding
              (else                 (form-it #\0 2nd-ch) ) ) ) ) ) )
    ;Remaining formatting
    (date-printer loc date (cdr fmt-rem) (fx- len-rem 1) port) ) )

(define (format-date dest fmtstr . r)
  (let ((port #f)
        (date (optional r #f)) )
    (cond
      ((not dest)       (set! port (open-output-string)) )
      ((string? dest)
        (set! date fmtstr)
        (set! fmtstr dest)
        (set! port (open-output-string)) )
      ((number? dest)   (set! port (current-error-port)) )
      ((port? dest)     (set! port dest) )
      (else             (set! port (current-output-port)) ) )
    (check-date 'format-date date)
    (check-string 'format-date fmtstr)
    (check-output-port 'format-date port)
    (date-printer 'format-date date (string->list fmtstr) (string-length fmtstr) port)
    (or (and dest (not (string? dest)))
        (get-output-string port)) ) )

(define (date->string date . args)
  (let-optionals args ((fmtstr "~c"))
    (check-date 'date->string date)
    (check-string 'date->string fmtstr)
    (let ((port (open-output-string)))
      (date-printer 'date->string date (string->list fmtstr) (string-length fmtstr) port)
      (get-output-string port) ) ) )

;;; Input

(define (digit->int ch)
  (case ch
    ((#\0) 0)
    ((#\1) 1)
    ((#\2) 2)
    ((#\3) 3)
    ((#\4) 4)
    ((#\5) 5)
    ((#\6) 6)
    ((#\7) 7)
    ((#\8) 8)
    ((#\9) 9)
    (else
     (error-bad-date-template 'date-read "not a decimal digit" ch))) )

;; Read an integer upto n characters long on port;
;; upto -> #f if any length

(define (integer-reader upto port)
  (let loop ((accum 0) (nchars 0))
    (let ((ch (peek-char port)))
      (if (or (eof-object? ch)
              (not (char-numeric? ch))
              (and upto (fx>= nchars upto))) accum
        (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1))) ) ) )

(define (make-integer-reader upto)
  (lambda (port)
    (integer-reader upto port) ) )

;; Read *exactly* n characters and convert to integer; could be padded

(define (integer-reader-exact n port)
  (let ((padding-ok #t))
    (let loop ((accum 0) (nchars 0))
      (let ((ch (peek-char port)))
        (cond
          ((fx>= nchars n)
            accum)
          ((eof-object? ch)
            (error-bad-date-template 'string->date
              "premature ending to integer read" 'eof-object))
          ((char-numeric? ch)
            (set! padding-ok #f)
            (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1)))
          (padding-ok
            (read-char port)    ;consume padding
            (loop accum (fx+ nchars 1)))
          (else                ;padding where it shouldn't be
            (error-bad-date-template 'string->date
              "non-numeric characters in integer read" ch))) ) ) ) )

(define (make-integer-exact-reader n)
  (lambda (port)
    (integer-reader-exact n port)) )

(define (zone-reader port)
  (let ((offset 0)
        (is-pos #t)
        (ch (read-char port)) )
    (when (eof-object? ch)
      (error-bad-date-template 'string->date
       "invalid time zone +/-" 'eof-object))
    (if (or (char=? ch #\Z) (char=? ch #\z)) 0
      (begin
        (cond
          ((char=? ch #\+) (set! is-pos #t))
          ((char=? ch #\-) (set! is-pos #f))
          (else
            (error-bad-date-template 'string->date "invalid time zone +/-" ch)))
        (let ((ch (read-char port)))
          (when (eof-object? ch)
            (error-bad-date-template 'string->date
             "invalid time zone number" 'eof-object))
          (set! offset (fx* (digit->int ch) (fx* 10 SEC/HR))))
        ;non-existing values are considered zero
        (let ((ch (read-char port)))
          (unless (eof-object? ch)
            (set! offset (fx+ offset (fx* (digit->int ch) SEC/HR)))))
        (let ((ch (read-char port)))
          (unless (eof-object? ch)
            (set! offset (fx+ offset (fx* (digit->int ch) 600)))))
        (let ((ch (read-char port)))
          (unless (eof-object? ch)
            (set! offset (fx+ offset (fx* (digit->int ch) 60)))))
        (if is-pos offset (fxneg offset)))) ) )

;; Looking at a char, read the char string, run thru indexer, return index

(define (locale-reader port indexer)
  (letrec (
    (read-char-string
      (lambda ()
        (let ((ch (peek-char port)))
          (when (char-alphabetic? ch)
            (write-char (read-char port))
            (read-char-string)) ) )))
    (let* ((str (with-output-to-string read-char-string))
           (index (indexer str)))
      (unless index
        (error-bad-date-template 'string->date "invalid string for indexer" str))
      index ) ) )

(define (make-locale-reader indexer)
  (lambda (port)
    (locale-reader port indexer)) )

(define (make-char-id-reader char)
  (lambda (port)
    (let ((rch (read-char port)))
      (if (char=? char rch) char
        (error-bad-date-template 'string->date "invalid character match" rch) ) ) ) )

;; A List of formatted read directives.
;; Each entry is a list.
;; 1. the character directive;
;; a procedure, which takes a character as input & returns
;; 2. #t as soon as a character on the input port is acceptable
;; for input,
;; 3. a port reader procedure that knows how to read the current port
;; for a value. Its one parameter is the port.
;; 4. a action procedure, that takes the value (from 3.) and some
;; object (here, always the date) and (probably) side-effects it.
;; In some cases (e.g., ~A) the action is to do nothing

(define read-directives
  (let ((ireader4 (make-integer-reader 4))
        (ireader2 (make-integer-reader 2))
        (ireader7 (make-integer-reader 7))
        (ireaderf (make-integer-reader #f))
        (eireader2 (make-integer-exact-reader 2))
        (eireader4 (make-integer-exact-reader 4))
        (locale-reader-abbr-weekday (make-locale-reader locale-abbr-weekday->index))
        (locale-reader-long-weekday (make-locale-reader locale-long-weekday->index))
        (locale-reader-abbr-month   (make-locale-reader locale-abbr-month->index))
        (locale-reader-long-month   (make-locale-reader locale-long-month->index))
        (char-fail (lambda (ch) #t))
        (do-nothing (lambda _ (void))) )

    (list
      (list #\~ char-fail (make-char-id-reader #\~) do-nothing)

      (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)

      (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)

      (list #\b char-alphabetic? locale-reader-abbr-month
        (lambda (val dat) (tm:date-month-set! dat val)))

      (list #\B char-alphabetic? locale-reader-long-month
        (lambda (val dat) (tm:date-month-set! dat val)))

      (list #\d char-numeric? ireader2
        (lambda (val dat) (tm:date-day-set! dat val)))

      (list #\e char-fail eireader2
        (lambda (val dat) (tm:date-day-set! dat val)))

      (list #\h char-alphabetic? locale-reader-abbr-month
        (lambda (val dat) (tm:date-month-set! dat val)))

      (list #\H char-numeric? ireader2
        (lambda (val dat) (tm:date-hour-set! dat val)))

      (list #\k char-fail eireader2
        (lambda (val dat) (tm:date-hour-set! dat val)))

      (list #\m char-numeric? ireader2
        (lambda (val dat) (tm:date-month-set! dat val)))

      (list #\M char-numeric? ireader2
        (lambda (val dat) (tm:date-minute-set! dat val)))

      (list #\N char-numeric? ireader7
        (lambda (val dat) (tm:date-nanosecond-set! dat val)))

      (list #\S char-numeric? ireader2
        (lambda (val dat) (tm:date-second-set! dat val)))

      ;Note that the target date zone-offset value is used!
      (list #\y char-fail eireader2
        (lambda (val dat)
          (tm:date-year-set! dat (tm:natural-year val (tm:date-zone-offset dat)))))

      (list #\Y char-numeric? ireader4
        (lambda (val dat) (tm:date-year-set! dat val)))

      (list #\z
        (lambda (c)
          (or (char=? c #\Z)
              (char=? c #\z)
              (char=? c #\+)
              (char=? c #\-)))
        zone-reader
        (lambda (val dat) (tm:date-zone-offset-set! dat val))) ) ) )

(define (date-reader date fmt-rem len-rem port)
  (let loop ((fmt-rem fmt-rem) (len-rem len-rem))
    (let ((skip-until
           (lambda (skipper)
             (let loop ((ch (peek-char port)))
               (if (eof-object? ch)
                   (error-bad-date-template 'scan-date "" (list->string fmt-rem))
                   (unless (skipper ch)
                     (read-char port)
                     (loop (peek-char port))))))))
      (when (fx< 0 len-rem)
        (let ((cur-ch (car fmt-rem)))
          (cond
            ((not (char=? cur-ch #\~))
              (let ((port-char (read-char port)))
                (when (or (eof-object? port-char)
                          (not (char=? cur-ch port-char)))
                  (error-bad-date-template 'scan-date "" (list->string fmt-rem))))
              (loop (cdr fmt-rem) (fx- len-rem 1)))
            ;otherwise, it's an escape, we hope
            ((fx< len-rem 2)
              (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
            (else
              (let* ((format-char (cadr fmt-rem))
                     (format-info (assoc format-char read-directives)))
                (unless format-info
                  (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
                (let ((skipper (cadr format-info))
                      (reader (caddr format-info))
                      (actor (cadddr format-info)))
                  (skip-until skipper)
                  (let ((val (reader port)))
                    (if (eof-object? val)
                      (error-bad-date-template 'scan-date "" (list->string fmt-rem))
                      (actor val date))))
                (loop (cddr fmt-rem) (fx- len-rem 2))))) ) ) ) ) )

(define (scan-date src fmtstr)
  (let ((port #f)
        (newdate (tm:make-incomplete-date)))
    (let ((date-complete?
           (lambda ()
             (and (tm:date-nanosecond newdate)
                  (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
                  (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
                  (tm:date-zone-offset newdate))))
          (date-ok
           (lambda ()
             (check-date-elements
               'scan-date
               (tm:date-nanosecond newdate)
               (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
               (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
               (tm:date-zone-offset newdate)
               (tm:date-zone-name newdate)))))
      (cond
        ((string? src)  (set! port (open-input-string src)))
        ((port? src)    (set! port src))
        (src            (set! port (current-input-port))))
      (check-input-port 'scan-date port)
      (check-string 'scan-date fmtstr)
      (date-reader newdate (string->list fmtstr) (string-length fmtstr) port)
      (unless (date-complete?)
        (error-bad-date-template 'scan-date "date read incomplete" fmtstr newdate))
      (date-ok)
      newdate ) ) )

(define (string->date src . fmtstr)
  (scan-date src (optional fmtstr (item@ LOCALE-DATE-TIME-FORMAT))) )

) ;module srfi-19-io