code:
/* srfi-13.c --- old place of SRFI-13 procedures for Guile
 *
 * Copyright (C) 2001, 2004, 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 2.1 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
 */

/* This file is now empty since all its procedures are now in the
   core.  We keep the libguile-srfi-srfi-13.so library around anyway
   since people might still be linking with it.
*/

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <srfi/srfi-13.h>

void scm_init_srfi_13_no_clash_with_libguile (void);
void scm_init_srfi_13_14_no_clash_with_libguile (void);

void
scm_init_srfi_13_no_clash_with_libguile (void)
{
}

void
scm_init_srfi_13_14_no_clash_with_libguile (void)
{
}


code:
#ifndef SCM_SRFI_13_H
#define SCM_SRFI_13_H

/* SRFI-13 procedures for Guile
 *
 * 	Copyright (C) 2001, 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 2.1 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
 */

/* All SRFI-13 procedures are in in the core now. */

#include <libguile.h>

/* SCM_SRFI1314_API is a macro prepended to all function and data definitions
   which should be exported or imported in the resulting dynamic link
   library in the Win32 port. */

#if defined (SCM_SRFI1314_IMPORT)
# define SCM_SRFI1314_API __declspec (dllimport) extern
#elif defined (SCM_SRFI1314_EXPORT) || defined (DLL_EXPORT)
# define SCM_SRFI1314_API __declspec (dllexport) extern
#else
# define SCM_SRFI1314_API extern
#endif

SCM_SRFI1314_API void scm_init_srfi_13 (void);
SCM_SRFI1314_API void scm_init_srfi_13_14 (void);

/* The following functions have new names in the core.
 */

#define scm_string_to_listS    scm_substring_to_list
#define scm_string_copyS       scm_substring_copy
#define scm_substring_sharedS  scm_substring_shared
#define scm_string_fill_xS     scm_substring_fill_x
#define scm_string_indexS      scm_string_index
#define scm_string_upcase_xS   scm_substring_upcase_x
#define scm_string_upcaseS     scm_substring_upcase
#define scm_string_downcase_xS scm_substring_downcase_x
#define scm_string_downcaseS   scm_substring_downcase

#endif /* SCM_SRFI_13_H */

license: unknown


code:
;;; srfi-13.scm --- String Library

;; 	Copyright (C) 2001, 2002, 2003, 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 2.1 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.
;;
;; All procedures are in the core and are simply reexported here.

;;; Code:

(define-module (srfi srfi-13))

(re-export
;;; Predicates
 string?
 string-null?
 string-any
 string-every

;;; Constructors
 make-string
 string
 string-tabulate

;;; List/string conversion
 string->list
 list->string
 reverse-list->string
 string-join

;;; Selection
 string-length
 string-ref
 string-copy
 substring/shared
 string-copy!
 string-take string-take-right
 string-drop string-drop-right
 string-pad string-pad-right
 string-trim string-trim-right
 string-trim-both

;;; Modification
 string-set!
 string-fill!

;;; Comparison
 string-compare
 string-compare-ci
 string= string<>
 string< string>
 string<= string>=
 string-ci= string-ci<>
 string-ci< string-ci>
 string-ci<= string-ci>=
 string-hash string-hash-ci

;;; Prefixes/Suffixes
 string-prefix-length
 string-prefix-length-ci
 string-suffix-length
 string-suffix-length-ci
 string-prefix?
 string-prefix-ci?
 string-suffix?
 string-suffix-ci?

;;; Searching
 string-index
 string-index-right
 string-skip string-skip-right
 string-count
 string-contains string-contains-ci

;;; Alphabetic case mapping
 string-upcase
 string-upcase!
 string-downcase
 string-downcase!
 string-titlecase
 string-titlecase!

;;; Reverse/Append
 string-reverse
 string-reverse!
 string-append
 string-append/shared
 string-concatenate
 string-concatenate-reverse
 string-concatenate/shared
 string-concatenate-reverse/shared

;;; Fold/Unfold/Map
 string-map string-map!
 string-fold
 string-fold-right
 string-unfold
 string-unfold-right
 string-for-each
 string-for-each-index

;;; Replicate/Rotate
 xsubstring
 string-xcopy!

;;; Miscellaneous
 string-replace
 string-tokenize

;;; Filtering/Deleting
 string-filter
 string-delete)

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

;;; srfi-13.scm ends here


code:
/* srfi-14.c --- Old place of SRFI-14 procedures for Guile
 *
 * Copyright (C) 2001, 2004, 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 2.1 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
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <srfi/srfi-14.h>

void scm_init_srfi_14_no_clash_with_libguile (void);
void scm_c_init_srfi_14_no_clash_with_libguile (void);

void
scm_init_srfi_14_no_clash_with_libguile (void)
{
}

void
scm_c_init_srfi_14_no_clash_with_libguile (void)
{
}


code:
#ifndef SCM_SRFI_14_H
#define SCM_SRFI_14_H
/* srfi-14.c --- SRFI-14 procedures for Guile
 *
 * 	Copyright (C) 2001, 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 2.1 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
 */

/* SCM_SRFI1314_API is a macro prepended to all function and data definitions
   which should be exported or imported in the resulting dynamic link
   library in the Win32 port. */

#if defined (SCM_SRFI1314_IMPORT)
# define SCM_SRFI1314_API __declspec (dllimport) extern
#elif defined (SCM_SRFI1314_EXPORT) || defined (DLL_EXPORT)
# define SCM_SRFI1314_API __declspec (dllexport) extern
#else
# define SCM_SRFI1314_API extern
#endif

SCM_SRFI1314_API void scm_c_init_srfi_14 (void);
SCM_SRFI1314_API void scm_init_srfi_14 (void);

#endif /* SCM_SRFI_14_H */


code:
;;; srfi-14.scm --- Character-set Library

;; 	Copyright (C) 2001, 2002, 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 2.1 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-14))

(re-export
;;; General procedures
 char-set?
 char-set=
 char-set<=
 char-set-hash

;;; Iterating over character sets
 char-set-cursor
 char-set-ref
 char-set-cursor-next
 end-of-char-set?
 char-set-fold
 char-set-unfold char-set-unfold!
 char-set-for-each
 char-set-map

;;; Creating character sets
 char-set-copy
 char-set
 list->char-set list->char-set!
 string->char-set string->char-set!
 char-set-filter char-set-filter!
 ucs-range->char-set ucs-range->char-set!
 ->char-set

;;; Querying character sets
 char-set-size
 char-set-count
 char-set->list
 char-set->string
 char-set-contains?
 char-set-every
 char-set-any

;;; Character set algebra
 char-set-adjoin char-set-adjoin!
 char-set-delete char-set-delete!
 char-set-complement
 char-set-union
 char-set-intersection
 char-set-difference
 char-set-xor
 char-set-diff+intersection
 char-set-complement!
 char-set-union!
 char-set-intersection!
 char-set-difference!
 char-set-xor!
 char-set-diff+intersection!

;;; Standard character sets
 char-set:lower-case
 char-set:upper-case
 char-set:title-case
 char-set:letter
 char-set:digit
 char-set:letter+digit
 char-set:graphic
 char-set:printing
 char-set:whitespace
 char-set:iso-control
 char-set:punctuation
 char-set:symbol
 char-set:hex-digit
 char-set:blank
 char-set:ascii
 char-set:empty
 char-set:full)

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

;;; srfi-14.scm ends here


code:
;;; srfi-16.scm --- case-lambda

;; 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 2.1 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

;;; Commentary:

;; Implementation of SRFI-16.  `case-lambda' is a syntactic form
;; which permits writing functions acting different according to the
;; number of arguments passed.
;;
;; The syntax of the `case-lambda' form is defined in the following
;; EBNF grammar.
;;
;; <case-lambda>
;;    --> (case-lambda <case-lambda-clause>)
;; <case-lambda-clause>
;;    --> (<signature> <definition-or-command>*)
;; <signature>
;;    --> (<identifier>*)
;;      | (<identifier>* . <identifier>)
;;      | <identifier>
;;
;; The value returned by a `case-lambda' form is a procedure which
;; matches the number of actual arguments against the signatures in
;; the various clauses, in order.  The first matching clause is
;; selected, the corresponding values from the actual parameter list
;; are bound to the variable names in the clauses and the body of the
;; clause is evaluated.

;;; Code:

(define-module (srfi srfi-16)
  :export-syntax (case-lambda))

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

(define-macro (case-lambda . clauses)

  ;; Return the length of the list @var{l}, but allow dotted list.
  ;;
  (define (alength l)
    (cond ((null? l) 0)
	  ((pair? l) (+ 1 (alength (cdr l))))
	  (else 0)))

  ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is
  ;; a normal list.
  ;;
  (define (dotted? l)
    (cond ((null? l) #f)
	  ((pair? l) (dotted? (cdr l)))
	  (else #t)))

  ;; Return the expression for accessing the @var{index}th element of
  ;; the list called @var{args-name}.  If @var{tail?} is true, code
  ;; for accessing the list-tail is generated, otherwise for accessing
  ;; the list element itself.
  ;;
  (define (accessor args-name index tail?)
    (if tail?
	(case index
	  ((0) `,args-name)
	  ((1) `(cdr ,args-name))
	  ((2) `(cddr ,args-name))
	  ((3) `(cdddr ,args-name))
	  ((4) `(cddddr ,args-name))
	  (else `(list-tail ,args-name ,index)))
	(case index
	  ((0) `(car ,args-name))
	  ((1) `(cadr ,args-name))
	  ((2) `(caddr ,args-name))
	  ((3) `(cadddr ,args-name))
	  (else `(list-ref ,args-name ,index)))))

  ;; Generate the binding lists of the variables of one case-lambda
  ;; clause.  @var{vars} is the (possibly dotted) list of variables
  ;; and @var{args-name} is the generated name used for the argument
  ;; list.
  ;;
  (define (gen-temps vars args-name)
    (let lp ((v vars) (i 0))
      (cond ((null? v) '())
	    ((pair? v)
	     (cons `(,(car v) ,(accessor args-name i #f))
		   (lp (cdr v) (+ i 1))))
	    (else `((,v ,(accessor args-name i #t)))))))

  ;; Generate the cond clauses for each of the clauses of case-lambda,
  ;; including the parameter count check, binding of the parameters
  ;; and the code of the corresponding body.
  ;;
  (define (gen-clauses l length-name args-name)
    (cond ((null? l) (list '(else (error "too few arguments"))))
	  (else
	   (cons
	    `((,(if (dotted? (caar l)) '>= '=)
	       ,length-name ,(alength (caar l)))
	      (let ,(gen-temps (caar l) args-name)
	      ,@(cdar l)))
	    (gen-clauses (cdr l) length-name args-name)))))

  (let ((args-name (gensym))
	(length-name (gensym)))
    (let ((proc
	   `(lambda ,args-name
	      (let ((,length-name (length ,args-name)))
		(cond ,@(gen-clauses clauses length-name args-name))))))
      proc)))

;;; srfi-16.scm ends here


code:
;;; srfi-17.scm --- Generalized set!

;; Copyright (C) 2001, 2002, 2003, 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 2.1 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: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>

;;; Commentary:

;; This is an implementation of SRFI-17: Generalized set!
;;
;; It exports the Guile procedure `make-procedure-with-setter' under
;; the SRFI name `getter-with-setter' and exports the standard
;; procedures `car', `cdr', ..., `cdddr', `string-ref' and
;; `vector-ref' as procedures with setters, as required by the SRFI.
;;
;; SRFI-17 was heavily criticized during its discussion period but it
;; was finalized anyway.  One issue was its concept of globally
;; associating setter "properties" with (procedure) values, which is
;; non-Schemy.  For this reason, this implementation chooses not to
;; provide a way to set the setter of a procedure.  In fact, (set!
;; (setter PROC) SETTER) signals an error.  The only way to attach a
;; setter to a procedure is to create a new object (a "procedure with
;; setter") via the `getter-with-setter' procedure. This procedure is
;; also specified in the SRFI.  Using it avoids the described
;; problems.
;;
;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-17)
  :export (getter-with-setter)
  :replace (;; redefined standard procedures
	    setter
	    car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
	    cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
	    caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
	    cdddar cddddr string-ref vector-ref))

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

;;; Procedures

(define getter-with-setter make-procedure-with-setter)

(define setter
  (getter-with-setter
   (@ (guile) setter)
   (lambda args
     (error "Setting setters is not supported for a good reason."))))

;;; Redefine R5RS procedures to appropriate procedures with setters

(define (compose-setter setter location)
  (lambda (obj value)
    (setter (location obj) value)))

(define car
  (getter-with-setter (@ (guile) car)
                      set-car!))
(define cdr
  (getter-with-setter (@ (guile) cdr)
                      set-cdr!))

(define caar
  (getter-with-setter (@ (guile) caar)
                      (compose-setter set-car! (@ (guile) car))))
(define cadr
  (getter-with-setter (@ (guile) cadr)
                      (compose-setter set-car! (@ (guile) cdr))))
(define cdar
  (getter-with-setter (@ (guile) cdar)
                      (compose-setter set-cdr! (@ (guile) car))))
(define cddr
  (getter-with-setter (@ (guile) cddr)
                      (compose-setter set-cdr! (@ (guile) cdr))))

(define caaar
  (getter-with-setter (@ (guile) caaar)
                      (compose-setter set-car! (@ (guile) caar))))
(define caadr
  (getter-with-setter (@ (guile) caadr)
                      (compose-setter set-car! (@ (guile) cadr))))
(define cadar
  (getter-with-setter (@ (guile) cadar)
                      (compose-setter set-car! (@ (guile) cdar))))
(define caddr
  (getter-with-setter (@ (guile) caddr)
                      (compose-setter set-car! (@ (guile) cddr))))
(define cdaar
  (getter-with-setter (@ (guile) cdaar)
                      (compose-setter set-cdr! (@ (guile) caar))))
(define cdadr
  (getter-with-setter (@ (guile) cdadr)
                      (compose-setter set-cdr! (@ (guile) cadr))))
(define cddar
  (getter-with-setter (@ (guile) cddar)
                      (compose-setter set-cdr! (@ (guile) cdar))))
(define cdddr
  (getter-with-setter (@ (guile) cdddr)
                      (compose-setter set-cdr! (@ (guile) cddr))))

(define caaaar
  (getter-with-setter (@ (guile) caaaar)
                      (compose-setter set-car! (@ (guile) caaar))))
(define caaadr
  (getter-with-setter (@ (guile) caaadr)
                      (compose-setter set-car! (@ (guile) caadr))))
(define caadar
  (getter-with-setter (@ (guile) caadar)
                      (compose-setter set-car! (@ (guile) cadar))))
(define caaddr
  (getter-with-setter (@ (guile) caaddr)
                      (compose-setter set-car! (@ (guile) caddr))))
(define cadaar
  (getter-with-setter (@ (guile) cadaar)
                      (compose-setter set-car! (@ (guile) cdaar))))
(define cadadr
  (getter-with-setter (@ (guile) cadadr)
                      (compose-setter set-car! (@ (guile) cdadr))))
(define caddar
  (getter-with-setter (@ (guile) caddar)
                      (compose-setter set-car! (@ (guile) cddar))))
(define cadddr
  (getter-with-setter (@ (guile) cadddr)
                      (compose-setter set-car! (@ (guile) cdddr))))
(define cdaaar
  (getter-with-setter (@ (guile) cdaaar)
                      (compose-setter set-cdr! (@ (guile) caaar))))
(define cdaadr
  (getter-with-setter (@ (guile) cdaadr)
                      (compose-setter set-cdr! (@ (guile) caadr))))
(define cdadar
  (getter-with-setter (@ (guile) cdadar)
                      (compose-setter set-cdr! (@ (guile) cadar))))
(define cdaddr
  (getter-with-setter (@ (guile) cdaddr)
                      (compose-setter set-cdr! (@ (guile) caddr))))
(define cddaar
  (getter-with-setter (@ (guile) cddaar)
                      (compose-setter set-cdr! (@ (guile) cdaar))))
(define cddadr
  (getter-with-setter (@ (guile) cddadr)
                      (compose-setter set-cdr! (@ (guile) cdadr))))
(define cdddar
  (getter-with-setter (@ (guile) cdddar)
                      (compose-setter set-cdr! (@ (guile) cddar))))
(define cddddr
  (getter-with-setter (@ (guile) cddddr)
                      (compose-setter set-cdr! (@ (guile) cdddr))))

(define string-ref
  (getter-with-setter (@ (guile) string-ref)
                      string-set!))

(define vector-ref
  (getter-with-setter (@ (guile) vector-ref)
                      vector-set!))

;;; srfi-17.scm ends here


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

;; 	Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 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 2.1 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))

(begin-deprecated
 ;; Prevent `export' from re-exporting core bindings.  This behaviour
 ;; of `export' is deprecated and will disappear in one of the next
 ;; releases.
 (define current-time #f))

(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
           current-time
           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->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 ".")

(define priv:locale-abbr-weekday-vector
  (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))

(define priv:locale-long-weekday-vector
  (vector
   "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

;; note empty string in 0th place.
(define priv:locale-abbr-month-vector
  (vector ""
          "Jan"
          "Feb"
          "Mar"
          "Apr"
          "May"
          "Jun"
          "Jul"
          "Aug"
          "Sep"
          "Oct"
          "Nov"
          "Dec"))

(define priv:locale-long-month-vector
  (vector ""
          "January"
          "February"
          "March"
          "April"
          "May"
          "June"
          "July"
          "August"
          "September"
          "October"
          "November"
          "December"))

(define priv:locale-pm "PM")
(define priv:locale-am "AM")

;; 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))
  (values))

(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)))))

(define (leap-year? date)
  (priv:leap-year? (date-year date)))

;; 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)
  (vector-ref priv:locale-abbr-weekday-vector n))

(define (priv:locale-long-weekday n)
  (vector-ref priv:locale-long-weekday-vector n))

(define (priv:locale-abbr-month n)
  (vector-ref priv:locale-abbr-month-vector n))

(define (priv:locale-long-month n)
  (vector-ref priv:locale-long-month-vector n))

(define (priv:vector-find needle haystack comparator)
  (let ((len (vector-length haystack)))
    (define (priv:vector-find-int index)
      (cond
       ((>= index len) #f)
       ((comparator needle (vector-ref haystack index)) index)
       (else (priv:vector-find-int (+ index 1)))))
    (priv:vector-find-int 0)))

(define (priv:locale-abbr-weekday->index string)
  (priv:vector-find string priv:locale-abbr-weekday-vector string=?))

(define (priv:locale-long-weekday->index string)
  (priv:vector-find string priv:locale-long-weekday-vector string=?))

(define (priv:locale-abbr-month->index string)
  (priv:vector-find string priv:locale-abbr-month-vector string=?))

(define (priv:locale-long-month->index string)
  (priv:vector-find string priv:locale-long-month-vector 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))

;; FIXME: we should use strftime to determine this dynamically if possible.
;; Again, locale specific.
(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)
      (values)
      (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 '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. a action procedure, that takes the value (from 3.) and some
;; object (here, always the date) and (probably) side-effects it.
;; In some cases (e.g., ~A) the action is to do nothing

(define priv:read-directives
  (let ((ireader4 (priv:make-integer-reader 4))
        (ireader2 (priv:make-integer-reader 2))
        (ireaderf (priv:make-integer-reader #f))
        (eireader2 (priv:make-integer-exact-reader 2))
        (eireader4 (priv:make-integer-exact-reader 4))
        (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))
        (do-nothing (lambda (val object) (values))))

    (list
     (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing)
     (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
     (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
     (list #\b char-alphabetic? locale-reader-abbr-month
           (lambda (val 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)
      (begin
        (values))
      (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)
                                (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 2.1 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


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 2.1 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 2.1 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 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 2.1 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
	    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.