;;;; srfi-19-io.scm  -*- Scheme -*-
;;;; 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 scheme
  utf8
  (chicken base)
  (chicken type)
  srfi-6
  (only (srfi 1) drop)
  (only utf8-srfi-13 string-pad)
  (only (chicken port) with-output-to-string)
  ;NOTE no substring operations so safe w/ utf8
  (only (chicken string) reverse-string-append)
  (only (srfi 29)
    localized-template/default reset-locale-parameters
    load-best-available-bundle! most-specific-bundle-specifier)
  (only type-checks check-string check-output-port check-input-port)
  (only srfi-19-support check-date check-date-by-elements)
  srfi-19-tm)

;;;

(include-relative "srfi-19-common")

(include-relative "srfi-19-common.types")

(: date->string (date #!optional string -> string))
(: string->date (string #!optional string -> date))
(: format-date ((or boolean output-port string number) (or string date) #!optional date -> (or true string)))
(: scan-date ((or true string input-port) string -> date))

;;;

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

(define *bad-date-template-message* "bad date template")

(define (error-bad-date-template loc msg . args)
  (apply error
    loc
    (if (not msg)
      *bad-date-template-message*
      (string-append *bad-date-template-message* " - " msg))
    args) )

;;;

;; -- Locale bundle item keys

(define LOCALE-NUMBER-SEPARATOR 'separator)

(define LOCALE-ABRV-WEEKDAYS #(#f sun mon tue wed thu fri sat))
(define LOCALE-LONG-WEEKDAYS #(#f 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 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 (zero? p) (zero? n))
      (reverse-string-append ls)
      (let* ((n*10 (* 10 n))
             (rn*10 (round n*10)))
        (loop
          (- n*10 rn*10)
          (- 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
        (<= 2 len)
        (char=? #\. (string-ref str (- len 2)))
        (char=? #\0 (string-ref str (- len 1))) ) )
    (let ((str
            (if (not (trailing-dotzero?))
              str
              (substring str 0 (- len 2)) ) ) )
      (if (or (not pad-with) (> len length))
        str
        (string-pad str length pad-with)) ) ) )

(define take-right-digits
  (let ((nth #(0 10 100 1000 100000 1000000 10000000 100000000 1000000000)))
    (lambda (i n)
      (modulo (abs i) (vector-ref nth n)) ) ) )

(define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS (+ n 1))))
(define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS (+ n 1))))
(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 (- (vector-length vec) 1)))
    (and
      (positive? idx)
      (or
        (and
          (string=? str (item@ (vector-ref vec idx)))
          idx)
        (loop (- 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 (> hr 11) LOCALE-PM LOCALE-AM)))

(define (tz-printer offset port)
  (if (zero? offset)
    (display "Z" port)
    (let* ((isneg (negative? offset))
           (offset (if isneg (- offset) offset)) )
      (let-values (((hr hr-sec) (quotient&remainder offset SEC/HR)))
        (display (if isneg #\- #\+) port)
        (display (padding hr #\0 2) port)
        (display (padding (quotient hr-sec 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 (positive? (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 (> hr 12)
            (display (padding (- 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 (> hr 12) (- 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 (positive? (tm:days-before-first-week date 0))
            (display (padding (+ 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 (positive? (tm:days-before-first-week date 1))
            (display (padding (+ 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 (take-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 (< 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 (- 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 (- len-rem 1)) )

  ;Any formatting left to do?
  (when (positive? 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) (- len-rem 1) port) ) )

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

(define (date->string date . args)
  (let-optionals args ((fmt "~c"))
    (check-date 'date->string date)
    (check-string 'date->string fmt)
    (let ((port (open-output-string)))
      (date-printer 'date->string date (string->list fmt) (string-length fmt) 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)
  (define (eoi? ch nchars)
    (or (eof-object? ch)
        (not (char-numeric? ch))
        (and upto (>= nchars upto))) )
  (let loop ((accum 0) (nchars 0))
    (if (eoi? (peek-char port) nchars)
      accum
      (loop (+ (* accum 10) (digit->int (read-char port))) (+ 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
          ((>= 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 (+ (* accum 10) (digit->int (read-char port))) (+ nchars 1)))
          (padding-ok
            (read-char port)    ;consume padding
            (loop accum (+ 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)
  ;NOTE original is-pos & offset were in top let, w/ is-pos value set!, w/
  ;-strict-types the compiler assumed is-pos didn't change its' value from the
  ;initial #t!
  (define (optdec off fac)
    (let ((ch (read-char port)))
      (if (eof-object? ch)
        off
        (+ off (* (digit->int ch) fac)))) )
  (let ((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
      (let* ((is-pos
              (cond
                ((char=? ch #\+) #t)
                ((char=? ch #\-) #f)
                (else
                  (error-bad-date-template 'string->date "invalid time zone +/-" ch))))
             (offset
               (let ((ch (read-char port)))
                 (when (eof-object? ch)
                   (error-bad-date-template 'string->date "invalid time zone number" 'eof-object))
                 (* (digit->int ch) (* 10 SEC/HR))))
             ;non-existing values are considered zero
             (offset (optdec offset SEC/HR))
             (offset (optdec offset (* 10 SEC/MIN)))
             (offset (optdec offset SEC/MIN)) )
        (if is-pos offset (- 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 #f (list->string fmt-rem))
                 (unless (skipper ch)
                   (read-char port)
                   (loop (peek-char port))))))))
      (when (positive? 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 #f (list->string fmt-rem))))
              (loop (cdr fmt-rem) (- len-rem 1)))
            ;otherwise, it's an escape, we hope
            ((< len-rem 2)
              (error-bad-date-template 'scan-date #f (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 #f (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 #f (list->string fmt-rem))
                      (actor val date))))
                (loop (cddr fmt-rem) (- len-rem 2))))) ) ) ) ) )

(define (scan-date src fmt)
  (check-string 'scan-date fmt)
  (let ((inp
          (check-input-port 'scan-date
            (cond
              ((string? src)
                (open-input-string src))
              ((input-port? src)
                src)
              (src
                (current-input-port)))))
        (newdat
          (tm:make-incomplete-date)) )
    (date-reader newdat (string->list fmt) (string-length fmt) inp)
    ;missing (all-of) d-m-y filled in w/ current; probable time only format
    (when (not (or (tm:date-day newdat) (tm:date-month newdat) (tm:date-year newdat)))
      (let ((curdat (tm:current-date (tm:date-timezone-info newdat))))
        (tm:date-day-set! newdat (tm:date-day curdat))
        (tm:date-month-set! newdat (tm:date-month curdat))
        (tm:date-year-set! newdat (tm:date-year curdat)) ) )
    (unless (tm:date-complete? newdat)
      (error-bad-date-template 'scan-date "date read incomplete" fmt newdat) )
    ;final validation
    (check-date-by-elements 'scan-date newdat) ) )

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

;;;
;;; Module Init
;;;

;; SRFI-29: Localization initialization

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

) ;module srfi-19-io