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