srfi/srfi-19.scm

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