guile18/srfi/srfi-19.scm

   1 ;;; srfi-19.scm --- Time/Date Library
   2
   3 ;;      Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Author: Rob Browning <rlb@cs.utexas.edu>
  20 ;;;         Originally from SRFI reference implementation by Will Fitzgerald.
  21
  22 ;;; Commentary:
  23
  24 ;; This module is fully documented in the Guile Reference Manual.
  25
  26 ;;; Code:
  27
  28 ;; FIXME: I haven't checked a decent amount of this code for potential
  29 ;; performance improvements, but I suspect that there may be some
  30 ;; substantial ones to be realized, esp. in the later "parsing" half
  31 ;; of the file, by rewriting the code with use of more Guile native
  32 ;; functions that do more work in a "chunk".
  33 ;;
  34 ;; FIXME: mkoeppe: Time zones are treated a little simplistic in
  35 ;; SRFI-19; they are only a numeric offset.  Thus, printing time zones
  36 ;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly.  The
  37 ;; functions taking an optional TZ-OFFSET should be extended to take a
  38 ;; symbolic time-zone (like "CET"); this string should be stored in
  39 ;; the DATE structure.
  40
  41 (define-module (srfi srfi-19)
  42   :use-module (srfi srfi-6)
  43   :use-module (srfi srfi-8)
  44   :use-module (srfi srfi-9)
  45   :autoload   (ice-9 rdelim) (read-line))
  46
  47 (begin-deprecated
  48  ;; Prevent `export' from re-exporting core bindings.  This behaviour
  49  ;; of `export' is deprecated and will disappear in one of the next
  50  ;; releases.
  51  (define current-time #f))
  52
  53 (export ;; Constants
  54            time-duration
  55            time-monotonic
  56            time-process
  57            time-tai
  58            time-thread
  59            time-utc
  60            ;; Current time and clock resolution
  61            current-date
  62            current-julian-day
  63            current-modified-julian-day
  64            current-time
  65            time-resolution
  66            ;; Time object and accessors
  67            make-time
  68            time?
  69            time-type
  70            time-nanosecond
  71            time-second
  72            set-time-type!
  73            set-time-nanosecond!
  74            set-time-second!
  75            copy-time
  76            ;; Time comparison procedures
  77            time<=?
  78            time<?
  79            time=?
  80            time>=?
  81            time>?
  82            ;; Time arithmetic procedures
  83            time-difference
  84            time-difference!
  85            add-duration
  86            add-duration!
  87            subtract-duration
  88            subtract-duration!
  89            ;; Date object and accessors
  90            make-date
  91            date?
  92            date-nanosecond
  93            date-second
  94            date-minute
  95            date-hour
  96            date-day
  97            date-month
  98            date-year
  99            date-zone-offset
 100            date-year-day
 101            date-week-day
 102            date-week-number
 103            ;; Time/Date/Julian Day/Modified Julian Day converters
 104            date->julian-day
 105            date->modified-julian-day
 106            date->time-monotonic
 107            date->time-tai
 108            date->time-utc
 109            julian-day->date
 110            julian-day->time-monotonic
 111            julian-day->time-tai
 112            julian-day->time-utc
 113            modified-julian-day->date
 114            modified-julian-day->time-monotonic
 115            modified-julian-day->time-tai
 116            modified-julian-day->time-utc
 117            time-monotonic->date
 118            time-monotonic->time-tai
 119            time-monotonic->time-tai!
 120            time-monotonic->time-utc
 121            time-monotonic->time-utc!
 122            time-tai->date
 123            time-tai->julian-day
 124            time-tai->modified-julian-day
 125            time-tai->time-monotonic
 126            time-tai->time-monotonic!
 127            time-tai->time-utc
 128            time-tai->time-utc!
 129            time-utc->date
 130            time-utc->julian-day
 131            time-utc->modified-julian-day
 132            time-utc->time-monotonic
 133            time-utc->time-monotonic!
 134            time-utc->time-tai
 135            time-utc->time-tai!
 136            ;; Date to string/string to date converters.
 137            date->string
 138            string->date)
 139
 140 (cond-expand-provide (current-module) '(srfi-19))
 141
 142 (define time-tai 'time-tai)
 143 (define time-utc 'time-utc)
 144 (define time-monotonic 'time-monotonic)
 145 (define time-thread 'time-thread)
 146 (define time-process 'time-process)
 147 (define time-duration 'time-duration)
 148
 149 ;; FIXME: do we want to add gc time?
 150 ;; (define time-gc 'time-gc)
 151
 152 ;;-- LOCALE dependent constants
 153
 154 (define priv:locale-number-separator ".")
 155
 156 (define priv:locale-abbr-weekday-vector
 157   (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
 158
 159 (define priv:locale-long-weekday-vector
 160   (vector
 161    "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
 162
 163 ;; note empty string in 0th place.
 164 (define priv:locale-abbr-month-vector
 165   (vector ""
 166           "Jan"
 167           "Feb"
 168           "Mar"
 169           "Apr"
 170           "May"
 171           "Jun"
 172           "Jul"
 173           "Aug"
 174           "Sep"
 175           "Oct"
 176           "Nov"
 177           "Dec"))
 178
 179 (define priv:locale-long-month-vector
 180   (vector ""
 181           "January"
 182           "February"
 183           "March"
 184           "April"
 185           "May"
 186           "June"
 187           "July"
 188           "August"
 189           "September"
 190           "October"
 191           "November"
 192           "December"))
 193
 194 (define priv:locale-pm "PM")
 195 (define priv:locale-am "AM")
 196
 197 ;; See date->string
 198 (define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
 199 (define priv:locale-short-date-format "~m/~d/~y")
 200 (define priv:locale-time-format "~H:~M:~S")
 201 (define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
 202
 203 ;;-- Miscellaneous Constants.
 204 ;;-- only the priv:tai-epoch-in-jd might need changing if
 205 ;;   a different epoch is used.
 206
 207 (define priv:nano 1000000000)           ; nanoseconds in a second
 208 (define priv:sid  86400)                ; seconds in a day
 209 (define priv:sihd 43200)                ; seconds in a half day
 210 (define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
 211
 212 ;; FIXME: should this be something other than misc-error?
 213 (define (priv:time-error caller type value)
 214   (if value
 215       (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
 216       (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
 217
 218 ;; A table of leap seconds
 219 ;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
 220 ;; and update as necessary.
 221 ;; this procedures reads the file in the abover
 222 ;; format and creates the leap second table
 223 ;; it also calls the almost standard, but not R5 procedures read-line
 224 ;; & open-input-string
 225 ;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))
 226
 227 (define (priv:read-tai-utc-data filename)
 228   (define (convert-jd jd)
 229     (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid))
 230   (define (convert-sec sec)
 231     (inexact->exact sec))
 232   (let ((port (open-input-file filename))
 233         (table '()))
 234     (let loop ((line (read-line port)))
 235       (if (not (eof-object? line))
 236           (begin
 237             (let* ((data (read (open-input-string
 238                                 (string-append "(" line ")"))))
 239                    (year (car data))
 240                    (jd   (cadddr (cdr data)))
 241                    (secs (cadddr (cdddr data))))
 242               (if (>= year 1972)
 243                   (set! table (cons
 244                                (cons (convert-jd jd) (convert-sec secs))
 245                                table)))
 246               (loop (read-line port))))))
 247     table))
 248
 249 ;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
 250 ;; note they go higher to lower, and end in 1972.
 251 (define priv:leap-second-table
 252   '((1136073600 . 33)
 253     (915148800 . 32)
 254     (867715200 . 31)
 255     (820454400 . 30)
 256     (773020800 . 29)
 257     (741484800 . 28)
 258     (709948800 . 27)
 259     (662688000 . 26)
 260     (631152000 . 25)
 261     (567993600 . 24)
 262     (489024000 . 23)
 263     (425865600 . 22)
 264     (394329600 . 21)
 265     (362793600 . 20)
 266     (315532800 . 19)
 267     (283996800 . 18)
 268     (252460800 . 17)
 269     (220924800 . 16)
 270     (189302400 . 15)
 271     (157766400 . 14)
 272     (126230400 . 13)
 273     (94694400  . 12)
 274     (78796800  . 11)
 275     (63072000  . 10)))
 276
 277 (define (read-leap-second-table filename)
 278   (set! priv:leap-second-table (priv:read-tai-utc-data filename))
 279   (values))
 280
 281
 282 (define (priv:leap-second-delta utc-seconds)
 283   (letrec ((lsd (lambda (table)
 284                   (cond ((>= utc-seconds (caar table))
 285                          (cdar table))
 286                         (else (lsd (cdr table)))))))
 287     (if (< utc-seconds  (* (- 1972 1970) 365 priv:sid)) 0
 288         (lsd  priv:leap-second-table))))
 289
 290
 291 ;;; the TIME structure; creates the accessors, too.
 292
 293 (define-record-type time
 294   (make-time-unnormalized type nanosecond second)
 295   time?
 296   (type time-type set-time-type!)
 297   (nanosecond time-nanosecond set-time-nanosecond!)
 298   (second time-second set-time-second!))
 299
 300 (define (copy-time time)
 301   (make-time (time-type time) (time-nanosecond time) (time-second time)))
 302
 303 (define (priv:split-real r)
 304   (if (integer? r)
 305       (values (inexact->exact r) 0)
 306       (let ((l (truncate r)))
 307         (values (inexact->exact l) (- r l)))))
 308
 309 (define (priv:time-normalize! t)
 310   (if (>= (abs (time-nanosecond t)) 1000000000)
 311       (receive (int frac)
 312           (priv:split-real (time-nanosecond t))
 313         (set-time-second! t (+ (time-second t)
 314                                (quotient int 1000000000)))
 315         (set-time-nanosecond! t (+ (remainder int 1000000000)
 316                                    frac))))
 317   (if (and (positive? (time-second t))
 318            (negative? (time-nanosecond t)))
 319       (begin
 320         (set-time-second! t (- (time-second t) 1))
 321         (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
 322       (if (and (negative? (time-second t))
 323                (positive? (time-nanosecond t)))
 324           (begin
 325             (set-time-second! t (+ (time-second t) 1))
 326             (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
 327   t)
 328
 329 (define (make-time type nanosecond second)
 330   (priv:time-normalize! (make-time-unnormalized type nanosecond second)))
 331
 332 ;; Helpers
 333 ;; FIXME: finish this and publish it?
 334 (define (date->broken-down-time date)
 335   (let ((result (mktime 0)))
 336     ;; FIXME: What should we do about leap-seconds which may overflow
 337     ;; set-tm:sec?
 338     (set-tm:sec result (date-second date))
 339     (set-tm:min result (date-minute date))
 340     (set-tm:hour result (date-hour date))
 341     ;; FIXME: SRFI day ranges from 0-31.  (not compatible with set-tm:mday).
 342     (set-tm:mday result (date-day date))
 343     (set-tm:mon result (- (date-month date) 1))
 344     ;; FIXME: need to signal error on range violation.
 345     (set-tm:year result (+ 1900 (date-year date)))
 346     (set-tm:isdst result -1)
 347     (set-tm:gmtoff result (- (date-zone-offset date)))
 348     result))
 349
 350 ;;; current-time
 351
 352 ;;; specific time getters.
 353
 354 (define (priv:current-time-utc)
 355   ;; Resolution is microseconds.
 356   (let ((tod (gettimeofday)))
 357     (make-time time-utc (* (cdr tod) 1000) (car tod))))
 358
 359 (define (priv:current-time-tai)
 360   ;; Resolution is microseconds.
 361   (let* ((tod (gettimeofday))
 362          (sec (car tod))
 363          (usec (cdr tod)))
 364     (make-time time-tai
 365                (* usec 1000)
 366                (+ (car tod) (priv:leap-second-delta sec)))))
 367
 368 ;;(define (priv:current-time-ms-time time-type proc)
 369 ;;  (let ((current-ms (proc)))
 370 ;;    (make-time time-type
 371 ;;               (quotient current-ms 10000)
 372 ;;       (* (remainder current-ms 1000) 10000))))
 373
 374 ;; -- we define it to be the same as TAI.
 375 ;;    A different implemation of current-time-montonic
 376 ;;    will require rewriting all of the time-monotonic converters,
 377 ;;    of course.
 378
 379 (define (priv:current-time-monotonic)
 380   ;; Resolution is microseconds.
 381   (priv:current-time-tai))
 382
 383 (define (priv:current-time-thread)
 384   (priv:time-error 'current-time 'unsupported-clock-type 'time-thread))
 385
 386 (define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
 387
 388 (define (priv:current-time-process)
 389   (let ((run-time (get-internal-run-time)))
 390     (make-time
 391      time-process
 392      (* (remainder run-time internal-time-units-per-second)
 393         priv:ns-per-guile-tick)
 394      (quotient run-time internal-time-units-per-second))))
 395
 396 ;;(define (priv:current-time-gc)
 397 ;;  (priv:current-time-ms-time time-gc current-gc-milliseconds))
 398
 399 (define (current-time . clock-type)
 400   (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
 401     (cond
 402      ((eq? clock-type time-tai) (priv:current-time-tai))
 403      ((eq? clock-type time-utc) (priv:current-time-utc))
 404      ((eq? clock-type time-monotonic) (priv:current-time-monotonic))
 405      ((eq? clock-type time-thread) (priv:current-time-thread))
 406      ((eq? clock-type time-process) (priv:current-time-process))
 407      ;;     ((eq? clock-type time-gc) (priv:current-time-gc))
 408      (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))
 409
 410 ;; -- Time Resolution
 411 ;; This is the resolution of the clock in nanoseconds.
 412 ;; This will be implementation specific.
 413
 414 (define (time-resolution . clock-type)
 415   (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
 416     (case clock-type
 417       ((time-tai) 1000)
 418       ((time-utc) 1000)
 419       ((time-monotonic) 1000)
 420       ((time-process) priv:ns-per-guile-tick)
 421       ;;     ((eq? clock-type time-thread) 1000)
 422       ;;     ((eq? clock-type time-gc) 10000)
 423       (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type)))))
 424
 425 ;; -- Time comparisons
 426
 427 (define (time=? t1 t2)
 428   ;; Arrange tests for speed and presume that t1 and t2 are actually times.
 429   ;; also presume it will be rare to check two times of different types.
 430   (and (= (time-second t1) (time-second t2))
 431        (= (time-nanosecond t1) (time-nanosecond t2))
 432        (eq? (time-type t1) (time-type t2))))
 433
 434 (define (time>? t1 t2)
 435   (or (> (time-second t1) (time-second t2))
 436       (and (= (time-second t1) (time-second t2))
 437            (> (time-nanosecond t1) (time-nanosecond t2)))))
 438
 439 (define (time<? t1 t2)
 440   (or (< (time-second t1) (time-second t2))
 441       (and (= (time-second t1) (time-second t2))
 442            (< (time-nanosecond t1) (time-nanosecond t2)))))
 443
 444 (define (time>=? t1 t2)
 445   (or (> (time-second t1) (time-second t2))
 446       (and (= (time-second t1) (time-second t2))
 447            (>= (time-nanosecond t1) (time-nanosecond t2)))))
 448
 449 (define (time<=? t1 t2)
 450   (or (< (time-second t1) (time-second t2))
 451       (and (= (time-second t1) (time-second t2))
 452            (<= (time-nanosecond t1) (time-nanosecond t2)))))
 453
 454 ;; -- Time arithmetic
 455
 456 (define (time-difference! time1 time2)
 457   (let ((sec-diff (- (time-second time1) (time-second time2)))
 458         (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
 459     (set-time-type! time1 time-duration)
 460     (set-time-second! time1 sec-diff)
 461     (set-time-nanosecond! time1 nsec-diff)
 462     (priv:time-normalize! time1)))
 463
 464 (define (time-difference time1 time2)
 465   (let ((result (copy-time time1)))
 466     (time-difference! result time2)))
 467
 468 (define (add-duration! t duration)
 469   (if (not (eq? (time-type duration) time-duration))
 470       (priv:time-error 'add-duration 'not-duration duration)
 471       (let ((sec-plus (+ (time-second t) (time-second duration)))
 472             (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
 473         (set-time-second! t sec-plus)
 474         (set-time-nanosecond! t nsec-plus)
 475         (priv:time-normalize! t))))
 476
 477 (define (add-duration t duration)
 478   (let ((result (copy-time t)))
 479     (add-duration! result duration)))
 480
 481 (define (subtract-duration! t duration)
 482   (if (not (eq? (time-type duration) time-duration))
 483       (priv:time-error 'add-duration 'not-duration duration)
 484       (let ((sec-minus  (- (time-second t) (time-second duration)))
 485             (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
 486         (set-time-second! t sec-minus)
 487         (set-time-nanosecond! t nsec-minus)
 488         (priv:time-normalize! t))))
 489
 490 (define (subtract-duration time1 duration)
 491   (let ((result (copy-time time1)))
 492     (subtract-duration! result duration)))
 493
 494 ;; -- Converters between types.
 495
 496 (define (priv:time-tai->time-utc! time-in time-out caller)
 497   (if (not (eq? (time-type time-in) time-tai))
 498       (priv:time-error caller 'incompatible-time-types time-in))
 499   (set-time-type! time-out time-utc)
 500   (set-time-nanosecond! time-out (time-nanosecond time-in))
 501   (set-time-second!     time-out (- (time-second time-in)
 502                                     (priv:leap-second-delta
 503                                      (time-second time-in))))
 504   time-out)
 505
 506 (define (time-tai->time-utc time-in)
 507   (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))
 508
 509
 510 (define (time-tai->time-utc! time-in)
 511   (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
 512
 513 (define (priv:time-utc->time-tai! time-in time-out caller)
 514   (if (not (eq? (time-type time-in) time-utc))
 515       (priv:time-error caller 'incompatible-time-types time-in))
 516   (set-time-type! time-out time-tai)
 517   (set-time-nanosecond! time-out (time-nanosecond time-in))
 518   (set-time-second!     time-out (+ (time-second time-in)
 519                                     (priv:leap-second-delta
 520                                      (time-second time-in))))
 521   time-out)
 522
 523 (define (time-utc->time-tai time-in)
 524   (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))
 525
 526 (define (time-utc->time-tai! time-in)
 527   (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
 528
 529 ;; -- these depend on time-monotonic having the same definition as time-tai!
 530 (define (time-monotonic->time-utc time-in)
 531   (if (not (eq? (time-type time-in) time-monotonic))
 532       (priv:time-error 'time-monotonic->time-utc
 533                        'incompatible-time-types time-in))
 534   (let ((ntime (copy-time time-in)))
 535     (set-time-type! ntime time-tai)
 536     (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
 537
 538 (define (time-monotonic->time-utc! time-in)
 539   (if (not (eq? (time-type time-in) time-monotonic))
 540       (priv:time-error 'time-monotonic->time-utc!
 541                        'incompatible-time-types time-in))
 542   (set-time-type! time-in time-tai)
 543   (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
 544
 545 (define (time-monotonic->time-tai time-in)
 546   (if (not (eq? (time-type time-in) time-monotonic))
 547       (priv:time-error 'time-monotonic->time-tai
 548                        'incompatible-time-types time-in))
 549   (let ((ntime (copy-time time-in)))
 550     (set-time-type! ntime time-tai)
 551     ntime))
 552
 553 (define (time-monotonic->time-tai! time-in)
 554   (if (not (eq? (time-type time-in) time-monotonic))
 555       (priv:time-error 'time-monotonic->time-tai!
 556                        'incompatible-time-types time-in))
 557   (set-time-type! time-in time-tai)
 558   time-in)
 559
 560 (define (time-utc->time-monotonic time-in)
 561   (if (not (eq? (time-type time-in) time-utc))
 562       (priv:time-error 'time-utc->time-monotonic
 563                        'incompatible-time-types time-in))
 564   (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
 565                                          'time-utc->time-monotonic)))
 566     (set-time-type! ntime time-monotonic)
 567     ntime))
 568
 569 (define (time-utc->time-monotonic! time-in)
 570   (if (not (eq? (time-type time-in) time-utc))
 571       (priv:time-error 'time-utc->time-monotonic!
 572                        'incompatible-time-types time-in))
 573   (let ((ntime (priv:time-utc->time-tai! time-in time-in
 574                                          'time-utc->time-monotonic!)))
 575     (set-time-type! ntime time-monotonic)
 576     ntime))
 577
 578 (define (time-tai->time-monotonic time-in)
 579   (if (not (eq? (time-type time-in) time-tai))
 580       (priv:time-error 'time-tai->time-monotonic
 581                        'incompatible-time-types time-in))
 582   (let ((ntime (copy-time time-in)))
 583     (set-time-type! ntime time-monotonic)
 584     ntime))
 585
 586 (define (time-tai->time-monotonic! time-in)
 587   (if (not (eq? (time-type time-in) time-tai))
 588       (priv:time-error 'time-tai->time-monotonic!
 589                        'incompatible-time-types time-in))
 590   (set-time-type! time-in time-monotonic)
 591   time-in)
 592
 593 ;; -- Date Structures
 594
 595 ;; FIXME: to be really safe, perhaps we should normalize the
 596 ;; seconds/nanoseconds/minutes coming in to make-date...
 597
 598 (define-record-type date
 599   (make-date nanosecond second minute
 600              hour day month
 601              year
 602              zone-offset)
 603   date?
 604   (nanosecond date-nanosecond set-date-nanosecond!)
 605   (second date-second set-date-second!)
 606   (minute date-minute set-date-minute!)
 607   (hour date-hour set-date-hour!)
 608   (day date-day set-date-day!)
 609   (month date-month set-date-month!)
 610   (year date-year set-date-year!)
 611   (zone-offset date-zone-offset set-date-zone-offset!))
 612
 613 ;; gives the julian day which starts at noon.
 614 (define (priv:encode-julian-day-number day month year)
 615   (let* ((a (quotient (- 14 month) 12))
 616          (y (- (+ year 4800) a (if (negative? year) -1  0)))
 617          (m (- (+ month (* 12 a)) 3)))
 618     (+ day
 619        (quotient (+ (* 153 m) 2) 5)
 620        (* 365 y)
 621        (quotient y 4)
 622        (- (quotient y 100))
 623        (quotient y 400)
 624        -32045)))
 625
 626 ;; gives the seconds/date/month/year
 627 (define (priv:decode-julian-day-number jdn)
 628   (let* ((days (inexact->exact (truncate jdn)))
 629          (a (+ days 32044))
 630          (b (quotient (+ (* 4 a) 3) 146097))
 631          (c (- a (quotient (* 146097 b) 4)))
 632          (d (quotient (+ (* 4 c) 3) 1461))
 633          (e (- c (quotient (* 1461 d) 4)))
 634          (m (quotient (+ (* 5 e) 2) 153))
 635          (y (+ (* 100 b) d -4800 (quotient m 10))))
 636     (values ; seconds date month year
 637      (* (- jdn days) priv:sid)
 638      (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
 639      (+ m 3 (* -12 (quotient m 10)))
 640      (if (>= 0 y) (- y 1) y))))
 641
 642 ;; relies on the fact that we named our time zone accessor
 643 ;; differently from MzScheme's....
 644 ;; This should be written to be OS specific.
 645
 646 (define (priv:local-tz-offset utc-time)
 647   ;; SRFI uses seconds West, but guile (and libc) use seconds East.
 648   (- (tm:gmtoff (localtime (time-second utc-time)))))
 649
 650 ;; special thing -- ignores nanos
 651 (define (priv:time->julian-day-number seconds tz-offset)
 652   (+ (/ (+ seconds tz-offset priv:sihd)
 653         priv:sid)
 654      priv:tai-epoch-in-jd))
 655
 656 (define (priv:leap-second? second)
 657   (and (assoc second priv:leap-second-table) #t))
 658
 659 (define (time-utc->date time . tz-offset)
 660   (if (not (eq? (time-type time) time-utc))
 661       (priv:time-error 'time->date 'incompatible-time-types  time))
 662   (let* ((offset (if (null? tz-offset)
 663                      (priv:local-tz-offset time)
 664                      (car tz-offset)))
 665          (leap-second? (priv:leap-second? (+ offset (time-second time))))
 666          (jdn (priv:time->julian-day-number (if leap-second?
 667                                                 (- (time-second time) 1)
 668                                                 (time-second time))
 669                                             offset)))
 670
 671     (call-with-values (lambda () (priv:decode-julian-day-number jdn))
 672       (lambda (secs date month year)
 673         ;; secs is a real because jdn is a real in Guile;
 674         ;; but it is conceptionally an integer.
 675         (let* ((int-secs (inexact->exact (round secs)))
 676                (hours    (quotient int-secs (* 60 60)))
 677                (rem      (remainder int-secs (* 60 60)))
 678                (minutes  (quotient rem 60))
 679                (seconds  (remainder rem 60)))
 680           (make-date (time-nanosecond time)
 681                      (if leap-second? (+ seconds 1) seconds)
 682                      minutes
 683                      hours
 684                      date
 685                      month
 686                      year
 687                      offset))))))
 688
 689 (define (time-tai->date time  . tz-offset)
 690   (if (not (eq? (time-type time) time-tai))
 691       (priv:time-error 'time->date 'incompatible-time-types  time))
 692   (let* ((offset (if (null? tz-offset)
 693                      (priv:local-tz-offset (time-tai->time-utc time))
 694                      (car tz-offset)))
 695          (seconds (- (time-second time)
 696                      (priv:leap-second-delta (time-second time))))
 697          (leap-second? (priv:leap-second? (+ offset seconds)))
 698          (jdn (priv:time->julian-day-number (if leap-second?
 699                                                 (- seconds 1)
 700                                                 seconds)
 701                                             offset)))
 702     (call-with-values (lambda () (priv:decode-julian-day-number jdn))
 703       (lambda (secs date month year)
 704         ;; secs is a real because jdn is a real in Guile;
 705         ;; but it is conceptionally an integer.
 706         ;; adjust for leap seconds if necessary ...
 707         (let* ((int-secs (inexact->exact (round secs)))
 708                (hours    (quotient int-secs (* 60 60)))
 709                (rem      (remainder int-secs (* 60 60)))
 710                (minutes  (quotient rem 60))
 711                (seconds  (remainder rem 60)))
 712           (make-date (time-nanosecond time)
 713                      (if leap-second? (+ seconds 1) seconds)
 714                      minutes
 715                      hours
 716                      date
 717                      month
 718                      year
 719                      offset))))))
 720
 721 ;; this is the same as time-tai->date.
 722 (define (time-monotonic->date time . tz-offset)
 723   (if (not (eq? (time-type time) time-monotonic))
 724       (priv:time-error 'time->date 'incompatible-time-types  time))
 725   (let* ((offset (if (null? tz-offset)
 726                      (priv:local-tz-offset (time-monotonic->time-utc time))
 727                      (car tz-offset)))
 728          (seconds (- (time-second time)
 729                      (priv:leap-second-delta (time-second time))))
 730          (leap-second? (priv:leap-second? (+ offset seconds)))
 731          (jdn (priv:time->julian-day-number (if leap-second?
 732                                                 (- seconds 1)
 733                                                 seconds)
 734                                             offset)))
 735     (call-with-values (lambda () (priv:decode-julian-day-number jdn))
 736       (lambda (secs date month year)
 737         ;; secs is a real because jdn is a real in Guile;
 738         ;; but it is conceptionally an integer.
 739         ;; adjust for leap seconds if necessary ...
 740         (let* ((int-secs (inexact->exact (round secs)))
 741                (hours    (quotient int-secs (* 60 60)))
 742                (rem      (remainder int-secs (* 60 60)))
 743                (minutes  (quotient rem 60))
 744                (seconds  (remainder rem 60)))
 745           (make-date (time-nanosecond time)
 746                      (if leap-second? (+ seconds 1) seconds)
 747                      minutes
 748                      hours
 749                      date
 750                      month
 751                      year
 752                      offset))))))
 753
 754 (define (date->time-utc date)
 755   (let* ((jdays (- (priv:encode-julian-day-number (date-day date)
 756                                                  (date-month date)
 757                                                  (date-year date))
 758                    priv:tai-epoch-in-jd))
 759          ;; jdays is an integer plus 1/2,
 760          (jdays-1/2 (inexact->exact (- jdays 1/2))))
 761     (make-time
 762      time-utc
 763      (date-nanosecond date)
 764      (+ (* jdays-1/2 24 60 60)
 765         (* (date-hour date) 60 60)
 766         (* (date-minute date) 60)
 767         (date-second date)
 768         (- (date-zone-offset date))))))
 769
 770 (define (date->time-tai date)
 771   (time-utc->time-tai! (date->time-utc date)))
 772
 773 (define (date->time-monotonic date)
 774   (time-utc->time-monotonic! (date->time-utc date)))
 775
 776 (define (priv:leap-year? year)
 777   (or (= (modulo year 400) 0)
 778       (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
 779
 780 (define (leap-year? date)
 781   (priv:leap-year? (date-year date)))
 782
 783 ;; Map 1-based month number M to number of days in the year before the
 784 ;; start of month M (in a non-leap year).
 785 (define priv:month-assoc '((1 . 0)   (2 . 31)   (3 . 59)   (4 . 90)
 786                            (5 . 120) (6 . 151)  (7 . 181)  (8 . 212)
 787                            (9 . 243) (10 . 273) (11 . 304) (12 . 334)))
 788
 789 (define (priv:year-day day month year)
 790   (let ((days-pr (assoc month priv:month-assoc)))
 791     (if (not days-pr)
 792         (priv:time-error 'date-year-day 'invalid-month-specification month))
 793     (if (and (priv:leap-year? year) (> month 2))
 794         (+ day (cdr days-pr) 1)
 795         (+ day (cdr days-pr)))))
 796
 797 (define (date-year-day date)
 798   (priv:year-day (date-day date) (date-month date) (date-year date)))
 799
 800 ;; from calendar faq
 801 (define (priv:week-day day month year)
 802   (let* ((a (quotient (- 14 month) 12))
 803          (y (- year a))
 804          (m (+ month (* 12 a) -2)))
 805     (modulo (+ day
 806                y
 807                (quotient y 4)
 808                (- (quotient y 100))
 809                (quotient y 400)
 810                (quotient (* 31 m) 12))
 811             7)))
 812
 813 (define (date-week-day date)
 814   (priv:week-day (date-day date) (date-month date) (date-year date)))
 815
 816 (define (priv:days-before-first-week date day-of-week-starting-week)
 817   (let* ((first-day (make-date 0 0 0 0
 818                                1
 819                                1
 820                                (date-year date)
 821                                #f))
 822          (fdweek-day (date-week-day first-day)))
 823     (modulo (- day-of-week-starting-week fdweek-day)
 824             7)))
 825
 826 ;; The "-1" here is a fix for the reference implementation, to make a new
 827 ;; week start on the given day-of-week-starting-week.  date-year-day returns
 828 ;; a day starting from 1 for 1st Jan.
 829 ;;
 830 (define (date-week-number date day-of-week-starting-week)
 831   (quotient (- (date-year-day date)
 832                1
 833                (priv:days-before-first-week  date day-of-week-starting-week))
 834             7))
 835
 836 (define (current-date . tz-offset)
 837   (let ((time (current-time time-utc)))
 838     (time-utc->date
 839      time
 840      (if (null? tz-offset)
 841          (priv:local-tz-offset time)
 842          (car tz-offset)))))
 843
 844 ;; given a 'two digit' number, find the year within 50 years +/-
 845 (define (priv:natural-year n)
 846   (let* ((current-year (date-year (current-date)))
 847          (current-century (* (quotient current-year 100) 100)))
 848     (cond
 849      ((>= n 100) n)
 850      ((<  n 0) n)
 851      ((<=  (- (+ current-century n) current-year) 50) (+ current-century n))
 852      (else (+ (- current-century 100) n)))))
 853
 854 (define (date->julian-day date)
 855   (let ((nanosecond (date-nanosecond date))
 856         (second (date-second date))
 857         (minute (date-minute date))
 858         (hour (date-hour date))
 859         (day (date-day date))
 860         (month (date-month date))
 861         (year (date-year date))
 862         (offset (date-zone-offset date)))
 863     (+ (priv:encode-julian-day-number day month year)
 864        (- 1/2)
 865        (+ (/ (+ (- offset)
 866                 (* hour 60 60)
 867                 (* minute 60)
 868                 second
 869                 (/ nanosecond priv:nano))
 870              priv:sid)))))
 871
 872 (define (date->modified-julian-day date)
 873   (- (date->julian-day date)
 874      4800001/2))
 875
 876 (define (time-utc->julian-day time)
 877   (if (not (eq? (time-type time) time-utc))
 878       (priv:time-error 'time->date 'incompatible-time-types  time))
 879   (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano))
 880         priv:sid)
 881      priv:tai-epoch-in-jd))
 882
 883 (define (time-utc->modified-julian-day time)
 884   (- (time-utc->julian-day time)
 885      4800001/2))
 886
 887 (define (time-tai->julian-day time)
 888   (if (not (eq? (time-type time) time-tai))
 889       (priv:time-error 'time->date 'incompatible-time-types  time))
 890   (+ (/ (+ (- (time-second time)
 891               (priv:leap-second-delta (time-second time)))
 892            (/ (time-nanosecond time) priv:nano))
 893         priv:sid)
 894      priv:tai-epoch-in-jd))
 895
 896 (define (time-tai->modified-julian-day time)
 897   (- (time-tai->julian-day time)
 898      4800001/2))
 899
 900 ;; this is the same as time-tai->julian-day
 901 (define (time-monotonic->julian-day time)
 902   (if (not (eq? (time-type time) time-monotonic))
 903       (priv:time-error 'time->date 'incompatible-time-types  time))
 904   (+ (/ (+ (- (time-second time)
 905               (priv:leap-second-delta (time-second time)))
 906            (/ (time-nanosecond time) priv:nano))
 907         priv:sid)
 908      priv:tai-epoch-in-jd))
 909
 910 (define (time-monotonic->modified-julian-day time)
 911   (- (time-monotonic->julian-day time)
 912      4800001/2))
 913
 914 (define (julian-day->time-utc jdn)
 915   (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
 916     (receive (seconds parts)
 917         (priv:split-real secs)
 918       (make-time time-utc
 919                  (* parts priv:nano)
 920                  seconds))))
 921
 922 (define (julian-day->time-tai jdn)
 923   (time-utc->time-tai! (julian-day->time-utc jdn)))
 924
 925 (define (julian-day->time-monotonic jdn)
 926   (time-utc->time-monotonic! (julian-day->time-utc jdn)))
 927
 928 (define (julian-day->date jdn . tz-offset)
 929   (let* ((time (julian-day->time-utc jdn))
 930          (offset (if (null? tz-offset)
 931                      (priv:local-tz-offset time)
 932                      (car tz-offset))))
 933     (time-utc->date time offset)))
 934
 935 (define (modified-julian-day->date jdn . tz-offset)
 936   (apply julian-day->date (+ jdn 4800001/2)
 937          tz-offset))
 938
 939 (define (modified-julian-day->time-utc jdn)
 940   (julian-day->time-utc (+ jdn 4800001/2)))
 941
 942 (define (modified-julian-day->time-tai jdn)
 943   (julian-day->time-tai (+ jdn 4800001/2)))
 944
 945 (define (modified-julian-day->time-monotonic jdn)
 946   (julian-day->time-monotonic (+ jdn 4800001/2)))
 947
 948 (define (current-julian-day)
 949   (time-utc->julian-day (current-time time-utc)))
 950
 951 (define (current-modified-julian-day)
 952   (time-utc->modified-julian-day (current-time time-utc)))
 953
 954 ;; returns a string rep. of number N, of minimum LENGTH, padded with
 955 ;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's
 956 ;; as if number->string was used.  if string is longer than or equal
 957 ;; in length to LENGTH, it's as if number->string was used.
 958
 959 (define (priv:padding n pad-with length)
 960   (let* ((str (number->string n))
 961          (str-len (string-length str)))
 962     (if (or (>= str-len length)
 963             (not pad-with))
 964         str
 965         (string-append (make-string (- length str-len) pad-with) str))))
 966
 967 (define (priv:last-n-digits i n)
 968   (abs (remainder i (expt 10 n))))
 969
 970 (define (priv:locale-abbr-weekday n)
 971   (vector-ref priv:locale-abbr-weekday-vector n))
 972
 973 (define (priv:locale-long-weekday n)
 974   (vector-ref priv:locale-long-weekday-vector n))
 975
 976 (define (priv:locale-abbr-month n)
 977   (vector-ref priv:locale-abbr-month-vector n))
 978
 979 (define (priv:locale-long-month n)
 980   (vector-ref priv:locale-long-month-vector n))
 981
 982 (define (priv:vector-find needle haystack comparator)
 983   (let ((len (vector-length haystack)))
 984     (define (priv:vector-find-int index)
 985       (cond
 986        ((>= index len) #f)
 987        ((comparator needle (vector-ref haystack index)) index)
 988        (else (priv:vector-find-int (+ index 1)))))
 989     (priv:vector-find-int 0)))
 990
 991 (define (priv:locale-abbr-weekday->index string)
 992   (priv:vector-find string priv:locale-abbr-weekday-vector string=?))
 993
 994 (define (priv:locale-long-weekday->index string)
 995   (priv:vector-find string priv:locale-long-weekday-vector string=?))
 996
 997 (define (priv:locale-abbr-month->index string)
 998   (priv:vector-find string priv:locale-abbr-month-vector string=?))
 999
1000 (define (priv:locale-long-month->index string)
1001   (priv:vector-find string priv:locale-long-month-vector string=?))
1002
1003
1004 ;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
1005 ;; Print it here instead of the numerical offset if available.
1006 (define (priv:locale-print-time-zone date port)
1007   (priv:tz-printer (date-zone-offset date) port))
1008
1009 ;; FIXME: we should use strftime to determine this dynamically if possible.
1010 ;; Again, locale specific.
1011 (define (priv:locale-am/pm hr)
1012   (if (> hr 11) priv:locale-pm priv:locale-am))
1013
1014 (define (priv:tz-printer offset port)
1015   (cond
1016    ((= offset 0) (display "Z" port))
1017    ((negative? offset) (display "-" port))
1018    (else (display "+" port)))
1019   (if (not (= offset 0))
1020       (let ((hours   (abs (quotient offset (* 60 60))))
1021             (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
1022         (display (priv:padding hours #\0 2) port)
1023         (display (priv:padding minutes #\0 2) port))))
1024
1025 ;; A table of output formatting directives.
1026 ;; the first time is the format char.
1027 ;; the second is a procedure that takes the date, a padding character
1028 ;; (which might be #f), and the output port.
1029 ;;
1030 (define priv:directives
1031   (list
1032    (cons #\~ (lambda (date pad-with port)
1033                (display #\~ port)))
1034    (cons #\a (lambda (date pad-with port)
1035                (display (priv:locale-abbr-weekday (date-week-day date))
1036                         port)))
1037    (cons #\A (lambda (date pad-with port)
1038                (display (priv:locale-long-weekday (date-week-day date))
1039                         port)))
1040    (cons #\b (lambda (date pad-with port)
1041                (display (priv:locale-abbr-month (date-month date))
1042                         port)))
1043    (cons #\B (lambda (date pad-with port)
1044                (display (priv:locale-long-month (date-month date))
1045                         port)))
1046    (cons #\c (lambda (date pad-with port)
1047                (display (date->string date priv:locale-date-time-format) port)))
1048    (cons #\d (lambda (date pad-with port)
1049                (display (priv:padding (date-day date)
1050                                       #\0 2)
1051                         port)))
1052    (cons #\D (lambda (date pad-with port)
1053                (display (date->string date "~m/~d/~y") port)))
1054    (cons #\e (lambda (date pad-with port)
1055                (display (priv:padding (date-day date)
1056                                       #\Space 2)
1057                         port)))
1058    (cons #\f (lambda (date pad-with port)
1059                (if (> (date-nanosecond date)
1060                       priv:nano)
1061                    (display (priv:padding (+ (date-second date) 1)
1062                                           pad-with 2)
1063                             port)
1064                    (display (priv:padding (date-second date)
1065                                           pad-with 2)
1066                             port))
1067                (receive (i f)
1068                         (priv:split-real (/
1069                                           (date-nanosecond date)
1070                                           priv:nano 1.0))
1071                         (let* ((ns (number->string f))
1072                                (le (string-length ns)))
1073                           (if (> le 2)
1074                               (begin
1075                                 (display priv:locale-number-separator port)
1076                                 (display (substring ns 2 le) port)))))))
1077    (cons #\h (lambda (date pad-with port)
1078                (display (date->string date "~b") port)))
1079    (cons #\H (lambda (date pad-with port)
1080                (display (priv:padding (date-hour date)
1081                                       pad-with 2)
1082                         port)))
1083    (cons #\I (lambda (date pad-with port)
1084                (let ((hr (date-hour date)))
1085                  (if (> hr 12)
1086                      (display (priv:padding (- hr 12)
1087                                             pad-with 2)
1088                               port)
1089                      (display (priv:padding hr
1090                                             pad-with 2)
1091                               port)))))
1092    (cons #\j (lambda (date pad-with port)
1093                (display (priv:padding (date-year-day date)
1094                                       pad-with 3)
1095                         port)))
1096    (cons #\k (lambda (date pad-with port)
1097                (display (priv:padding (date-hour date)
1098                                       #\Space 2)
1099                         port)))
1100    (cons #\l (lambda (date pad-with port)
1101                (let ((hr (if (> (date-hour date) 12)
1102                              (- (date-hour date) 12) (date-hour date))))
1103                  (display (priv:padding hr  #\Space 2)
1104                           port))))
1105    (cons #\m (lambda (date pad-with port)
1106                (display (priv:padding (date-month date)
1107                                       pad-with 2)
1108                         port)))
1109    (cons #\M (lambda (date pad-with port)
1110                (display (priv:padding (date-minute date)
1111                                       pad-with 2)
1112                         port)))
1113    (cons #\n (lambda (date pad-with port)
1114                (newline port)))
1115    (cons #\N (lambda (date pad-with port)
1116                (display (priv:padding (date-nanosecond date)
1117                                       pad-with 7)
1118                         port)))
1119    (cons #\p (lambda (date pad-with port)
1120                (display (priv:locale-am/pm (date-hour date)) port)))
1121    (cons #\r (lambda (date pad-with port)
1122                (display (date->string date "~I:~M:~S ~p") port)))
1123    (cons #\s (lambda (date pad-with port)
1124                (display (time-second (date->time-utc date)) port)))
1125    (cons #\S (lambda (date pad-with port)
1126                (if (> (date-nanosecond date)
1127                       priv:nano)
1128                    (display (priv:padding (+ (date-second date) 1)
1129                                           pad-with 2)
1130                             port)
1131                    (display (priv:padding (date-second date)
1132                                           pad-with 2)
1133                             port))))
1134    (cons #\t (lambda (date pad-with port)
1135                (display #\Tab port)))
1136    (cons #\T (lambda (date pad-with port)
1137                (display (date->string date "~H:~M:~S") port)))
1138    (cons #\U (lambda (date pad-with port)
1139                (if (> (priv:days-before-first-week date 0) 0)
1140                    (display (priv:padding (+ (date-week-number date 0) 1)
1141                                           #\0 2) port)
1142                    (display (priv:padding (date-week-number date 0)
1143                                           #\0 2) port))))
1144    (cons #\V (lambda (date pad-with port)
1145                (display (priv:padding (date-week-number date 1)
1146                                       #\0 2) port)))
1147    (cons #\w (lambda (date pad-with port)
1148                (display (date-week-day date) port)))
1149    (cons #\x (lambda (date pad-with port)
1150                (display (date->string date priv:locale-short-date-format) port)))
1151    (cons #\X (lambda (date pad-with port)
1152                (display (date->string date priv:locale-time-format) port)))
1153    (cons #\W (lambda (date pad-with port)
1154                (if (> (priv:days-before-first-week date 1) 0)
1155                    (display (priv:padding (+ (date-week-number date 1) 1)
1156                                           #\0 2) port)
1157                    (display (priv:padding (date-week-number date 1)
1158                                           #\0 2) port))))
1159    (cons #\y (lambda (date pad-with port)
1160                (display (priv:padding (priv:last-n-digits
1161                                        (date-year date) 2)
1162                                       pad-with
1163                                       2)
1164                         port)))
1165    (cons #\Y (lambda (date pad-with port)
1166                (display (date-year date) port)))
1167    (cons #\z (lambda (date pad-with port)
1168                (priv:tz-printer (date-zone-offset date) port)))
1169    (cons #\Z (lambda (date pad-with port)
1170                (priv:locale-print-time-zone date port)))
1171    (cons #\1 (lambda (date pad-with port)
1172                (display (date->string date "~Y-~m-~d") port)))
1173    (cons #\2 (lambda (date pad-with port)
1174                (display (date->string date "~k:~M:~S~z") port)))
1175    (cons #\3 (lambda (date pad-with port)
1176                (display (date->string date "~k:~M:~S") port)))
1177    (cons #\4 (lambda (date pad-with port)
1178                (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
1179    (cons #\5 (lambda (date pad-with port)
1180                (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
1181
1182
1183 (define (priv:get-formatter char)
1184   (let ((associated (assoc char priv:directives)))
1185     (if associated (cdr associated) #f)))
1186
1187 (define (priv:date-printer date index format-string str-len port)
1188   (if (>= index str-len)
1189       (values)
1190       (let ((current-char (string-ref format-string index)))
1191         (if (not (char=? current-char #\~))
1192             (begin
1193               (display current-char port)
1194               (priv:date-printer date (+ index 1) format-string str-len port))
1195             (if (= (+ index 1) str-len) ; bad format string.
1196                 (priv:time-error 'priv:date-printer 'bad-date-format-string
1197                                  format-string)
1198                 (let ((pad-char? (string-ref format-string (+ index 1))))
1199                   (cond
1200                    ((char=? pad-char? #\-)
1201                     (if (= (+ index 2) str-len) ; bad format string.
1202                         (priv:time-error 'priv:date-printer
1203                                          'bad-date-format-string
1204                                          format-string)
1205                         (let ((formatter (priv:get-formatter
1206                                           (string-ref format-string
1207                                                       (+ index 2)))))
1208                           (if (not formatter)
1209                               (priv:time-error 'priv:date-printer
1210                                                'bad-date-format-string
1211                                                format-string)
1212                               (begin
1213                                 (formatter date #f port)
1214                                 (priv:date-printer date
1215                                                    (+ index 3)
1216                                                    format-string
1217                                                    str-len
1218                                                    port))))))
1219
1220                    ((char=? pad-char? #\_)
1221                     (if (= (+ index 2) str-len) ; bad format string.
1222                         (priv:time-error 'priv:date-printer
1223                                          'bad-date-format-string
1224                                          format-string)
1225                         (let ((formatter (priv:get-formatter
1226                                           (string-ref format-string
1227                                                       (+ index 2)))))
1228                           (if (not formatter)
1229                               (priv:time-error 'priv:date-printer
1230                                                'bad-date-format-string
1231                                                format-string)
1232                               (begin
1233                                 (formatter date #\Space port)
1234                                 (priv:date-printer date
1235                                                    (+ index 3)
1236                                                    format-string
1237                                                    str-len
1238                                                    port))))))
1239                    (else
1240                     (let ((formatter (priv:get-formatter
1241                                       (string-ref format-string
1242                                                   (+ index 1)))))
1243                       (if (not formatter)
1244                           (priv:time-error 'priv:date-printer
1245                                            'bad-date-format-string
1246                                            format-string)
1247                           (begin
1248                             (formatter date #\0 port)
1249                             (priv:date-printer date
1250                                                (+ index 2)
1251                                                format-string
1252                                                str-len
1253                                                port))))))))))))
1254
1255
1256 (define (date->string date .  format-string)
1257   (let ((str-port (open-output-string))
1258         (fmt-str (if (null? format-string) "~c" (car format-string))))
1259     (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
1260     (get-output-string str-port)))
1261
1262 (define (priv:char->int ch)
1263   (case ch
1264    ((#\0) 0)
1265    ((#\1) 1)
1266    ((#\2) 2)
1267    ((#\3) 3)
1268    ((#\4) 4)
1269    ((#\5) 5)
1270    ((#\6) 6)
1271    ((#\7) 7)
1272    ((#\8) 8)
1273    ((#\9) 9)
1274    (else (priv:time-error 'bad-date-template-string
1275                           (list "Non-integer character" ch)))))
1276
1277 ;; read an integer upto n characters long on port; upto -> #f is any length
1278 (define (priv:integer-reader upto port)
1279   (let loop ((accum 0) (nchars 0))
1280     (let ((ch (peek-char port)))
1281       (if (or (eof-object? ch)
1282               (not (char-numeric? ch))
1283               (and upto (>= nchars  upto)))
1284           accum
1285           (loop (+ (* accum 10) (priv:char->int (read-char port)))
1286                 (+ nchars 1))))))
1287
1288 (define (priv:make-integer-reader upto)
1289   (lambda (port)
1290     (priv:integer-reader upto port)))
1291
1292 ;; read *exactly* n characters and convert to integer; could be padded
1293 (define (priv:integer-reader-exact n port)
1294   (let ((padding-ok #t))
1295     (define (accum-int port accum nchars)
1296       (let ((ch (peek-char port)))
1297         (cond
1298          ((>= nchars n) accum)
1299          ((eof-object? ch)
1300           (priv:time-error 'string->date 'bad-date-template-string
1301                            "Premature ending to integer read."))
1302          ((char-numeric? ch)
1303           (set! padding-ok #f)
1304           (accum-int port
1305                      (+ (* accum 10) (priv:char->int (read-char port)))
1306                      (+ nchars 1)))
1307          (padding-ok
1308           (read-char port) ; consume padding
1309           (accum-int port accum (+ nchars 1)))
1310          (else ; padding where it shouldn't be
1311           (priv:time-error 'string->date 'bad-date-template-string
1312                            "Non-numeric characters in integer read.")))))
1313     (accum-int port 0 0)))
1314
1315
1316 (define (priv:make-integer-exact-reader n)
1317   (lambda (port)
1318     (priv:integer-reader-exact n port)))
1319
1320 (define (priv:zone-reader port)
1321   (let ((offset 0)
1322         (positive? #f))
1323     (let ((ch (read-char port)))
1324       (if (eof-object? ch)
1325           (priv:time-error 'string->date 'bad-date-template-string
1326                            (list "Invalid time zone +/-" ch)))
1327       (if (or (char=? ch #\Z) (char=? ch #\z))
1328           0
1329           (begin
1330             (cond
1331              ((char=? ch #\+) (set! positive? #t))
1332              ((char=? ch #\-) (set! positive? #f))
1333              (else
1334               (priv:time-error 'string->date 'bad-date-template-string
1335                                (list "Invalid time zone +/-" ch))))
1336             (let ((ch (read-char port)))
1337               (if (eof-object? ch)
1338                   (priv:time-error 'string->date 'bad-date-template-string
1339                                    (list "Invalid time zone number" ch)))
1340               (set! offset (* (priv:char->int ch)
1341                               10 60 60)))
1342             (let ((ch (read-char port)))
1343               (if (eof-object? ch)
1344                   (priv:time-error 'string->date 'bad-date-template-string
1345                                    (list "Invalid time zone number" ch)))
1346               (set! offset (+ offset (* (priv:char->int ch)
1347                                         60 60))))
1348             (let ((ch (read-char port)))
1349               (if (eof-object? ch)
1350                   (priv:time-error 'string->date 'bad-date-template-string
1351                                    (list "Invalid time zone number" ch)))
1352               (set! offset (+ offset (* (priv:char->int ch)
1353                                         10 60))))
1354             (let ((ch (read-char port)))
1355               (if (eof-object? ch)
1356                   (priv:time-error 'string->date 'bad-date-template-string
1357                                    (list "Invalid time zone number" ch)))
1358               (set! offset (+ offset (* (priv:char->int ch)
1359                                         60))))
1360             (if positive? offset (- offset)))))))
1361
1362 ;; looking at a char, read the char string, run thru indexer, return index
1363 (define (priv:locale-reader port indexer)
1364
1365   (define (read-char-string result)
1366     (let ((ch (peek-char port)))
1367       (if (char-alphabetic? ch)
1368           (read-char-string (cons (read-char port) result))
1369           (list->string (reverse! result)))))
1370
1371   (let* ((str (read-char-string '()))
1372          (index (indexer str)))
1373     (if index index (priv:time-error 'string->date
1374                                      'bad-date-template-string
1375                                      (list "Invalid string for " indexer)))))
1376
1377 (define (priv:make-locale-reader indexer)
1378   (lambda (port)
1379     (priv:locale-reader port indexer)))
1380
1381 (define (priv:make-char-id-reader char)
1382   (lambda (port)
1383     (if (char=? char (read-char port))
1384         char
1385         (priv:time-error 'string->date
1386                          'bad-date-template-string
1387                          "Invalid character match."))))
1388
1389 ;; A List of formatted read directives.
1390 ;; Each entry is a list.
1391 ;; 1. the character directive;
1392 ;; a procedure, which takes a character as input & returns
1393 ;; 2. #t as soon as a character on the input port is acceptable
1394 ;; for input,
1395 ;; 3. a port reader procedure that knows how to read the current port
1396 ;; for a value. Its one parameter is the port.
1397 ;; 4. a action procedure, that takes the value (from 3.) and some
1398 ;; object (here, always the date) and (probably) side-effects it.
1399 ;; In some cases (e.g., ~A) the action is to do nothing
1400
1401 (define priv:read-directives
1402   (let ((ireader4 (priv:make-integer-reader 4))
1403         (ireader2 (priv:make-integer-reader 2))
1404         (ireaderf (priv:make-integer-reader #f))
1405         (eireader2 (priv:make-integer-exact-reader 2))
1406         (eireader4 (priv:make-integer-exact-reader 4))
1407         (locale-reader-abbr-weekday (priv:make-locale-reader
1408                                      priv:locale-abbr-weekday->index))
1409         (locale-reader-long-weekday (priv:make-locale-reader
1410                                      priv:locale-long-weekday->index))
1411         (locale-reader-abbr-month   (priv:make-locale-reader
1412                                      priv:locale-abbr-month->index))
1413         (locale-reader-long-month   (priv:make-locale-reader
1414                                      priv:locale-long-month->index))
1415         (char-fail (lambda (ch) #t))
1416         (do-nothing (lambda (val object) (values))))
1417
1418     (list
1419      (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing)
1420      (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
1421      (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
1422      (list #\b char-alphabetic? locale-reader-abbr-month
1423            (lambda (val object)
1424              (set-date-month! object val)))
1425      (list #\B char-alphabetic? locale-reader-long-month
1426            (lambda (val object)
1427              (set-date-month! object val)))
1428      (list #\d char-numeric? ireader2 (lambda (val object)
1429                                         (set-date-day!
1430                                          object val)))
1431      (list #\e char-fail eireader2 (lambda (val object)
1432                                      (set-date-day! object val)))
1433      (list #\h char-alphabetic? locale-reader-abbr-month
1434            (lambda (val object)
1435              (set-date-month! object val)))
1436      (list #\H char-numeric? ireader2 (lambda (val object)
1437                                         (set-date-hour! object val)))
1438      (list #\k char-fail eireader2 (lambda (val object)
1439                                      (set-date-hour! object val)))
1440      (list #\m char-numeric? ireader2 (lambda (val object)
1441                                         (set-date-month! object val)))
1442      (list #\M char-numeric? ireader2 (lambda (val object)
1443                                         (set-date-minute!
1444                                          object val)))
1445      (list #\S char-numeric? ireader2 (lambda (val object)
1446                                         (set-date-second! object val)))
1447      (list #\y char-fail eireader2
1448            (lambda (val object)
1449              (set-date-year! object (priv:natural-year val))))
1450      (list #\Y char-numeric? ireader4 (lambda (val object)
1451                                         (set-date-year! object val)))
1452      (list #\z (lambda (c)
1453                  (or (char=? c #\Z)
1454                      (char=? c #\z)
1455                      (char=? c #\+)
1456                      (char=? c #\-)))
1457            priv:zone-reader (lambda (val object)
1458                               (set-date-zone-offset! object val))))))
1459
1460 (define (priv:string->date date index format-string str-len port template-string)
1461   (define (skip-until port skipper)
1462     (let ((ch (peek-char port)))
1463       (if (eof-object? ch)
1464           (priv:time-error 'string->date 'bad-date-format-string template-string)
1465           (if (not (skipper ch))
1466               (begin (read-char port) (skip-until port skipper))))))
1467   (if (>= index str-len)
1468       (begin
1469         (values))
1470       (let ((current-char (string-ref format-string index)))
1471         (if (not (char=? current-char #\~))
1472             (let ((port-char (read-char port)))
1473               (if (or (eof-object? port-char)
1474                       (not (char=? current-char port-char)))
1475                   (priv:time-error 'string->date
1476                                    'bad-date-format-string template-string))
1477               (priv:string->date date
1478                                  (+ index 1)
1479                                  format-string
1480                                  str-len
1481                                  port
1482                                  template-string))
1483             ;; otherwise, it's an escape, we hope
1484             (if (> (+ index 1) str-len)
1485                 (priv:time-error 'string->date
1486                                  'bad-date-format-string template-string)
1487                 (let* ((format-char (string-ref format-string (+ index 1)))
1488                        (format-info (assoc format-char priv:read-directives)))
1489                   (if (not format-info)
1490                       (priv:time-error 'string->date
1491                                        'bad-date-format-string template-string)
1492                       (begin
1493                         (let ((skipper (cadr format-info))
1494                               (reader  (caddr format-info))
1495                               (actor   (cadddr format-info)))
1496                           (skip-until port skipper)
1497                           (let ((val (reader port)))
1498                             (if (eof-object? val)
1499                                 (priv:time-error 'string->date
1500                                                  'bad-date-format-string
1501                                                  template-string)
1502                                 (actor val date)))
1503                           (priv:string->date date
1504                                              (+ index 2)
1505                                              format-string
1506                                              str-len
1507                                              port
1508                                              template-string))))))))))
1509
1510 (define (string->date input-string template-string)
1511   (define (priv:date-ok? date)
1512     (and (date-nanosecond date)
1513          (date-second date)
1514          (date-minute date)
1515          (date-hour date)
1516          (date-day date)
1517          (date-month date)
1518          (date-year date)
1519          (date-zone-offset date)))
1520   (let ((newdate (make-date 0 0 0 0 #f #f #f #f)))
1521     (priv:string->date newdate
1522                        0
1523                        template-string
1524                        (string-length template-string)
1525                        (open-input-string input-string)
1526                        template-string)
1527     (if (not (date-zone-offset newdate))
1528         (begin
1529           ;; this is necessary to get DST right -- as far as we can
1530           ;; get it right (think of the double/missing hour in the
1531           ;; night when we are switching between normal time and DST).
1532           (set-date-zone-offset! newdate
1533                                  (priv:local-tz-offset
1534                                   (make-time time-utc 0 0)))
1535           (set-date-zone-offset! newdate
1536                                  (priv:local-tz-offset
1537                                   (date->time-utc newdate)))))
1538     (if (priv:date-ok? newdate)
1539         newdate
1540         (priv:time-error
1541          'string->date
1542          'bad-date-format-string
1543          (list "Incomplete date read. " newdate template-string)))))
1544
1545 ;;; srfi-19.scm ends here