code:
;;; srfi-19.scm --- Time/Date Library

;; 	Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Rob Browning <rlb@cs.utexas.edu>
;;;         Originally from SRFI reference implementation by Will Fitzgerald.

;;; Commentary:

;; This module is fully documented in the Guile Reference Manual.

;;; Code:

;; FIXME: I haven't checked a decent amount of this code for potential
;; performance improvements, but I suspect that there may be some
;; substantial ones to be realized, esp. in the later "parsing" half
;; of the file, by rewriting the code with use of more Guile native
;; functions that do more work in a "chunk".
;;
;; FIXME: mkoeppe: Time zones are treated a little simplistic in
;; SRFI-19; they are only a numeric offset.  Thus, printing time zones
;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly.  The
;; functions taking an optional TZ-OFFSET should be extended to take a
;; symbolic time-zone (like "CET"); this string should be stored in
;; the DATE structure.

(define-module (srfi srfi-19)
  :use-module (srfi srfi-6)
  :use-module (srfi srfi-8)
  :use-module (srfi srfi-9)
  :autoload   (ice-9 rdelim) (read-line)
  :use-module (ice-9 i18n)
  :replace (current-time)
  :export (;; Constants
           time-duration
           time-monotonic
           time-process
           time-tai
           time-thread
           time-utc
           ;; Current time and clock resolution
           current-date
           current-julian-day
           current-modified-julian-day
           time-resolution
           ;; Time object and accessors
           make-time
           time?
           time-type
           time-nanosecond
           time-second
           set-time-type!
           set-time-nanosecond!
           set-time-second!
           copy-time
           ;; Time comparison procedures
           time<=?
           time<?
           time=?
           time>=?
           time>?
           ;; Time arithmetic procedures
           time-difference
           time-difference!
           add-duration
           add-duration!
           subtract-duration
           subtract-duration!
           ;; Date object and accessors
           make-date
           date?
           date-nanosecond
           date-second
           date-minute
           date-hour
           date-day
           date-month
           date-year
           date-zone-offset
           date-year-day
           date-week-day
           date-week-number
           ;; Time/Date/Julian Day/Modified Julian Day converters
           date->julian-day
           date->modified-julian-day
           date->time-monotonic
           date->time-tai
           date->time-utc
           julian-day->date
           julian-day->time-monotonic
           julian-day->time-tai
           julian-day->time-utc
           modified-julian-day->date
           modified-julian-day->time-monotonic
           modified-julian-day->time-tai
           modified-julian-day->time-utc
           time-monotonic->date
           time-monotonic->julian-day
           time-monotonic->modified-julian-day
           time-monotonic->time-tai
           time-monotonic->time-tai!
           time-monotonic->time-utc
           time-monotonic->time-utc!
           time-tai->date
           time-tai->julian-day
           time-tai->modified-julian-day
           time-tai->time-monotonic
           time-tai->time-monotonic!
           time-tai->time-utc
           time-tai->time-utc!
           time-utc->date
           time-utc->julian-day
           time-utc->modified-julian-day
           time-utc->time-monotonic
           time-utc->time-monotonic!
           time-utc->time-tai
           time-utc->time-tai!
           ;; Date to string/string to date converters.
           date->string
           string->date))

(cond-expand-provide (current-module) '(srfi-19))

(define time-tai 'time-tai)
(define time-utc 'time-utc)
(define time-monotonic 'time-monotonic)
(define time-thread 'time-thread)
(define time-process 'time-process)
(define time-duration 'time-duration)

;; FIXME: do we want to add gc time?
;; (define time-gc 'time-gc)

;;-- LOCALE dependent constants

(define priv:locale-number-separator locale-decimal-point)
(define priv:locale-pm               locale-pm-string)
(define priv:locale-am               locale-am-string)

;; See date->string
(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
(define priv:locale-short-date-format "~m/~d/~y")
(define priv:locale-time-format "~H:~M:~S")
(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")

;;-- Miscellaneous Constants.
;;-- only the priv:tai-epoch-in-jd might need changing if
;;   a different epoch is used.

(define priv:nano 1000000000)           ; nanoseconds in a second
(define priv:sid  86400)                ; seconds in a day
(define priv:sihd 43200)                ; seconds in a half day
(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'

;; FIXME: should this be something other than misc-error?
(define (priv:time-error caller type value)
  (if value
      (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
      (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))

;; A table of leap seconds
;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
;; and update as necessary.
;; this procedures reads the file in the abover
;; format and creates the leap second table
;; it also calls the almost standard, but not R5 procedures read-line
;; & open-input-string
;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))

(define (priv:read-tai-utc-data filename)
  (define (convert-jd jd)
    (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid))
  (define (convert-sec sec)
    (inexact->exact sec))
  (let ((port (open-input-file filename))
        (table '()))
    (let loop ((line (read-line port)))
      (if (not (eof-object? line))
          (begin
            (let* ((data (read (open-input-string
                                (string-append "(" line ")"))))
                   (year (car data))
                   (jd   (cadddr (cdr data)))
                   (secs (cadddr (cdddr data))))
              (if (>= year 1972)
                  (set! table (cons
                               (cons (convert-jd jd) (convert-sec secs))
                               table)))
              (loop (read-line port))))))
    table))

;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
;; note they go higher to lower, and end in 1972.
(define priv:leap-second-table
  '((1136073600 . 33)
    (915148800 . 32)
    (867715200 . 31)
    (820454400 . 30)
    (773020800 . 29)
    (741484800 . 28)
    (709948800 . 27)
    (662688000 . 26)
    (631152000 . 25)
    (567993600 . 24)
    (489024000 . 23)
    (425865600 . 22)
    (394329600 . 21)
    (362793600 . 20)
    (315532800 . 19)
    (283996800 . 18)
    (252460800 . 17)
    (220924800 . 16)
    (189302400 . 15)
    (157766400 . 14)
    (126230400 . 13)
    (94694400  . 12)
    (78796800  . 11)
    (63072000  . 10)))

(define (read-leap-second-table filename)
  (set! priv:leap-second-table (priv:read-tai-utc-data filename)))

(define (priv:leap-second-delta utc-seconds)
  (letrec ((lsd (lambda (table)
                  (cond ((>= utc-seconds (caar table))
                         (cdar table))
                        (else (lsd (cdr table)))))))
    (if (< utc-seconds  (* (- 1972 1970) 365 priv:sid)) 0
        (lsd  priv:leap-second-table))))

;;; the TIME structure; creates the accessors, too.

(define-record-type time
  (make-time-unnormalized type nanosecond second)
  time?
  (type time-type set-time-type!)
  (nanosecond time-nanosecond set-time-nanosecond!)
  (second time-second set-time-second!))

(define (copy-time time)
  (make-time (time-type time) (time-nanosecond time) (time-second time)))

(define (priv:split-real r)
  (if (integer? r)
      (values (inexact->exact r) 0)
      (let ((l (truncate r)))
        (values (inexact->exact l) (- r l)))))

(define (priv:time-normalize! t)
  (if (>= (abs (time-nanosecond t)) 1000000000)
      (receive (int frac)
	  (priv:split-real (time-nanosecond t))
	(set-time-second! t (+ (time-second t)
			       (quotient int 1000000000)))
	(set-time-nanosecond! t (+ (remainder int 1000000000)
				   frac))))
  (if (and (positive? (time-second t))
           (negative? (time-nanosecond t)))
      (begin
        (set-time-second! t (- (time-second t) 1))
        (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
      (if (and (negative? (time-second t))
               (positive? (time-nanosecond t)))
          (begin
            (set-time-second! t (+ (time-second t) 1))
            (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
  t)

(define (make-time type nanosecond second)
  (priv:time-normalize! (make-time-unnormalized type nanosecond second)))

;; Helpers
;; FIXME: finish this and publish it?
(define (date->broken-down-time date)
  (let ((result (mktime 0)))
    ;; FIXME: What should we do about leap-seconds which may overflow
    ;; set-tm:sec?
    (set-tm:sec result (date-second date))
    (set-tm:min result (date-minute date))
    (set-tm:hour result (date-hour date))
    ;; FIXME: SRFI day ranges from 0-31.  (not compatible with set-tm:mday).
    (set-tm:mday result (date-day date))
    (set-tm:mon result (- (date-month date) 1))
    ;; FIXME: need to signal error on range violation.
    (set-tm:year result (+ 1900 (date-year date)))
    (set-tm:isdst result -1)
    (set-tm:gmtoff result (- (date-zone-offset date)))
    result))

;;; current-time

;;; specific time getters.

(define (priv:current-time-utc)
  ;; Resolution is microseconds.
  (let ((tod (gettimeofday)))
    (make-time time-utc (* (cdr tod) 1000) (car tod))))

(define (priv:current-time-tai)
  ;; Resolution is microseconds.
  (let* ((tod (gettimeofday))
         (sec (car tod))
         (usec (cdr tod)))
    (make-time time-tai
               (* usec 1000)
               (+ (car tod) (priv:leap-second-delta sec)))))

;;(define (priv:current-time-ms-time time-type proc)
;;  (let ((current-ms (proc)))
;;    (make-time time-type
;;               (quotient current-ms 10000)
;;       (* (remainder current-ms 1000) 10000))))

;; -- we define it to be the same as TAI.
;;    A different implemation of current-time-montonic
;;    will require rewriting all of the time-monotonic converters,
;;    of course.

(define (priv:current-time-monotonic)
  ;; Resolution is microseconds.
  (priv:current-time-tai))

(define (priv:current-time-thread)
  (priv:time-error 'current-time 'unsupported-clock-type 'time-thread))

(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))

(define (priv:current-time-process)
  (let ((run-time (get-internal-run-time)))
    (make-time
     time-process
     (* (remainder run-time internal-time-units-per-second)
        priv:ns-per-guile-tick)
     (quotient run-time internal-time-units-per-second))))

;;(define (priv:current-time-gc)
;;  (priv:current-time-ms-time time-gc current-gc-milliseconds))

(define (current-time . clock-type)
  (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
    (cond
     ((eq? clock-type time-tai) (priv:current-time-tai))
     ((eq? clock-type time-utc) (priv:current-time-utc))
     ((eq? clock-type time-monotonic) (priv:current-time-monotonic))
     ((eq? clock-type time-thread) (priv:current-time-thread))
     ((eq? clock-type time-process) (priv:current-time-process))
     ;;     ((eq? clock-type time-gc) (priv:current-time-gc))
     (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))

;; -- Time Resolution
;; This is the resolution of the clock in nanoseconds.
;; This will be implementation specific.

(define (time-resolution . clock-type)
  (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
    (case clock-type
      ((time-tai) 1000)
      ((time-utc) 1000)
      ((time-monotonic) 1000)
      ((time-process) priv:ns-per-guile-tick)
      ;;     ((eq? clock-type time-thread) 1000)
      ;;     ((eq? clock-type time-gc) 10000)
      (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type)))))

;; -- Time comparisons

(define (time=? t1 t2)
  ;; Arrange tests for speed and presume that t1 and t2 are actually times.
  ;; also presume it will be rare to check two times of different types.
  (and (= (time-second t1) (time-second t2))
       (= (time-nanosecond t1) (time-nanosecond t2))
       (eq? (time-type t1) (time-type t2))))

(define (time>? t1 t2)
  (or (> (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (> (time-nanosecond t1) (time-nanosecond t2)))))

(define (time<? t1 t2)
  (or (< (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (< (time-nanosecond t1) (time-nanosecond t2)))))

(define (time>=? t1 t2)
  (or (> (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (>= (time-nanosecond t1) (time-nanosecond t2)))))

(define (time<=? t1 t2)
  (or (< (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (<= (time-nanosecond t1) (time-nanosecond t2)))))

;; -- Time arithmetic

(define (time-difference! time1 time2)
  (let ((sec-diff (- (time-second time1) (time-second time2)))
        (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
    (set-time-type! time1 time-duration)
    (set-time-second! time1 sec-diff)
    (set-time-nanosecond! time1 nsec-diff)
    (priv:time-normalize! time1)))

(define (time-difference time1 time2)
  (let ((result (copy-time time1)))
    (time-difference! result time2)))

(define (add-duration! t duration)
  (if (not (eq? (time-type duration) time-duration))
      (priv:time-error 'add-duration 'not-duration duration)
      (let ((sec-plus (+ (time-second t) (time-second duration)))
            (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
        (set-time-second! t sec-plus)
        (set-time-nanosecond! t nsec-plus)
        (priv:time-normalize! t))))

(define (add-duration t duration)
  (let ((result (copy-time t)))
    (add-duration! result duration)))

(define (subtract-duration! t duration)
  (if (not (eq? (time-type duration) time-duration))
      (priv:time-error 'add-duration 'not-duration duration)
      (let ((sec-minus  (- (time-second t) (time-second duration)))
            (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
        (set-time-second! t sec-minus)
        (set-time-nanosecond! t nsec-minus)
        (priv:time-normalize! t))))

(define (subtract-duration time1 duration)
  (let ((result (copy-time time1)))
    (subtract-duration! result duration)))

;; -- Converters between types.

(define (priv:time-tai->time-utc! time-in time-out caller)
  (if (not (eq? (time-type time-in) time-tai))
      (priv:time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-out time-utc)
  (set-time-nanosecond! time-out (time-nanosecond time-in))
  (set-time-second!     time-out (- (time-second time-in)
                                    (priv:leap-second-delta
                                     (time-second time-in))))
  time-out)

(define (time-tai->time-utc time-in)
  (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))

(define (time-tai->time-utc! time-in)
  (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))

(define (priv:time-utc->time-tai! time-in time-out caller)
  (if (not (eq? (time-type time-in) time-utc))
      (priv:time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-out time-tai)
  (set-time-nanosecond! time-out (time-nanosecond time-in))
  (set-time-second!     time-out (+ (time-second time-in)
                                    (priv:leap-second-delta
                                     (time-second time-in))))
  time-out)

(define (time-utc->time-tai time-in)
  (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))

(define (time-utc->time-tai! time-in)
  (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))

;; -- these depend on time-monotonic having the same definition as time-tai!
(define (time-monotonic->time-utc time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error 'time-monotonic->time-utc
                       'incompatible-time-types time-in))
  (let ((ntime (copy-time time-in)))
    (set-time-type! ntime time-tai)
    (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))

(define (time-monotonic->time-utc! time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error 'time-monotonic->time-utc!
                       'incompatible-time-types time-in))
  (set-time-type! time-in time-tai)
  (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))

(define (time-monotonic->time-tai time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error 'time-monotonic->time-tai
                       'incompatible-time-types time-in))
  (let ((ntime (copy-time time-in)))
    (set-time-type! ntime time-tai)
    ntime))

(define (time-monotonic->time-tai! time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error 'time-monotonic->time-tai!
                       'incompatible-time-types time-in))
  (set-time-type! time-in time-tai)
  time-in)

(define (time-utc->time-monotonic time-in)
  (if (not (eq? (time-type time-in) time-utc))
      (priv:time-error 'time-utc->time-monotonic
                       'incompatible-time-types time-in))
  (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
                                         'time-utc->time-monotonic)))
    (set-time-type! ntime time-monotonic)
    ntime))

(define (time-utc->time-monotonic! time-in)
  (if (not (eq? (time-type time-in) time-utc))
      (priv:time-error 'time-utc->time-monotonic!
                       'incompatible-time-types time-in))
  (let ((ntime (priv:time-utc->time-tai! time-in time-in
                                         'time-utc->time-monotonic!)))
    (set-time-type! ntime time-monotonic)
    ntime))

(define (time-tai->time-monotonic time-in)
  (if (not (eq? (time-type time-in) time-tai))
      (priv:time-error 'time-tai->time-monotonic
                       'incompatible-time-types time-in))
  (let ((ntime (copy-time time-in)))
    (set-time-type! ntime time-monotonic)
    ntime))

(define (time-tai->time-monotonic! time-in)
  (if (not (eq? (time-type time-in) time-tai))
      (priv:time-error 'time-tai->time-monotonic!
                       'incompatible-time-types time-in))
  (set-time-type! time-in time-monotonic)
  time-in)

;; -- Date Structures

;; FIXME: to be really safe, perhaps we should normalize the
;; seconds/nanoseconds/minutes coming in to make-date...

(define-record-type date
  (make-date nanosecond second minute
             hour day month
             year
             zone-offset)
  date?
  (nanosecond date-nanosecond set-date-nanosecond!)
  (second date-second set-date-second!)
  (minute date-minute set-date-minute!)
  (hour date-hour set-date-hour!)
  (day date-day set-date-day!)
  (month date-month set-date-month!)
  (year date-year set-date-year!)
  (zone-offset date-zone-offset set-date-zone-offset!))

;; gives the julian day which starts at noon.
(define (priv:encode-julian-day-number day month year)
  (let* ((a (quotient (- 14 month) 12))
         (y (- (+ year 4800) a (if (negative? year) -1  0)))
         (m (- (+ month (* 12 a)) 3)))
    (+ day
       (quotient (+ (* 153 m) 2) 5)
       (* 365 y)
       (quotient y 4)
       (- (quotient y 100))
       (quotient y 400)
       -32045)))

;; gives the seconds/date/month/year
(define (priv:decode-julian-day-number jdn)
  (let* ((days (inexact->exact (truncate jdn)))
         (a (+ days 32044))
         (b (quotient (+ (* 4 a) 3) 146097))
         (c (- a (quotient (* 146097 b) 4)))
         (d (quotient (+ (* 4 c) 3) 1461))
         (e (- c (quotient (* 1461 d) 4)))
         (m (quotient (+ (* 5 e) 2) 153))
         (y (+ (* 100 b) d -4800 (quotient m 10))))
    (values ; seconds date month year
     (* (- jdn days) priv:sid)
     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
     (+ m 3 (* -12 (quotient m 10)))
     (if (>= 0 y) (- y 1) y))))

;; relies on the fact that we named our time zone accessor
;; differently from MzScheme's....
;; This should be written to be OS specific.

(define (priv:local-tz-offset utc-time)
  ;; SRFI uses seconds West, but guile (and libc) use seconds East.
  (- (tm:gmtoff (localtime (time-second utc-time)))))

;; special thing -- ignores nanos
(define (priv:time->julian-day-number seconds tz-offset)
  (+ (/ (+ seconds tz-offset priv:sihd)
        priv:sid)
     priv:tai-epoch-in-jd))

(define (priv:leap-second? second)
  (and (assoc second priv:leap-second-table) #t))

(define (time-utc->date time . tz-offset)
  (if (not (eq? (time-type time) time-utc))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (let* ((offset (if (null? tz-offset)
		     (priv:local-tz-offset time)
		     (car tz-offset)))
         (leap-second? (priv:leap-second? (+ offset (time-second time))))
         (jdn (priv:time->julian-day-number (if leap-second?
                                                (- (time-second time) 1)
                                                (time-second time))
                                            offset)))

    (call-with-values (lambda () (priv:decode-julian-day-number jdn))
      (lambda (secs date month year)
	;; secs is a real because jdn is a real in Guile;
	;; but it is conceptionally an integer.
        (let* ((int-secs (inexact->exact (round secs)))
               (hours    (quotient int-secs (* 60 60)))
               (rem      (remainder int-secs (* 60 60)))
               (minutes  (quotient rem 60))
               (seconds  (remainder rem 60)))
          (make-date (time-nanosecond time)
                     (if leap-second? (+ seconds 1) seconds)
                     minutes
                     hours
                     date
                     month
                     year
                     offset))))))

(define (time-tai->date time  . tz-offset)
  (if (not (eq? (time-type time) time-tai))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (let* ((offset (if (null? tz-offset)
		     (priv:local-tz-offset (time-tai->time-utc time))
		     (car tz-offset)))
         (seconds (- (time-second time)
                     (priv:leap-second-delta (time-second time))))
         (leap-second? (priv:leap-second? (+ offset seconds)))
         (jdn (priv:time->julian-day-number (if leap-second?
                                                (- seconds 1)
                                                seconds)
                                            offset)))
    (call-with-values (lambda () (priv:decode-julian-day-number jdn))
      (lambda (secs date month year)
	;; secs is a real because jdn is a real in Guile;
	;; but it is conceptionally an integer.
        ;; adjust for leap seconds if necessary ...
        (let* ((int-secs (inexact->exact (round secs)))
	       (hours    (quotient int-secs (* 60 60)))
               (rem      (remainder int-secs (* 60 60)))
               (minutes  (quotient rem 60))
               (seconds  (remainder rem 60)))
          (make-date (time-nanosecond time)
                     (if leap-second? (+ seconds 1) seconds)
                     minutes
                     hours
                     date
                     month
                     year
                     offset))))))

;; this is the same as time-tai->date.
(define (time-monotonic->date time . tz-offset)
  (if (not (eq? (time-type time) time-monotonic))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (let* ((offset (if (null? tz-offset)
		     (priv:local-tz-offset (time-monotonic->time-utc time))
		     (car tz-offset)))
         (seconds (- (time-second time)
                     (priv:leap-second-delta (time-second time))))
         (leap-second? (priv:leap-second? (+ offset seconds)))
         (jdn (priv:time->julian-day-number (if leap-second?
                                                (- seconds 1)
                                                seconds)
                                            offset)))
    (call-with-values (lambda () (priv:decode-julian-day-number jdn))
      (lambda (secs date month year)
	;; secs is a real because jdn is a real in Guile;
	;; but it is conceptionally an integer.
        ;; adjust for leap seconds if necessary ...
        (let* ((int-secs (inexact->exact (round secs)))
	       (hours    (quotient int-secs (* 60 60)))
               (rem      (remainder int-secs (* 60 60)))
               (minutes  (quotient rem 60))
               (seconds  (remainder rem 60)))
          (make-date (time-nanosecond time)
                     (if leap-second? (+ seconds 1) seconds)
                     minutes
                     hours
                     date
                     month
                     year
                     offset))))))

(define (date->time-utc date)
  (let* ((jdays (- (priv:encode-julian-day-number (date-day date)
                                                 (date-month date)
                                                 (date-year date))
		   priv:tai-epoch-in-jd))
	 ;; jdays is an integer plus 1/2,
	 (jdays-1/2 (inexact->exact (- jdays 1/2))))
    (make-time
     time-utc
     (date-nanosecond date)
     (+ (* jdays-1/2 24 60 60)
        (* (date-hour date) 60 60)
        (* (date-minute date) 60)
        (date-second date)
	(- (date-zone-offset date))))))

(define (date->time-tai date)
  (time-utc->time-tai! (date->time-utc date)))

(define (date->time-monotonic date)
  (time-utc->time-monotonic! (date->time-utc date)))

(define (priv:leap-year? year)
  (or (= (modulo year 400) 0)
      (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))

;; Map 1-based month number M to number of days in the year before the
;; start of month M (in a non-leap year).
(define priv:month-assoc '((1 . 0)   (2 . 31)   (3 . 59)   (4 . 90)
			   (5 . 120) (6 . 151)  (7 . 181)  (8 . 212)
			   (9 . 243) (10 . 273) (11 . 304) (12 . 334)))

(define (priv:year-day day month year)
  (let ((days-pr (assoc month priv:month-assoc)))
    (if (not days-pr)
        (priv:time-error 'date-year-day 'invalid-month-specification month))
    (if (and (priv:leap-year? year) (> month 2))
        (+ day (cdr days-pr) 1)
        (+ day (cdr days-pr)))))

(define (date-year-day date)
  (priv:year-day (date-day date) (date-month date) (date-year date)))

;; from calendar faq
(define (priv:week-day day month year)
  (let* ((a (quotient (- 14 month) 12))
         (y (- year a))
         (m (+ month (* 12 a) -2)))
    (modulo (+ day
               y
               (quotient y 4)
               (- (quotient y 100))
               (quotient y 400)
               (quotient (* 31 m) 12))
            7)))

(define (date-week-day date)
  (priv:week-day (date-day date) (date-month date) (date-year date)))

(define (priv:days-before-first-week date day-of-week-starting-week)
  (let* ((first-day (make-date 0 0 0 0
                               1
                               1
                               (date-year date)
                               #f))
         (fdweek-day (date-week-day first-day)))
    (modulo (- day-of-week-starting-week fdweek-day)
            7)))

;; The "-1" here is a fix for the reference implementation, to make a new
;; week start on the given day-of-week-starting-week.  date-year-day returns
;; a day starting from 1 for 1st Jan.
;;
(define (date-week-number date day-of-week-starting-week)
  (quotient (- (date-year-day date)
	       1
               (priv:days-before-first-week  date day-of-week-starting-week))
            7))

(define (current-date . tz-offset)
  (let ((time (current-time time-utc)))
    (time-utc->date
     time
     (if (null? tz-offset)
	 (priv:local-tz-offset time)
	 (car tz-offset)))))

;; given a 'two digit' number, find the year within 50 years +/-
(define (priv:natural-year n)
  (let* ((current-year (date-year (current-date)))
         (current-century (* (quotient current-year 100) 100)))
    (cond
     ((>= n 100) n)
     ((<  n 0) n)
     ((<=  (- (+ current-century n) current-year) 50) (+ current-century n))
     (else (+ (- current-century 100) n)))))

(define (date->julian-day date)
  (let ((nanosecond (date-nanosecond date))
        (second (date-second date))
        (minute (date-minute date))
        (hour (date-hour date))
        (day (date-day date))
        (month (date-month date))
        (year (date-year date))
        (offset (date-zone-offset date)))
    (+ (priv:encode-julian-day-number day month year)
       (- 1/2)
       (+ (/ (+ (- offset)
                (* hour 60 60)
                (* minute 60)
                second
                (/ nanosecond priv:nano))
             priv:sid)))))

(define (date->modified-julian-day date)
  (- (date->julian-day date)
     4800001/2))

(define (time-utc->julian-day time)
  (if (not (eq? (time-type time) time-utc))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano))
        priv:sid)
     priv:tai-epoch-in-jd))

(define (time-utc->modified-julian-day time)
  (- (time-utc->julian-day time)
     4800001/2))

(define (time-tai->julian-day time)
  (if (not (eq? (time-type time) time-tai))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (+ (/ (+ (- (time-second time)
              (priv:leap-second-delta (time-second time)))
           (/ (time-nanosecond time) priv:nano))
        priv:sid)
     priv:tai-epoch-in-jd))

(define (time-tai->modified-julian-day time)
  (- (time-tai->julian-day time)
     4800001/2))

;; this is the same as time-tai->julian-day
(define (time-monotonic->julian-day time)
  (if (not (eq? (time-type time) time-monotonic))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (+ (/ (+ (- (time-second time)
              (priv:leap-second-delta (time-second time)))
           (/ (time-nanosecond time) priv:nano))
        priv:sid)
     priv:tai-epoch-in-jd))

(define (time-monotonic->modified-julian-day time)
  (- (time-monotonic->julian-day time)
     4800001/2))

(define (julian-day->time-utc jdn)
  (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
    (receive (seconds parts)
	(priv:split-real secs)
      (make-time time-utc
		 (* parts priv:nano)
		 seconds))))

(define (julian-day->time-tai jdn)
  (time-utc->time-tai! (julian-day->time-utc jdn)))

(define (julian-day->time-monotonic jdn)
  (time-utc->time-monotonic! (julian-day->time-utc jdn)))

(define (julian-day->date jdn . tz-offset)
  (let* ((time (julian-day->time-utc jdn))
	 (offset (if (null? tz-offset)
		     (priv:local-tz-offset time)
		     (car tz-offset))))
    (time-utc->date time offset)))

(define (modified-julian-day->date jdn . tz-offset)
  (apply julian-day->date (+ jdn 4800001/2)
	 tz-offset))

(define (modified-julian-day->time-utc jdn)
  (julian-day->time-utc (+ jdn 4800001/2)))

(define (modified-julian-day->time-tai jdn)
  (julian-day->time-tai (+ jdn 4800001/2)))

(define (modified-julian-day->time-monotonic jdn)
  (julian-day->time-monotonic (+ jdn 4800001/2)))

(define (current-julian-day)
  (time-utc->julian-day (current-time time-utc)))

(define (current-modified-julian-day)
  (time-utc->modified-julian-day (current-time time-utc)))

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

(define (priv:padding n pad-with length)
  (let* ((str (number->string n))
         (str-len (string-length str)))
    (if (or (>= str-len length)
            (not pad-with))
        str
        (string-append (make-string (- length str-len) pad-with) str))))

(define (priv:last-n-digits i n)
  (abs (remainder i (expt 10 n))))

(define (priv:locale-abbr-weekday n) (locale-day-short (+ 1 n)))
(define (priv:locale-long-weekday n) (locale-day (+ 1 n)))
(define priv:locale-abbr-month       locale-month-short)
(define priv:locale-long-month       locale-month)

(define (priv:date-reverse-lookup needle haystack-ref haystack-len
                                  same?)
  ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure
  ;; that returns a string corresponding to the given index) by passing it
  ;; indices lower than HAYSTACK-LEN.
  (let loop ((index 1))
    (cond ((> index haystack-len) #f)
          ((same? needle (haystack-ref index))
           index)
          (else (loop (+ index 1))))))

(define (priv:locale-abbr-weekday->index string)
  (priv:date-reverse-lookup string locale-day-short 7 string=?))

(define (priv:locale-long-weekday->index string)
  (priv:date-reverse-lookup string locale-day 7 string=?))

(define (priv:locale-abbr-month->index string)
  (priv:date-reverse-lookup string priv:locale-abbr-month  12 string=?))

(define (priv:locale-long-month->index string)
  (priv:date-reverse-lookup string priv:locale-long-month  12 string=?))

;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
;; Print it here instead of the numerical offset if available.
(define (priv:locale-print-time-zone date port)
  (priv:tz-printer (date-zone-offset date) port))

(define (priv:locale-am/pm hr)
  (if (> hr 11) (priv:locale-pm) (priv:locale-am)))

(define (priv:tz-printer offset port)
  (cond
   ((= offset 0) (display "Z" port))
   ((negative? offset) (display "-" port))
   (else (display "+" port)))
  (if (not (= offset 0))
      (let ((hours   (abs (quotient offset (* 60 60))))
            (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
        (display (priv:padding hours #\0 2) port)
        (display (priv:padding minutes #\0 2) port))))

;; A table of output formatting directives.
;; the first time is the format char.
;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port.
;;
(define priv:directives
  (list
   (cons #\~ (lambda (date pad-with port)
               (display #\~ port)))
   (cons #\a (lambda (date pad-with port)
               (display (priv:locale-abbr-weekday (date-week-day date))
                        port)))
   (cons #\A (lambda (date pad-with port)
               (display (priv:locale-long-weekday (date-week-day date))
                        port)))
   (cons #\b (lambda (date pad-with port)
               (display (priv:locale-abbr-month (date-month date))
                        port)))
   (cons #\B (lambda (date pad-with port)
               (display (priv:locale-long-month (date-month date))
                        port)))
   (cons #\c (lambda (date pad-with port)
               (display (date->string date priv:locale-date-time-format) port)))
   (cons #\d (lambda (date pad-with port)
               (display (priv:padding (date-day date)
                                      #\0 2)
                        port)))
   (cons #\D (lambda (date pad-with port)
               (display (date->string date "~m/~d/~y") port)))
   (cons #\e (lambda (date pad-with port)
               (display (priv:padding (date-day date)
                                      #\Space 2)
                        port)))
   (cons #\f (lambda (date pad-with port)
               (if (> (date-nanosecond date)
                      priv:nano)
                   (display (priv:padding (+ (date-second date) 1)
                                          pad-with 2)
                            port)
                   (display (priv:padding (date-second date)
                                          pad-with 2)
                            port))
               (receive (i f)
                        (priv:split-real (/
                                          (date-nanosecond date)
                                          priv:nano 1.0))
                        (let* ((ns (number->string f))
                               (le (string-length ns)))
                          (if (> le 2)
                              (begin
                                (display (priv:locale-number-separator) port)
                                (display (substring ns 2 le) port)))))))
   (cons #\h (lambda (date pad-with port)
               (display (date->string date "~b") port)))
   (cons #\H (lambda (date pad-with port)
               (display (priv:padding (date-hour date)
                                      pad-with 2)
                        port)))
   (cons #\I (lambda (date pad-with port)
               (let ((hr (date-hour date)))
                 (if (> hr 12)
                     (display (priv:padding (- hr 12)
                                            pad-with 2)
                              port)
                     (display (priv:padding hr
                                            pad-with 2)
                              port)))))
   (cons #\j (lambda (date pad-with port)
               (display (priv:padding (date-year-day date)
                                      pad-with 3)
                        port)))
   (cons #\k (lambda (date pad-with port)
               (display (priv:padding (date-hour date)
                                      #\Space 2)
                        port)))
   (cons #\l (lambda (date pad-with port)
               (let ((hr (if (> (date-hour date) 12)
                             (- (date-hour date) 12) (date-hour date))))
                 (display (priv:padding hr  #\Space 2)
                          port))))
   (cons #\m (lambda (date pad-with port)
               (display (priv:padding (date-month date)
                                      pad-with 2)
                        port)))
   (cons #\M (lambda (date pad-with port)
               (display (priv:padding (date-minute date)
                                      pad-with 2)
                        port)))
   (cons #\n (lambda (date pad-with port)
               (newline port)))
   (cons #\N (lambda (date pad-with port)
               (display (priv:padding (date-nanosecond date)
                                      pad-with 7)
                        port)))
   (cons #\p (lambda (date pad-with port)
               (display (priv:locale-am/pm (date-hour date)) port)))
   (cons #\r (lambda (date pad-with port)
               (display (date->string date "~I:~M:~S ~p") port)))
   (cons #\s (lambda (date pad-with port)
               (display (time-second (date->time-utc date)) port)))
   (cons #\S (lambda (date pad-with port)
               (if (> (date-nanosecond date)
                      priv:nano)
                   (display (priv:padding (+ (date-second date) 1)
                                          pad-with 2)
                            port)
                   (display (priv:padding (date-second date)
                                          pad-with 2)
                            port))))
   (cons #\t (lambda (date pad-with port)
               (display #\Tab port)))
   (cons #\T (lambda (date pad-with port)
               (display (date->string date "~H:~M:~S") port)))
   (cons #\U (lambda (date pad-with port)
               (if (> (priv:days-before-first-week date 0) 0)
                   (display (priv:padding (+ (date-week-number date 0) 1)
                                          #\0 2) port)
                   (display (priv:padding (date-week-number date 0)
                                          #\0 2) port))))
   (cons #\V (lambda (date pad-with port)
               (display (priv:padding (date-week-number date 1)
                                      #\0 2) port)))
   (cons #\w (lambda (date pad-with port)
               (display (date-week-day date) port)))
   (cons #\x (lambda (date pad-with port)
               (display (date->string date priv:locale-short-date-format) port)))
   (cons #\X (lambda (date pad-with port)
               (display (date->string date priv:locale-time-format) port)))
   (cons #\W (lambda (date pad-with port)
               (if (> (priv:days-before-first-week date 1) 0)
                   (display (priv:padding (+ (date-week-number date 1) 1)
                                          #\0 2) port)
                   (display (priv:padding (date-week-number date 1)
                                          #\0 2) port))))
   (cons #\y (lambda (date pad-with port)
               (display (priv:padding (priv:last-n-digits
                                       (date-year date) 2)
                                      pad-with
                                      2)
                        port)))
   (cons #\Y (lambda (date pad-with port)
               (display (date-year date) port)))
   (cons #\z (lambda (date pad-with port)
               (priv:tz-printer (date-zone-offset date) port)))
   (cons #\Z (lambda (date pad-with port)
               (priv:locale-print-time-zone date port)))
   (cons #\1 (lambda (date pad-with port)
               (display (date->string date "~Y-~m-~d") port)))
   (cons #\2 (lambda (date pad-with port)
               (display (date->string date "~k:~M:~S~z") port)))
   (cons #\3 (lambda (date pad-with port)
               (display (date->string date "~k:~M:~S") port)))
   (cons #\4 (lambda (date pad-with port)
               (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
   (cons #\5 (lambda (date pad-with port)
               (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))

(define (priv:get-formatter char)
  (let ((associated (assoc char priv:directives)))
    (if associated (cdr associated) #f)))

(define (priv:date-printer date index format-string str-len port)
  (if (< index str-len)
      (let ((current-char (string-ref format-string index)))
        (if (not (char=? current-char #\~))
            (begin
              (display current-char port)
              (priv:date-printer date (+ index 1) format-string str-len port))
            (if (= (+ index 1) str-len) ; bad format string.
                (priv:time-error 'priv:date-printer 'bad-date-format-string
                                 format-string)
                (let ((pad-char? (string-ref format-string (+ index 1))))
                  (cond
                   ((char=? pad-char? #\-)
                    (if (= (+ index 2) str-len) ; bad format string.
                        (priv:time-error 'priv:date-printer
                                         'bad-date-format-string
                                         format-string)
                        (let ((formatter (priv:get-formatter
                                          (string-ref format-string
                                                      (+ index 2)))))
                          (if (not formatter)
                              (priv:time-error 'priv:date-printer
                                               'bad-date-format-string
                                               format-string)
                              (begin
                                (formatter date #f port)
                                (priv:date-printer date
                                                   (+ index 3)
                                                   format-string
                                                   str-len
                                                   port))))))

                   ((char=? pad-char? #\_)
                    (if (= (+ index 2) str-len) ; bad format string.
                        (priv:time-error 'priv:date-printer
                                         'bad-date-format-string
                                         format-string)
                        (let ((formatter (priv:get-formatter
                                          (string-ref format-string
                                                      (+ index 2)))))
                          (if (not formatter)
                              (priv:time-error 'priv:date-printer
                                               'bad-date-format-string
                                               format-string)
                              (begin
                                (formatter date #\Space port)
                                (priv:date-printer date
                                                   (+ index 3)
                                                   format-string
                                                   str-len
                                                   port))))))
                   (else
                    (let ((formatter (priv:get-formatter
                                      (string-ref format-string
                                                  (+ index 1)))))
                      (if (not formatter)
                          (priv:time-error 'priv:date-printer
                                           'bad-date-format-string
                                           format-string)
                          (begin
                            (formatter date #\0 port)
                            (priv:date-printer date
                                               (+ index 2)
                                               format-string
                                               str-len
                                               port))))))))))))

(define (date->string date .  format-string)
  (let ((str-port (open-output-string))
        (fmt-str (if (null? format-string) "~c" (car format-string))))
    (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
    (get-output-string str-port)))

(define (priv:char->int ch)
  (case ch
   ((#\0) 0)
   ((#\1) 1)
   ((#\2) 2)
   ((#\3) 3)
   ((#\4) 4)
   ((#\5) 5)
   ((#\6) 6)
   ((#\7) 7)
   ((#\8) 8)
   ((#\9) 9)
   (else (priv:time-error 'priv:char->int 'bad-date-template-string
                          (list "Non-integer character" ch)))))

;; read an integer upto n characters long on port; upto -> #f is any length
(define (priv:integer-reader upto port)
  (let loop ((accum 0) (nchars 0))
    (let ((ch (peek-char port)))
      (if (or (eof-object? ch)
              (not (char-numeric? ch))
              (and upto (>= nchars  upto)))
          accum
          (loop (+ (* accum 10) (priv:char->int (read-char port)))
                (+ nchars 1))))))

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

;; read *exactly* n characters and convert to integer; could be padded
(define (priv:integer-reader-exact n port)
  (let ((padding-ok #t))
    (define (accum-int port accum nchars)
      (let ((ch (peek-char port)))
	(cond
	 ((>= nchars n) accum)
	 ((eof-object? ch)
	  (priv:time-error 'string->date 'bad-date-template-string
                           "Premature ending to integer read."))
	 ((char-numeric? ch)
	  (set! padding-ok #f)
	  (accum-int port
                     (+ (* accum 10) (priv:char->int (read-char port)))
		     (+ nchars 1)))
	 (padding-ok
	  (read-char port) ; consume padding
	  (accum-int port accum (+ nchars 1)))
	 (else ; padding where it shouldn't be
	  (priv:time-error 'string->date 'bad-date-template-string
                           "Non-numeric characters in integer read.")))))
    (accum-int port 0 0)))

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

(define (priv:zone-reader port)
  (let ((offset 0)
        (positive? #f))
    (let ((ch (read-char port)))
      (if (eof-object? ch)
          (priv:time-error 'string->date 'bad-date-template-string
                           (list "Invalid time zone +/-" ch)))
      (if (or (char=? ch #\Z) (char=? ch #\z))
          0
          (begin
            (cond
             ((char=? ch #\+) (set! positive? #t))
             ((char=? ch #\-) (set! positive? #f))
             (else
              (priv:time-error 'string->date 'bad-date-template-string
                               (list "Invalid time zone +/-" ch))))
            (let ((ch (read-char port)))
              (if (eof-object? ch)
                  (priv:time-error 'string->date 'bad-date-template-string
                                   (list "Invalid time zone number" ch)))
              (set! offset (* (priv:char->int ch)
                              10 60 60)))
            (let ((ch (read-char port)))
              (if (eof-object? ch)
                  (priv:time-error 'string->date 'bad-date-template-string
                                   (list "Invalid time zone number" ch)))
              (set! offset (+ offset (* (priv:char->int ch)
                                        60 60))))
            (let ((ch (read-char port)))
              (if (eof-object? ch)
                  (priv:time-error 'string->date 'bad-date-template-string
                                   (list "Invalid time zone number" ch)))
              (set! offset (+ offset (* (priv:char->int ch)
                                        10 60))))
            (let ((ch (read-char port)))
              (if (eof-object? ch)
                  (priv:time-error 'string->date 'bad-date-template-string
                                   (list "Invalid time zone number" ch)))
              (set! offset (+ offset (* (priv:char->int ch)
                                        60))))
            (if positive? offset (- offset)))))))

;; looking at a char, read the char string, run thru indexer, return index
(define (priv:locale-reader port indexer)

  (define (read-char-string result)
    (let ((ch (peek-char port)))
      (if (char-alphabetic? ch)
          (read-char-string (cons (read-char port) result))
          (list->string (reverse! result)))))

  (let* ((str (read-char-string '()))
         (index (indexer str)))
    (if index index (priv:time-error 'string->date
                                     'bad-date-template-string
                                     (list "Invalid string for " indexer)))))

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

(define (priv:make-char-id-reader char)
  (lambda (port)
    (if (char=? char (read-char port))
        char
        (priv:time-error 'string->date
                         'bad-date-template-string
                         "Invalid character match."))))

;; A List of formatted read directives.
;; Each entry is a list.
;; 1. the character directive;
;; a procedure, which takes a character as input & returns
;; 2. #t as soon as a character on the input port is acceptable
;; for input,
;; 3. a port reader procedure that knows how to read the current port
;; for a value. Its one parameter is the port.
;; 4. an optional action procedure, that takes the value (from 3.) and
;; some object (here, always the date) and (probably) side-effects it.
;; If no action is required, as with ~A, this element may be #f.

(define priv:read-directives
  (let ((ireader4 (priv:make-integer-reader 4))
        (ireader2 (priv:make-integer-reader 2))
        (eireader2 (priv:make-integer-exact-reader 2))
        (locale-reader-abbr-weekday (priv:make-locale-reader
                                     priv:locale-abbr-weekday->index))
        (locale-reader-long-weekday (priv:make-locale-reader
                                     priv:locale-long-weekday->index))
        (locale-reader-abbr-month   (priv:make-locale-reader
                                     priv:locale-abbr-month->index))
        (locale-reader-long-month   (priv:make-locale-reader
                                     priv:locale-long-month->index))
        (char-fail (lambda (ch) #t)))

    (list
     (list #\~ char-fail (priv:make-char-id-reader #\~) #f)
     (list #\a char-alphabetic? locale-reader-abbr-weekday #f)
     (list #\A char-alphabetic? locale-reader-long-weekday #f)
     (list #\b char-alphabetic? locale-reader-abbr-month
           (lambda (val object)
             (set-date-month! object val)))
     (list #\B char-alphabetic? locale-reader-long-month
           (lambda (val object)
             (set-date-month! object val)))
     (list #\d char-numeric? ireader2 (lambda (val object)
                                        (set-date-day!
                                         object val)))
     (list #\e char-fail eireader2 (lambda (val object)
                                     (set-date-day! object val)))
     (list #\h char-alphabetic? locale-reader-abbr-month
           (lambda (val object)
             (set-date-month! object val)))
     (list #\H char-numeric? ireader2 (lambda (val object)
                                        (set-date-hour! object val)))
     (list #\k char-fail eireader2 (lambda (val object)
                                     (set-date-hour! object val)))
     (list #\m char-numeric? ireader2 (lambda (val object)
                                        (set-date-month! object val)))
     (list #\M char-numeric? ireader2 (lambda (val object)
                                        (set-date-minute!
                                         object val)))
     (list #\S char-numeric? ireader2 (lambda (val object)
                                        (set-date-second! object val)))
     (list #\y char-fail eireader2
           (lambda (val object)
             (set-date-year! object (priv:natural-year val))))
     (list #\Y char-numeric? ireader4 (lambda (val object)
                                        (set-date-year! object val)))
     (list #\z (lambda (c)
                 (or (char=? c #\Z)
                     (char=? c #\z)
                     (char=? c #\+)
                     (char=? c #\-)))
           priv:zone-reader (lambda (val object)
                              (set-date-zone-offset! object val))))))

(define (priv:string->date date index format-string str-len port template-string)
  (define (skip-until port skipper)
    (let ((ch (peek-char port)))
      (if (eof-object? ch)
          (priv:time-error 'string->date 'bad-date-format-string template-string)
          (if (not (skipper ch))
              (begin (read-char port) (skip-until port skipper))))))
  (if (< index str-len)
      (let ((current-char (string-ref format-string index)))
        (if (not (char=? current-char #\~))
            (let ((port-char (read-char port)))
              (if (or (eof-object? port-char)
                      (not (char=? current-char port-char)))
                  (priv:time-error 'string->date
                                   'bad-date-format-string template-string))
              (priv:string->date date
                                 (+ index 1)
                                 format-string
                                 str-len
                                 port
                                 template-string))
            ;; otherwise, it's an escape, we hope
            (if (> (+ index 1) str-len)
                (priv:time-error 'string->date
                                 'bad-date-format-string template-string)
                (let* ((format-char (string-ref format-string (+ index 1)))
                       (format-info (assoc format-char priv:read-directives)))
                  (if (not format-info)
                      (priv:time-error 'string->date
                                       'bad-date-format-string template-string)
                      (begin
                        (let ((skipper (cadr format-info))
                              (reader  (caddr format-info))
                              (actor   (cadddr format-info)))
                          (skip-until port skipper)
                          (let ((val (reader port)))
                            (if (eof-object? val)
                                (priv:time-error 'string->date
                                                 'bad-date-format-string
                                                 template-string)
                                (if actor (actor val date))))
                          (priv:string->date date
                                             (+ index 2)
                                             format-string
                                             str-len
                                             port
                                             template-string))))))))))

(define (string->date input-string template-string)
  (define (priv:date-ok? date)
    (and (date-nanosecond date)
         (date-second date)
         (date-minute date)
         (date-hour date)
         (date-day date)
         (date-month date)
         (date-year date)
         (date-zone-offset date)))
  (let ((newdate (make-date 0 0 0 0 #f #f #f #f)))
    (priv:string->date newdate
                       0
                       template-string
                       (string-length template-string)
                       (open-input-string input-string)
                       template-string)
    (if (not (date-zone-offset newdate))
	(begin
	  ;; this is necessary to get DST right -- as far as we can
	  ;; get it right (think of the double/missing hour in the
	  ;; night when we are switching between normal time and DST).
	  (set-date-zone-offset! newdate
				 (priv:local-tz-offset
				  (make-time time-utc 0 0)))
	  (set-date-zone-offset! newdate
				 (priv:local-tz-offset
				  (date->time-utc newdate)))))
    (if (priv:date-ok? newdate)
        newdate
        (priv:time-error
         'string->date
         'bad-date-format-string
         (list "Incomplete date read. " newdate template-string)))))

;;; srfi-19.scm ends here


code:
;;; srfi-2.scm --- and-let*

;; 	Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:

;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-2)
  :use-module (ice-9 and-let-star)
  :re-export-syntax (and-let*))

(cond-expand-provide (current-module) '(srfi-2))

;;; srfi-2.scm ends here

license: mit


code:
;;; srfi-26.scm --- specializing parameters without currying.

;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (srfi srfi-26)
  :export (cut cute))

(cond-expand-provide (current-module) '(srfi-26))

(define-macro (cut slot . slots)
  (let loop ((slots	(cons slot slots))
	     (params	'())
	     (args	'()))
    (if (null? slots)
	`(lambda ,(reverse! params) ,(reverse! args))
      (let ((s	  (car slots))
	    (rest (cdr slots)))
	(case s
	  ((<>)
	   (let ((var (gensym)))
	     (loop rest (cons var params) (cons var args))))
	  ((<...>)
	   (if (pair? rest)
	       (error "<...> not on the end of cut expression"))
	   (let ((var (gensym)))
	     `(lambda ,(append! (reverse! params) var)
		(apply ,@(reverse! (cons var args))))))
	  (else
	   (loop rest params (cons s args))))))))

(define-macro (cute . slots)
  (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
		   slots)))
    `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
       (cut ,@(map (lambda (t s) (or t s)) temp slots)))))


code:
;;; srfi-31.scm --- special form for recursive evaluation

;; 	Copyright (C) 2004, 2006 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Original author: Rob Browning <rlb@defaultvalue.org>

(define-module (srfi srfi-31)
  :export-syntax (rec))

(define-macro (rec arg-form . body)
  (cond
   ((and (symbol? arg-form) (= 1 (length body)))
    ;; (rec S (cons 1 (delay S)))
    `(letrec ((,arg-form ,(car body)))
       ,arg-form))
   ;; (rec (f x) (+ x 1))
   ((list? arg-form)
    `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
       ,(car arg-form)))
   (else
    (error "syntax error in rec form" `(rec ,arg-form ,@body)))))


code:
;;; srfi-34.scm --- Exception handling for programs

;; Copyright (C) 2003, 2006, 2008, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Neil Jerram <neil@ossau.uklinux.net>

;;; Commentary:

;; This is an implementation of SRFI-34: Exception Handling for
;; Programs.  For documentation please see the SRFI-34 document; this
;; module is not yet documented at all in the Guile manual.

;;; Code:

(define-module (srfi srfi-34)
  #:export (with-exception-handler)
  #:replace (raise)
  #:export-syntax (guard))

(cond-expand-provide (current-module) '(srfi-34))

(define throw-key 'srfi-34)

(define (with-exception-handler handler thunk)
  "Returns the result(s) of invoking THUNK. HANDLER must be a
procedure that accepts one argument.  It is installed as the current
exception handler for the dynamic extent (as determined by
dynamic-wind) of the invocation of THUNK."
  (with-throw-handler throw-key
	      thunk
	      (lambda (key obj)
		(handler obj))))

(define (raise obj)
  "Invokes the current exception handler on OBJ.  The handler is
called in the dynamic environment of the call to raise, except that
the current exception handler is that in place for the call to
with-exception-handler that installed the handler being called.  The
handler's continuation is otherwise unspecified."
  (throw throw-key obj))

(define-macro (guard var+clauses . body)
  "Syntax: (guard (<var> <clause1> <clause2> ...) <body>)
Each <clause> should have the same form as a `cond' clause.

Semantics: Evaluating a guard form evaluates <body> with an exception
handler that binds the raised object to <var> and within the scope of
that binding evaluates the clauses as if they were the clauses of a
cond expression.  That implicit cond expression is evaluated with the
continuation and dynamic environment of the guard expression.  If
every <clause>'s <test> evaluates to false and there is no else
clause, then raise is re-invoked on the raised object within the
dynamic environment of the original call to raise except that the
current exception handler is that of the guard expression."
  (let ((var (car var+clauses))
	(clauses (cdr var+clauses)))
    `(catch ',throw-key
	    (lambda ()
	      ,@body)
	    (lambda (key ,var)
	      (cond ,@(if (eq? (caar (last-pair clauses)) 'else)
			  clauses
			  (append clauses
				  `((else (throw key ,var))))))))))

;;; (srfi srfi-34) ends here.


code:
;;; srfi-35.scm --- Conditions                 -*- coding: utf-8 -*-

;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Ludovic Courtès <ludo@gnu.org>

;;; Commentary:

;; This is an implementation of SRFI-35, "Conditions".  Conditions are a
;; means to convey information about exceptional conditions between parts of
;; a program.

;;; Code:

(define-module (srfi srfi-35)
  #:use-module (srfi srfi-1)
  #:export (make-condition-type condition-type?
            make-condition condition? condition-has-type? condition-ref
            make-compound-condition extract-condition
            define-condition-type condition
            &condition
            &message message-condition? condition-message
            &serious serious-condition?
            &error error?))

(cond-expand-provide (current-module) '(srfi-35))

;;;
;;; Condition types.
;;;

(define %condition-type-vtable
  ;; The vtable of all condition types.
  ;;   vtable fields: vtable, self, printer
  ;;   user fields:   id, parent, all-field-names
  (make-vtable-vtable "prprpr" 0
		      (lambda (ct port)
			(if (eq? ct %condition-type-vtable)
			    (display "#<condition-type-vtable>")
			    (format port "#<condition-type ~a ~a>"
				    (condition-type-id ct)
				    (number->string (object-address ct)
						    16))))))

(define (%make-condition-type layout id parent all-fields)
  (let ((struct (make-struct %condition-type-vtable 0
                             (make-struct-layout layout) ;; layout
                             print-condition             ;; printer
                             id parent all-fields)))

    ;; Hack to associate STRUCT with a name, providing a better name for
    ;; GOOPS classes as returned by `class-of' et al.
    (set-struct-vtable-name! struct (cond ((symbol? id) id)
                                          ((string? id) (string->symbol id))
                                          (else         (string->symbol ""))))
    struct))

(define (condition-type? obj)
  "Return true if OBJ is a condition type."
  (and (struct? obj)
       (eq? (struct-vtable obj)
	    %condition-type-vtable)))

(define (condition-type-id ct)
  (and (condition-type? ct)
       (struct-ref ct (+ vtable-offset-user 0))))

(define (condition-type-parent ct)
  (and (condition-type? ct)
       (struct-ref ct (+ vtable-offset-user 1))))

(define (condition-type-all-fields ct)
  (and (condition-type? ct)
       (struct-ref ct (+ vtable-offset-user 2))))

(define (struct-layout-for-condition field-names)
  ;; Return a string denoting the layout required to hold the fields listed
  ;; in FIELD-NAMES.
  (let loop ((field-names field-names)
	     (layout      '("pr")))
    (if (null? field-names)
	(string-concatenate/shared layout)
	(loop (cdr field-names)
	      (cons "pr" layout)))))

(define (print-condition c port)
  ;; Print condition C to PORT in a way similar to how records print:
  ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
  (define (field-values)
    (let* ((type    (struct-vtable c))
           (strings (fold (lambda (field result)
                            (cons (format #f "~A: ~S" field
                                          (condition-ref c field))
                                  result))
                          '()
                          (condition-type-all-fields type))))
      (string-join (reverse strings) " ")))

  (format port "#<condition ~a [~a] ~a>"
          (condition-type-id (condition-type c))
          (field-values)
          (number->string (object-address c) 16)))

(define (make-condition-type id parent field-names)
  "Return a new condition type named ID, inheriting from PARENT, and with the
fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
symbols and must not contain names already used by PARENT or one of its
supertypes."
  (if (symbol? id)
      (if (condition-type? parent)
	  (let ((parent-fields (condition-type-all-fields parent)))
	    (if (and (every symbol? field-names)
		     (null? (lset-intersection eq?
					       field-names parent-fields)))
		(let* ((all-fields (append parent-fields field-names))
		       (layout     (struct-layout-for-condition all-fields)))
		  (%make-condition-type layout
                                        id parent all-fields))
		(error "invalid condition type field names"
		       field-names)))
	  (error "parent is not a condition type" parent))
      (error "condition type identifier is not a symbol" id)))

(define (make-compound-condition-type id parents)
  ;; Return a compound condition type made of the types listed in PARENTS.
  ;; All fields from PARENTS are kept, even same-named ones, since they are
  ;; needed by `extract-condition'.
  (cond ((null? parents)
         (error "`make-compound-condition-type' passed empty parent list"
                id))
        ((null? (cdr parents))
         (car parents))
        (else
         (let* ((all-fields (append-map condition-type-all-fields
                                        parents))
                (layout     (struct-layout-for-condition all-fields)))
           (%make-condition-type layout
                                 id
                                 parents         ;; list of parents!
                                 all-fields)))))

;;;
;;; Conditions.
;;;

(define (condition? c)
  "Return true if C is a condition."
  (and (struct? c)
       (condition-type? (struct-vtable c))))

(define (condition-type c)
  (and (struct? c)
       (let ((vtable (struct-vtable c)))
	 (if (condition-type? vtable)
	     vtable
	     #f))))

(define (condition-has-type? c type)
  "Return true if condition C has type TYPE."
  (if (and (condition? c) (condition-type? type))
      (let loop ((ct (condition-type c)))
        (or (eq? ct type)
            (and ct
                 (let ((parent (condition-type-parent ct)))
                   (if (list? parent)
                       (any loop parent) ;; compound condition
                       (loop (condition-type-parent ct)))))))
      (throw 'wrong-type-arg "condition-has-type?"
             "Wrong type argument")))

(define (condition-ref c field-name)
  "Return the value of the field named FIELD-NAME from condition C."
  (if (condition? c)
      (if (symbol? field-name)
	  (let* ((type   (condition-type c))
		 (fields (condition-type-all-fields type))
		 (index  (list-index (lambda (name)
				       (eq? name field-name))
				     fields)))
	    (if index
		(struct-ref c index)
		(error "invalid field name" field-name)))
	  (error "field name is not a symbol" field-name))
      (throw 'wrong-type-arg "condition-ref"
             "Wrong type argument: ~S" c)))

(define (make-condition-from-values type values)
  (apply make-struct type 0 values))

(define (make-condition type . field+value)
  "Return a new condition of type TYPE with fields initialized as specified
by FIELD+VALUE, a sequence of field names (symbols) and values."
  (if (condition-type? type)
      (let* ((all-fields (condition-type-all-fields type))
	     (inits      (fold-right (lambda (field inits)
				       (let ((v (memq field field+value)))
					 (if (pair? v)
					     (cons (cadr v) inits)
					     (error "field not specified"
						    field))))
				     '()
				     all-fields)))
	(make-condition-from-values type inits))
      (throw 'wrong-type-arg "make-condition"
             "Wrong type argument: ~S" type)))

(define (make-compound-condition . conditions)
  "Return a new compound condition composed of CONDITIONS."
  (let* ((types  (map condition-type conditions))
	 (ct     (make-compound-condition-type 'compound types))
	 (inits  (append-map (lambda (c)
			       (let ((ct (condition-type c)))
				 (map (lambda (f)
					(condition-ref c f))
				      (condition-type-all-fields ct))))
			     conditions)))
    (make-condition-from-values ct inits)))

(define (extract-condition c type)
  "Return a condition of condition type TYPE with the field values specified
by C."

  (define (first-field-index parents)
    ;; Return the index of the first field of TYPE within C.
    (let loop ((parents parents)
	       (index   0))
      (let ((parent (car parents)))
	(cond ((null? parents)
	       #f)
	      ((eq? parent type)
	       index)
	      ((pair? parent)
	       (or (loop parent index)
		   (loop (cdr parents)
			 (+ index
			    (apply + (map condition-type-all-fields
					  parent))))))
	      (else
	       (let ((shift (length (condition-type-all-fields parent))))
		 (loop (cdr parents)
		       (+ index shift))))))))

  (define (list-fields start-index field-names)
    ;; Return a list of the form `(FIELD-NAME VALUE...)'.
    (let loop ((index       start-index)
	       (field-names field-names)
	       (result      '()))
      (if (null? field-names)
	  (reverse! result)
	  (loop (+ 1 index)
		(cdr field-names)
		(cons* (struct-ref c index)
		       (car field-names)
		       result)))))

  (if (and (condition? c) (condition-type? type))
      (let* ((ct     (condition-type c))
             (parent (condition-type-parent ct)))
        (cond ((eq? type ct)
               c)
              ((pair? parent)
               ;; C is a compound condition.
               (let ((field-index (first-field-index parent)))
                 ;;(format #t "field-index: ~a ~a~%" field-index
                 ;;        (list-fields field-index
                 ;;                     (condition-type-all-fields type)))
                 (apply make-condition type
                        (list-fields field-index
                                     (condition-type-all-fields type)))))
              (else
               ;; C does not have type TYPE.
               #f)))
      (throw 'wrong-type-arg "extract-condition"
             "Wrong type argument")))

;;;
;;; Syntax.
;;;

(define-syntax define-condition-type
  (syntax-rules ()
    ((_ name parent pred (field-name field-accessor) ...)
     (begin
       (define name
         (make-condition-type 'name parent '(field-name ...)))
       (define (pred c)
         (condition-has-type? c name))
       (define (field-accessor c)
         (condition-ref c 'field-name))
       ...))))

(define-syntax compound-condition
  ;; Create a compound condition using `make-compound-condition-type'.
  (syntax-rules ()
    ((_ (type ...) (field ...))
     (condition ((make-compound-condition-type '%compound `(,type ...))
                 field ...)))))

(define-syntax condition-instantiation
  ;; Build the `(make-condition type ...)' call.
  (syntax-rules ()
    ((_ type (out ...))
     (make-condition type out ...))
    ((_ type (out ...) (field-name field-value) rest ...)
     (condition-instantiation type (out ... 'field-name field-value) rest ...))))

(define-syntax condition
  (syntax-rules ()
    ((_ (type field ...))
     (condition-instantiation type () field ...))
    ((_ (type field ...) ...)
     (compound-condition (type ...) (field ... ...)))))

;;;
;;; Standard condition types.
;;;

(define &condition
  ;; The root condition type.
  (make-struct %condition-type-vtable 0
	       (make-struct-layout "")
	       (lambda (c port)
		 (display "<&condition>"))
	       '&condition #f '() '()))

(define-condition-type &message &condition
  message-condition?
  (message condition-message))

(define-condition-type &serious &condition
  serious-condition?)

(define-condition-type &error &serious
  error?)

;;; srfi-35.scm ends here


code:
;;; srfi-37.scm --- args-fold

;; 	Copyright (C) 2007, 2008 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;
;; To use this module with Guile, use (cdr (program-arguments)) as
;; the ARGS argument to `args-fold'.  Here is a short example:
;;
;;  (args-fold (cdr (program-arguments))
;; 	    (let ((display-and-exit-proc
;; 		   (lambda (msg)
;; 		     (lambda (opt name arg)
;; 		       (display msg) (quit) (values)))))
;; 	      (list (option '(#\v "version") #f #f
;; 			    (display-and-exit-proc "Foo version 42.0\n"))
;; 		    (option '(#\h "help") #f #f
;; 			    (display-and-exit-proc
;; 			     "Usage: foo scheme-file ..."))))
;; 	    (lambda (opt name arg)
;; 	      (error "Unrecognized option `~A'" name))
;; 	    (lambda (op) (load op) (values)))
;;
;;; Code:

;;;; Module definition & exports
(define-module (srfi srfi-37)
  #:use-module (srfi srfi-9)
  #:export (option option-names option-required-arg?
	    option-optional-arg? option-processor
	    args-fold))

(cond-expand-provide (current-module) '(srfi-37))

;;;; args-fold and periphery procedures

;;; An option as answered by `option'.  `names' is a list of
;;; characters and strings, representing associated short-options and
;;; long-options respectively that should use this option's
;;; `processor' in an `args-fold' call.
;;;
;;; `required-arg?' and `optional-arg?' are mutually exclusive
;;; booleans and indicate whether an argument must be or may be
;;; provided.  Besides the obvious, this affects semantics of
;;; short-options, as short-options with a required or optional
;;; argument cannot be followed by other short options in the same
;;; program-arguments string, as they will be interpreted collectively
;;; as the option's argument.
;;;
;;; `processor' is called when this option is encountered.  It should
;;; accept the containing option, the element of `names' (by `equal?')
;;; encountered, the option's argument (or #f if none), and the seeds
;;; as variadic arguments, answering the new seeds as values.
(define-record-type srfi-37:option
  (option names required-arg? optional-arg? processor)
  option?
  (names option-names)
  (required-arg? option-required-arg?)
  (optional-arg? option-optional-arg?)
  (processor option-processor))

(define (error-duplicate-option option-name)
  (scm-error 'program-error "args-fold"
	     "Duplicate option name `~A~A'"
	     (list (if (char? option-name) #\- "--")
		   option-name)
	     #f))

(define (build-options-lookup options)
  "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
to the containing options, signalling an error if a name is
encountered more than once."
  (let ((lookup (make-hash-table (* 2 (length options)))))
    (for-each
     (lambda (opt)
       (for-each (lambda (name)
		   (let ((assoc (hash-create-handle!
				 lookup name #f)))
		     (if (cdr assoc)
			 (error-duplicate-option (car assoc))
			 (set-cdr! assoc opt))))
		 (option-names opt)))
     options)
    lookup))

(define (args-fold args options unrecognized-option-proc
		   operand-proc . seeds)
  "Answer the results of folding SEEDS as multiple values against the
program-arguments in ARGS, as decided by the OPTIONS'
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
  (let ((lookup (build-options-lookup options)))
    ;; I don't like Guile's `error' here
    (define (error msg . args)
      (scm-error 'misc-error "args-fold" msg args #f))

    (define (mutate-seeds! procedure . params)
      (set! seeds (call-with-values
		      (lambda ()
			(apply procedure (append params seeds)))
		    list)))

    ;; Clean up the rest of ARGS, assuming they're all operands.
    (define (rest-operands)
      (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
		args)
      (set! args '()))

    ;; Call OPT's processor with OPT, NAME, an argument to be decided,
    ;; and the seeds.  Depending on OPT's *-arg? specification, get
    ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
    ;; if no argument is allowed, call NO-ARG-PROC thunk.
    (define (invoke-option-processor
	     opt name req-arg-proc opt-arg-proc no-arg-proc)
      (mutate-seeds!
       (option-processor opt) opt name
       (cond ((option-required-arg? opt) (req-arg-proc))
	     ((option-optional-arg? opt) (opt-arg-proc))
	     (else (no-arg-proc) #f))))

    ;; Compute and answer a short option argument, advancing ARGS as
    ;; necessary, for the short option whose character is at POSITION
    ;; in the current ARG.
    (define (short-option-argument position)
      (cond ((< (1+ position) (string-length (car args)))
	     (let ((result (substring (car args) (1+ position))))
	       (set! args (cdr args))
	       result))
	    ((pair? (cdr args))
	     (let ((result (cadr args)))
	       (set! args (cddr args))
	       result))
	    (else #f)))

    ;; Interpret the short-option at index POSITION in (car ARGS),
    ;; followed by the remaining short options in (car ARGS).
    (define (short-option position)
      (if (>= position (string-length (car args)))
          (begin
            (set! args (cdr args))
            (next-arg))
	  (let* ((opt-name (string-ref (car args) position))
		 (option-here (hash-ref lookup opt-name)))
	    (cond ((not option-here)
		   (mutate-seeds! unrecognized-option-proc
				  (option (list opt-name) #f #f
					  unrecognized-option-proc)
				  opt-name #f)
		   (short-option (1+ position)))
		  (else
		   (invoke-option-processor
		    option-here opt-name
		    (lambda ()
		      (or (short-option-argument position)
			  (error "Missing required argument after `-~A'" opt-name)))
		    (lambda ()
		      ;; edge case: -xo -zf or -xo -- where opt-name=#\o
		      ;; GNU getopt_long resolves these like I do
		      (short-option-argument position))
		    (lambda () #f))
		   (if (not (or (option-required-arg? option-here)
				(option-optional-arg? option-here)))
		       (short-option (1+ position))))))))

    ;; Process the long option in (car ARGS).  We make the
    ;; interesting, possibly non-standard assumption that long option
    ;; names might contain #\=, so keep looking for more #\= in (car
    ;; ARGS) until we find a named option in lookup.
    (define (long-option)
      (let ((arg (car args)))
	(let place-=-after ((start-pos 2))
	  (let* ((index (string-index arg #\= start-pos))
		 (opt-name (substring arg 2 (or index (string-length arg))))
		 (option-here (hash-ref lookup opt-name)))
	    (if (not option-here)
		;; look for a later #\=, unless there can't be one
		(if index
		    (place-=-after (1+ index))
		    (mutate-seeds!
		     unrecognized-option-proc
		     (option (list opt-name) #f #f unrecognized-option-proc)
		     opt-name #f))
		(invoke-option-processor
		 option-here opt-name
		 (lambda ()
		   (if index
		       (substring arg (1+ index))
		       (error "Missing required argument after `--~A'" opt-name)))
		 (lambda () (and index (substring arg (1+ index))))
		 (lambda ()
		   (if index
		       (error "Extraneous argument after `--~A'" opt-name))))))))
      (set! args (cdr args)))

    ;; Process the remaining in ARGS.  Basically like calling
    ;; `args-fold', but without having to regenerate `lookup' and the
    ;; funcs above.
    (define (next-arg)
      (if (null? args)
	  (apply values seeds)
	  (let ((arg (car args)))
	    (cond ((or (not (char=? #\- (string-ref arg 0)))
		       (= 1 (string-length arg))) ;"-"
		   (mutate-seeds! operand-proc arg)
		   (set! args (cdr args)))
		  ((char=? #\- (string-ref arg 1))
		   (if (= 2 (string-length arg)) ;"--"
		       (begin (set! args (cdr args)) (rest-operands))
		       (long-option)))
		  (else (short-option 1)))
	    (next-arg))))

    (next-arg)))

;;; srfi-37.scm ends here


code:
;;; srfi-39.scm --- Parameter objects

;; 	Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
;;; Date: 2004-05-05

;;; Commentary:

;; This is an implementation of SRFI-39 (Parameter objects).
;;
;; The implementation is based on Guile's fluid objects, and is, therefore,
;; thread-safe (parameters are thread-local).
;;
;; In addition to the forms defined in SRFI-39 (`make-parameter',
;; `parameterize'), a new procedure `with-parameters*' is provided.
;; This procedures is analogous to `with-fluids*' but taking as first
;; argument a list of parameter objects instead of a list of fluids.
;;

;;; Code:

(define-module (srfi srfi-39)
  #:use-module (srfi srfi-16)

  #:export (make-parameter)
  #:export-syntax (parameterize)

  ;; helper procedure not in srfi-39.
  #:export (with-parameters*)
  #:replace (current-input-port current-output-port current-error-port))

;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
;;
(cond-expand-provide (current-module) '(srfi-39))

(define make-parameter
  (case-lambda
    ((val) (make-parameter/helper val (lambda (x) x)))
    ((val conv) (make-parameter/helper val conv))))

(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value
(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value

(define (make-parameter/helper val conv)
  (let ((value (make-fluid))
        (conv conv))
    (begin
      (fluid-set! value (conv val))
      (lambda new-value
        (cond
         ((null? new-value) (fluid-ref value))
         ((eq? (car new-value) get-fluid-tag) value)
         ((eq? (car new-value) get-conv-tag) conv)
         ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
         (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))

(define-syntax parameterize
  (syntax-rules ()
    ((_ ((?param ?value) ...) ?body ...)
     (with-parameters* (list ?param ...)
                       (list ?value ...)
                       (lambda () ?body ...)))))

(define (current-input-port . new-value)
  (if (null? new-value)
      ((@ (guile) current-input-port))
      (apply set-current-input-port new-value)))

(define (current-output-port . new-value)
  (if (null? new-value)
      ((@ (guile) current-output-port))
      (apply set-current-output-port new-value)))

(define (current-error-port . new-value)
  (if (null? new-value)
      ((@ (guile) current-error-port))
      (apply set-current-error-port new-value)))

(define port-list
  (list current-input-port current-output-port current-error-port))

;; There are no fluids behind current-input-port etc, so those parameter
;; objects are picked out of the list and handled separately with a
;; dynamic-wind to swap their values to and from a location (the "value"
;; variable in the swapper procedure "let").
;;
;; current-input-port etc are already per-dynamic-root, so this arrangement
;; works the same as a fluid.  Perhaps they could become fluids for ease of
;; implementation here.
;;
;; Notice the use of a param local variable for the swapper procedure.  It
;; ensures any application changes to the PARAMS list won't affect the
;; winding.
;;
(define (with-parameters* params values thunk)
  (let more ((params params)
	     (values values)
	     (fluids '())     ;; fluids from each of PARAMS
	     (convs  '())     ;; VALUES with conversion proc applied
	     (swapper noop))  ;; wind/unwind procedure for ports handling
    (if (null? params)
	(if (eq? noop swapper)
	    (with-fluids* fluids convs thunk)
	    (dynamic-wind
		swapper
		(lambda ()
		  (with-fluids* fluids convs thunk))
		swapper))
	(if (memq (car params) port-list)
	    (more (cdr params) (cdr values)
		  fluids convs
		  (let ((param (car params))
			(value (car values))
			(prev-swapper swapper))
		    (lambda ()
		      (set! value (param value))
		      (prev-swapper))))
	    (more (cdr params) (cdr values)
		  (cons ((car params) get-fluid-tag) fluids)
		  (cons (((car params) get-conv-tag) (car values)) convs)
		  swapper)))))


code:
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes

;; 	Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>

;;; Commentary:

;; This module exports the homogeneous numeric vector procedures as
;; defined in SRFI-4.  They are fully documented in the Guile
;; Reference Manual.

;;; Code:

(define-module (srfi srfi-4)
  #:use-module (rnrs bytevectors)
  #:export (;; Unsigned 8-bit vectors.
            u8vector? make-u8vector u8vector u8vector-length u8vector-ref
            u8vector-set! u8vector->list list->u8vector

            ;; Signed 8-bit vectors.
            s8vector? make-s8vector s8vector s8vector-length s8vector-ref
            s8vector-set! s8vector->list list->s8vector

            ;; Unsigned 16-bit vectors.
            u16vector? make-u16vector u16vector u16vector-length u16vector-ref
            u16vector-set! u16vector->list list->u16vector

            ;; Signed 16-bit vectors.
            s16vector? make-s16vector s16vector s16vector-length s16vector-ref
            s16vector-set! s16vector->list list->s16vector

            ;; Unsigned 32-bit vectors.
            u32vector? make-u32vector u32vector u32vector-length u32vector-ref
            u32vector-set! u32vector->list list->u32vector

            ;; Signed 32-bit vectors.
            s32vector? make-s32vector s32vector s32vector-length s32vector-ref
            s32vector-set! s32vector->list list->s32vector

            ;; Unsigned 64-bit vectors.
            u64vector? make-u64vector u64vector u64vector-length u64vector-ref
            u64vector-set! u64vector->list list->u64vector

            ;; Signed 64-bit vectors.
            s64vector? make-s64vector s64vector s64vector-length s64vector-ref
            s64vector-set! s64vector->list list->s64vector

            ;; 32-bit floating point vectors.
            f32vector? make-f32vector f32vector f32vector-length f32vector-ref
            f32vector-set! f32vector->list list->f32vector

            ;; 64-bit floating point vectors.
            f64vector? make-f64vector f64vector f64vector-length f64vector-ref
            f64vector-set! f64vector->list list->f64vector))

;; Need quasisyntax to do this effectively using syntax-case
(define-macro (define-bytevector-type tag infix size)
  `(begin
     (define (,(symbol-append tag 'vector?) obj)
       (and (uniform-vector? obj)
            (eq? (uniform-vector-element-type obj) ',tag)))
     (define (,(symbol-append 'make- tag 'vector) len . fill)
       (apply make-srfi-4-vector ',tag len fill))
     (define (,(symbol-append tag 'vector-length) v)
       (let ((len (* (uniform-vector-length v)
                     (/ ,size (uniform-vector-element-size v)))))
         (if (integer? len)
             len
             (error "fractional length" v ',tag ,size))))
     (define (,(symbol-append tag 'vector) . elts)
       (,(symbol-append 'list-> tag 'vector) elts))
     (define (,(symbol-append 'list-> tag 'vector) elts)
       (let* ((len (length elts))
              (v (,(symbol-append 'make- tag 'vector) len)))
         (let lp ((i 0) (elts elts))
           (if (and (< i len) (pair? elts))
               (begin
                 (,(symbol-append tag 'vector-set!) v i (car elts))
                 (lp (1+ i) (cdr elts)))
               v))))
     (define (,(symbol-append tag 'vector->list) v)
       (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
         (if (< i 0)
             elts
             (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
     (define (,(symbol-append tag 'vector-ref) v i)
       (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
     (define (,(symbol-append tag 'vector-set!) v i x)
       (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
     (define (,(symbol-append tag 'vector-set!) v i x)
       (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))

(define-bytevector-type u8 u8 1)
(define-bytevector-type s8 s8 1)
(define-bytevector-type u16 u16-native 2)
(define-bytevector-type s16 s16-native 2)
(define-bytevector-type u32 u32-native 4)
(define-bytevector-type s32 s32-native 4)
(define-bytevector-type u64 u64-native 8)
(define-bytevector-type s64 s64-native 8)
(define-bytevector-type f32 ieee-single-native 4)
(define-bytevector-type f64 ieee-double-native 8)

(define (bytevector-c32-ref v i)
  (make-rectangular (bytevector-ieee-single-native-ref v i)
                    (bytevector-ieee-single-native-ref v (+ i 4))))
(define (bytevector-c32-set! v i x)
  (bytevector-ieee-single-native-set! v i x)
  (bytevector-ieee-single-native-set! v (+ i 4) x))
(define-bytevector-type c32 c32 8)

(define (bytevector-c64-ref v i)
  (make-rectangular (bytevector-ieee-double-native-ref v i)
                    (bytevector-ieee-double-native-ref v (+ i 8))))
(define (bytevector-c64-set! v i x)
  (bytevector-ieee-double-native-set! v i x)
  (bytevector-ieee-double-native-set! v (+ i 8) x))
(define-bytevector-type c64 c64 16)