;;;; srfi-19-date.scm  -*- Scheme -*-
;;;; Chicken port, Kon Lovett, Dec '05

;;Issues
;;
;; - use of check-* im or/and forms is problematic

;; SRFI-19: Time Data Types and Procedures.
;;
;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
;;
;; This document and translations of it may be copied and furnished to others,
;; and derivative works that comment on or otherwise explain it or assist in its
;; implementation may be prepared, copied, published and distributed, in whole or
;; in part, without restriction of any kind, provided that the above copyright
;; notice and this paragraph are included on all such copies and derivative works.
;; However, this document itself may not be modified in any way, such as by
;; removing the copyright notice or references to the Scheme Request For
;; Implementation process or editors, except as needed for the purpose of
;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
;; process must be followed, or as required to translate it into languages other
;; than English.
;;
;; The limited permissions granted above are perpetual and will not be revoked
;; by the authors or their successors or assigns.
;;
;; This document and the information contained herein is provided on an "AS IS"
;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.

#| ;Attribution?
We actually count years from May 25th 1875, with the starting value May 25th
1875. That’s when the international dating convention was signed in Paris. It
has later been implemented as a standard, ISO 8601, and goes back to Friday
October 15th 1582, or the start of the Gregorian calendar. We can count years
further back too, but because of the mess of implementing the Gregorian
calendar (the date before Friday October 15th 1582 is Thursday October 4th
1582), that has to be negotiated.
|#

(module srfi-19-date-adjust-support

(;export
  #; ; UNUSED
  date-key-order
  date-adjuster-ref
  date-adjuster-set!)

(import scheme)
(import (chicken base))
(import (chicken type))
#; ; UNUSED
(import (only (srfi 1) list-index))

#; ; UNUSED
(: date-key-order (* --> fixnum))
(: date-adjuster-ref (symbol symbol --> symbol procedure))
(: date-adjuster-set! (symbol (list-of symbol) procedure -> void))

;; Date Adjust Support

(define-syntax alist-update/set!
  (syntax-rules ()
    ;
    ((alist-update/set! ?key ?val ?var)
      (set! ?var (alist-update! ?key ?val ?var eqv?)) )
    ;
    ((alist-update/set! ?key ?val ?var ?tst)
      (set! ?var (alist-update! ?key ?val ?var ?tst)) ) ) )

;empty alists
(define +date-adjust-synonym-map+ '())
(define +date-adjuster-map+ '())
(define +date-key-lexical-order+ '())

#; ; UNUSED
(define (date-key-order x)
  (list-index (cut eq? x <>) +date-key-lexical-order+) )

(define (date-adjust-key? obj)
  (and (alist-ref obj +date-adjust-synonym-map+ eq?)
       #t) )

(define (date-adjuster-ref loc key)
  (let* ((real-key (alist-ref key +date-adjust-synonym-map+ eq? 'UNKNOWN))
         (val (or (alist-ref real-key +date-adjuster-map+ eq?)
                  (error loc "unknown date-adjust key" key))) )
    (values real-key val) ) )

(define (date-adjuster-set! key syns hdlr)
  ;-set! in ascending order
  (set! +date-key-lexical-order+ (cons key +date-key-lexical-order+))
  ;all are key
  (alist-update/set! key key +date-adjust-synonym-map+ eq?)
  (for-each (lambda (syn) (alist-update/set! syn key +date-adjust-synonym-map+ eq?)) syns)
  ;adjuster for key
  (alist-update/set! key hdlr +date-adjuster-map+ eq?) )

;(define date-key? date-adjust-key?)

) ;module srfi-19-date-adjust-support

(module srfi-19-date

(;export
  ;;SRFI-19
  current-date
  current-julian-day
  current-modified-julian-day
  make-date
  date? check-date error-date
  date-nanosecond
  date-second
  date-minute
  date-hour
  date-day
  date-month
  date-year
  date-zone-offset
  leap-day? leap-year? ;not in original document
  date-year-day
  days-in-month/year
  natural-year
  date-week-day
  date-week-number
  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-tai->date
  time-tai->julian-day
  time-tai->modified-julian-day
  time-utc->date
  time-utc->julian-day
  time-utc->modified-julian-day
  ;;Extensions
  seconds->date
  read-leap-second-table
  time->date
  default-date-clock-type
  default-date-adjust-integer
  date-zone-name
  date-dst?
  copy-date date-copy
  date->seconds
  date->time
  date-adjust date-adjust*
  date-difference
  date-add-duration
  date-subtract-duration
  date-hash
  date=?
  date>?
  date<?
  date>=?
  date<=?
  date-max
  date-min
  time->julian-day
  time->modified-julian-day
  date-compare)

(import scheme
  (chicken base)
  (chicken type)
  (chicken keyword)
  (chicken sort)
  (srfi 8)
  (only (srfi 1) reverse!)
  (only locale-components check-timezone-components timezone-components?)
  (only miscmacros define-parameter)
  (only (check-errors sys) check-string check-integer)
  (only type-errors-basic warning-argument-type)
  (only srfi-19-timezone
    timezone-locale-offset timezone-locale-name timezone-locale-dst?
    checked-optional-timezone-info)
  (only srfi-19-support
    make-duration
    error-convert check-clock-type clock-type? check-date-elements check-date error-date
    check-raw-seconds check-date-compatible-timezone-offsets check-duration
    check-time-and-type check-time check-date-year check-date-month
    check-week-day check-julian-day)
  srfi-19-tm
  srfi-19-date-adjust-support)

(include-relative "srfi-19-common.types")

(: current-date (#!optional timezone-info -> date))
(: current-julian-day (-> real))
(: current-modified-julian-day (-> real))

(: make-date (real real real real real real real #!optional fixnum string boolean --> date))
(: date? (* -> boolean : date))
(: check-date (symbol * #!optional (or symbol string) -> date))
(: error-date (symbol * #!optional (or symbol string) -> void))
(: date-nanosecond (date --> fixnum))
(: date-second (date --> fixnum))
(: date-minute (date --> fixnum))
(: date-hour (date --> fixnum))
(: date-day (date --> fixnum))
(: date-month (date --> fixnum))
(: date-year (date --> fixnum))
(: date-zone-offset (date --> fixnum))

(: leap-day? (date --> boolean))
(: leap-year? ((or date fixnum) --> boolean))

(: date-year-day (date --> fixnum))
(: days-in-month/year (fixnum fixnum --> fixnum))
(: natural-year (fixnum #!optional timezone-info --> fixnum))

(: date-week-day (date --> fixnum))
(: date-week-number (date #!optional fixnum --> fixnum))

(: date->julian-day (date --> real))
(: date->modified-julian-day (date --> real))

(: date->time-monotonic (date --> time))
(: date->time-tai (date --> time))
(: date->time-utc (date --> time))

(: julian-day->date (real #!optional timezone-info --> date))
(: julian-day->time-monotonic (real --> time))
(: julian-day->time-tai (real --> time))
(: julian-day->time-utc (real --> time))
(: modified-julian-day->date (real --> date))
(: modified-julian-day->time-monotonic (real --> time))
(: modified-julian-day->time-tai (real --> time))
(: modified-julian-day->time-utc (real --> time))

(: time-monotonic->date (time --> date))
(: time-monotonic->julian-day (time --> real))
(: time-monotonic->modified-julian-day (time --> real))
(: time-tai->date (time --> date))
(: time-tai->julian-day (time --> real))
(: time-tai->modified-julian-day (time --> real))
(: time-utc->date (time --> date))
(: time-utc->julian-day (time --> real))
(: time-utc->modified-julian-day (time --> real))

(: seconds->date (real --> date))
(: read-leap-second-table (string -> void))

(: time->date (time #!optional timezone-info --> date))

(: default-date-clock-type (#!optional clock-type -> clock-type))
(: default-date-adjust-integer (#!optional (integer -> integer) -> (integer -> integer)))

(: date-zone-name (date --> string))
(: date-dst? (date --> boolean))

(: copy-date (date --> date))

(: date->seconds (date #!optional clock-type --> real))
(: date->time (date #!optional clock-type --> time))

(: date-adjust (date integer symbol #!optional clock-type --> date))
(: date-adjust* (date #!rest --> date))

(: date-difference (date date --> time))

(: date-add-duration (date time #!optional clock-type --> date))
(: date-subtract-duration (date time #!optional clock-type --> date))

(: date-hash (date #!optional fixnum --> fixnum))

(: date=? (date date --> boolean))
(: date>? (date date --> boolean))
(: date<? (date date --> boolean))
(: date>=? (date date --> boolean))
(: date<=? (date date --> boolean))

(: date-max (date #!rest (list-of date) --> date))
(: date-min (date #!rest (list-of date) --> date))

(: time->julian-day (time --> real))
(: time->modified-julian-day (time --> real))

(: date-compare (date date --> fixnum))

;;;

;srfi-69
(define-constant HASH-DEFAULT-BOUND 536870912)

;;;

;;

(define (symbol->keyword sym) (string->keyword (symbol->string sym)))
(define (keyword->symbol kwd) (string->symbol (keyword->string kwd)))

(include-relative "srfi-19-common")

;;

(define (checked-tm:time->date loc tim tzi)
  ;Note w/ (or ...) error-convert type dominates
  (let ((dat (tm:time->date tim tzi)))
    (unless dat
      (error-convert loc 'time 'date tim))
    dat ) )

;;

(define (checked-tm:date->time loc dat tt)
  ;Note w/ (or ...) error-convert type dominates
  (let ((tim (tm:date->time dat (check-clock-type loc tt))))
    (unless tim
      (error-convert loc 'date 'time dat))
    tim ) )

;;

(define (read-leap-second-table flnm)
  ;FIXME should be check-pathname
  (tm:read-leap-second-table (check-string 'read-leap-second-table flnm)) )

;;; Date Object (Public Immutable)

;;

(define-syntax date-adjuster-create
  (er-macro-transformer
    (lambda (frm r cmp)
      (let ((_date-adjuster-set! (r 'date-adjuster-set!))
            (_begin (r 'begin)) )
        `(,_begin
          ,@(let loop ((args (cdr frm)) (ls '()))
              ;order is unimportant
              (if (null? args) ls
                  (let ((?key (car args))
                        (?syns (cadr args))
                        (?hdlr (caddr args))
                        (?rest (cdddr args)) )
                    (loop ?rest (cons `(,_date-adjuster-set! ',?key ',?syns ,?hdlr) ls) ) ) ) ) ) ) ) ) )

;;

;FIXME should this be thread-specific? also, should use time-utc & not symbol
(define-parameter default-date-clock-type 'utc
  (lambda (obj)
    (if (clock-type? obj) obj
        (begin
          (warning-argument-type 'default-date-clock-type obj 'clock-type)
          (default-date-clock-type) ) ) ) )

;FIXME this is a hack
(define-parameter default-date-adjust-integer tm:date-adjust-amount->integer
  (lambda (obj)
    (if (procedure? obj) obj
        (begin
          (warning-argument-type 'default-date-adjust-integer obj 'procedure)
          (default-date-adjust-integer) ) ) ) )

;; Date CTOR

;FIXME ugly hack to differentiate valid boolean argument
(define UNIQUE-OBJECT (void))

(define (make-date ns sec min hr dy mn yr . args)
  (let-optionals args ((tzo (timezone-locale-offset))
                       (tzn #f)
                       (dstf UNIQUE-OBJECT) )
    (let ((no-dstf (eq? UNIQUE-OBJECT dstf)))
      (cond ((timezone-components? tzo)
              ;Supplied parameters override
              (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
              (set! tzn (or tzn (timezone-locale-name tzo)))
              (set! tzo (timezone-locale-offset tzo)) )
            (else
              (when no-dstf (set! dstf #f)) ) ) )
    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )

(define (date? obj)
  (tm:date? obj) )

(define (copy-date dat)
  (tm:copy-date (check-date 'copy-date dat)) )

(define date-copy copy-date)

;; Converts a seconds value, may be fractional, into a date type.
;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
;; A local (#t), utc (#f), or other (timezone-components) date depending on
;; the optional 2nd argument. The default is #t.

(define (seconds->date sec . tzi)
  (tm:seconds->date/type
    (check-raw-seconds 'seconds->date sec)
    (check-timezone-components 'seconds->date
      (checked-optional-timezone-info 'seconds->date
        (optional tzi #t)))) )

(define (date->seconds dat #!optional (tt (default-date-clock-type)))
  (tm:time->seconds
    (tm:date->time
      (check-date 'date->seconds dat)
      (check-clock-type 'date->seconds tt))) )

(define (current-date . tzi)
  (tm:current-date
    (checked-optional-timezone-info 'current-date
      (optional tzi #t))) )

;;

(define (date-nanosecond dat)
  (tm:date-nanosecond (check-date 'date-nanosecond dat)) )

(define (date-second dat)
  (tm:date-second (check-date 'date-second dat)) )

(define (date-minute dat)
  (tm:date-minute (check-date 'date-minute dat)) )

(define (date-hour dat)
  (tm:date-hour (check-date 'date-hour dat)) )

(define (date-day dat)
  (tm:date-day (check-date 'date-day dat)) )

(define (date-month dat)
  (tm:date-month (check-date 'date-month dat)) )

(define (date-year dat)
  (tm:date-year (check-date 'date-year dat)) )

(define (date-dst? dat)
  (tm:date-dst? (check-date 'date-dst? dat)) )

(define (date-zone-offset dat)
  (tm:date-zone-offset (check-date 'date-zone-offset dat)) )

(define (date-zone-name dat)
  (tm:date-zone-name (check-date 'date-zone-name dat)) )

;; Date Comparison

(define (checked-date-compare loc dat1 dat2)
  (check-date-compatible-timezone-offsets loc (check-date loc dat1) (check-date loc dat2))
  (tm:date-compare dat1 dat2) )

;;

(define (date-hash dat #!optional (bnd HASH-DEFAULT-BOUND))
  (tm:date-hash (check-date 'date-hash dat) bnd) )

(define (date-compare dat1 dat2)
  (signum (checked-date-compare 'date-compare dat1 dat2)) )

(define (date=? dat1 dat2)
  (zero? (checked-date-compare 'date=? dat1 dat2)) )

(define (date<? dat1 dat2)
  (negative? (checked-date-compare 'date<? dat1 dat2)) )

(define (date<=? dat1 dat2)
  (>= 0 (checked-date-compare 'date<=? dat1 dat2)) )

(define (date>? dat1 dat2)
  (positive? (checked-date-compare 'date>? dat1 dat2)) )

(define (date>=? dat1 dat2)
  (<= 0 (checked-date-compare 'date>=? dat1 dat2)) )

(define (date-max dat1 . rest)
  (foldl
    (lambda (acc dat)
      (check-date-compatible-timezone-offsets 'date-max acc (check-date 'date-max dat))
      (if (positive? (tm:date-compare acc dat)) dat acc) )
    (check-date 'date-max dat1)
    rest) )

(define (date-min dat1 . rest)
  (foldl
    (lambda (acc dat)
      (check-date-compatible-timezone-offsets 'date-min acc (check-date 'date-max dat))
      (if (negative? (tm:date-compare acc dat)) dat acc) )
    (check-date 'date-min dat1)
    rest) )

;; Date Arithmetic

#| UNUSED
(define (date-key-compare a b)
  (if (eq? a b) 0 (- (date-key-order a) (date-key-order b))) )

(define (date-key=? a b) (zero? (date-key-compare a b)))
(define (date-key<? a b) (negative? (date-key-compare a b)))

(define (sort-date-keys keys #!optional (lt date-key<?))
  (sort keys lt) )

(define (date-key-alist<? a b) (date-key<? (car a) (car b)))
|#

(define-inline (kwd->sym kwd) (if (symbol? kwd) kwd (keyword->symbol kwd)))

;date-adjust* date key # ... [tt]
;key = #:year ... #:nanosecond
(define (date-adjust* dat . adjs)
  (let ((tt (default-date-clock-type)))
    (define (process-argument ls)
      (let loop ((ls ls) (rs '()))
        (cond ((null? ls) (reverse! rs))
              ((null? (cdr ls))
                (set! tt (car ls))
                (loop (cdr ls) rs) )
              (else
                (let ((kwd (car ls)) (amt (cadr ls)))
                  (loop (cddr ls) `((,(kwd->sym kwd) . ,amt) . ,rs)) ) ) ) ) )
    (foldl (lambda (d c) (date-adjust d (cdr c) (car c) tt)) dat (process-argument adjs)) ) )

(define (date-adjust dat amt key . args)
  (let-optionals args ((tt (default-date-clock-type)))
    (let-values (((key adjuster) (date-adjuster-ref 'date-adjust key)))
      (adjuster
        (check-date 'date-adjust dat)
        ((default-date-adjust-integer) (check-integer 'date-adjust amt))
        key
        ;only used for duration conversion
        tt) ) ) )

(define (date-difference dat1 dat2 . args)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim1
            (checked-tm:date->time 'date-difference
              (check-date 'date-difference dat1) tt))
          (tim2
            (checked-tm:date->time 'date-difference
              (check-date 'date-difference dat2) tt)) )
      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )

(define (date-add-duration dat dur . args)
  (check-duration 'date-add-duration dur)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim
            (checked-tm:date->time 'date-add-duration
              (check-date 'date-add-duration dat) tt)) )
      (checked-tm:time->date 'date-add-duration
        (tm:add-duration tim dur (tm:as-some-time tim))
        (tm:date-timezone-info dat)) ) ) )

(define (date-subtract-duration dat dur . args)
  (check-duration 'date-subtract-duration dur)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim
            (checked-tm:date->time 'date-subtract-duration
              (check-date 'date-subtract-duration dat) tt)) )
      (checked-tm:time->date 'date-subtract-duration
        (tm:subtract-duration tim dur (tm:as-some-time tim))
        (tm:date-timezone-info dat)) ) ) )

;; Date Adjust Handlers

(define (date-adjuster-years dat amt key tt)
  (let ((yr (+ (tm:date-year dat) amt))
        (ndat (tm:copy-date dat)) )
    (tm:date-year-set! ndat yr)
    ;FIXME leap-year -> non-leap-year handling
    (when (and (not (tm:leap-year? yr))
               (tm:leap-day? (tm:date-day dat) (tm:date-month dat)))
      (tm:date-day-set! ndat (tm:days-in-month (tm:date-month dat) yr)) )
    ndat ) )

(define (date-adjuster-quarters dat amt key tt)
  (date-adjuster-months dat (* 3 amt) 'months tt) )

(define (date-adjuster-months dat amt key tt)
  (if (zero? amt)
      (tm:copy-date dat)
      (let ((ndat (tm:copy-date dat)))
        (let-values (((yrs mns) (quotient&remainder amt 12)))
          (cond ((positive? mns)
                  (when (< 12 (+ (tm:date-month dat) mns))
                    (tm:date-month-set! ndat 1)
                    (set! mns (- mns (- 12 (tm:date-month dat))))
                    (set! yrs (+ 1 yrs)) ) )
                (else ;(negative? amt)
                  (when (> 1 (+ (tm:date-month dat) mns))
                    (tm:date-month-set! ndat 12)
                    (set! mns (+ mns (tm:date-month dat)))
                    (set! yrs (- yrs 1)) ) ) )
          (tm:date-month-set! ndat (+ mns (tm:date-month ndat)))
          (tm:date-year-set! ndat (+ yrs (tm:date-year ndat)))
          (when (< (tm:days-in-month (tm:date-month ndat) (tm:date-year ndat)) (tm:date-day ndat))
            (tm:date-day-set! ndat (tm:days-in-month (tm:date-month ndat) (tm:date-year ndat))) )
          ndat  ) ) ) )

(define (date-adjuster-weeks dat amt key tt)
  (date-adjuster-duration dat (* amt 7) 'days tt) )

(define (date-adjuster-duration dat amt key tt)
  (let ((tim (checked-tm:date->time 'date-adjust-duration dat tt))
        (dur (make-duration (symbol->keyword key) amt)) )
    (checked-tm:time->date 'date-adjust-duration
      (tm:add-duration tim dur (tm:as-some-time tim))
      (tm:date-timezone-info dat)) ) )

;; Time to Date

(define (time-tai->date tim . tzi)
  (check-time-and-type 'time-tai->date tim 'tai)
  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )

(define (time-utc->date tim . tzi)
  (check-time-and-type 'time-utc->date tim 'utc)
  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #f))) )

(define (time-monotonic->date tim . tzi)
  (check-time-and-type 'time-monotonic->date tim 'monotonic)
  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )

(define (time->date tim . tzi)
  (checked-tm:time->date 'time->date
    (check-time 'time->date tim)
    (checked-optional-timezone-info 'time->date (optional tzi #t))) )

;; Date to Time

(define (date->time-utc dat)
  (tm:date->time-utc (check-date 'date->time-utc dat)) )

(define (date->time-tai dat)
  (tm:date->time-tai (check-date 'date->time-tai dat)) )

(define (date->time-monotonic dat)
  (tm:date->time-monotonic (check-date 'date->time-monotonic dat)) )

(define (date->time dat . args)
  (let-optionals args ((tt (default-date-clock-type)))
    (checked-tm:date->time 'date->time (check-date 'date->time dat) tt) ) )

;; Given a 'two digit' number, find the year within 50 years +/-

(define (natural-year n . tzi)
  (tm:natural-year
    (check-date-year 'natural-year n)
    (checked-optional-timezone-info 'natural-year (optional tzi #t))) )

;; Leap Day/Year

(define (leap-day? dat)
  (and (tm:leap-year? (tm:date-year (check-date 'leap-year? dat)))
       (tm:leap-day? (tm:date-day dat) (tm:date-month dat))) )

(define (leap-year? dat)
  (tm:leap-year?
    ;assume a number is a year, otherwise extract
    (if (fixnum? dat)
        dat
        (tm:date-year (check-date 'leap-year? dat)))) )

;; Day of Year

(define (date-year-day dat)
  (tm:date-year-day (check-date 'date-year-day dat)) )

(define (days-in-month/year mn yr)
  (tm:days-in-month (check-date-month 'days-in-month/year mn)
                    (check-date-year 'days-in-month/year yr)) )

;; Week Day

(define (date-week-day dat)
  (tm:date-week-day (check-date 'date-week-day dat)) )

;;

(define (date-week-number dat . args)
  (let-optionals args ((day-of-week-starting-week 0))
    (tm:date-week-number
      (check-date 'date-week-number dat)
      (check-week-day 'date-week-number day-of-week-starting-week)) ) )

;; Julian-day Operations

(define (date->julian-day dat)
  (tm:date->julian-day (check-date 'date->julian-day dat)) )

(define (date->modified-julian-day dat)
  (tm:julian-day->modified-julian-day
    (tm:date->julian-day
      (check-date 'date->modified-julian-day dat))) )

;; Time to Julian-day

(define (time-utc->julian-day tim)
  (check-time-and-type 'time-utc->julian-day tim 'utc)
  (tm:time-utc->julian-day tim) )

(define (time-tai->julian-day tim)
  (check-time-and-type 'time-tai->julian-day tim 'tai)
  (tm:time-tai->julian-day tim) )

(define (time-monotonic->julian-day tim)
  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
  (tm:time-monotonic->julian-day tim) )

(define (time->julian-day tim)
  ;Note w/ (or ...) error-convert type dominates
  (let ((jd (tm:time->julian-day (check-time 'time->julian-day tim))))
    (unless jd
      (error-convert 'time->julian-day 'time 'julian-day tim))
    jd ) )

(define (time-utc->modified-julian-day tim)
  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
  (tm:time-utc->modified-julian-day tim) )

(define (time-tai->modified-julian-day tim)
  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
  (tm:time-tai->modified-julian-day tim) )

(define (time-monotonic->modified-julian-day tim)
  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
  (tm:time-monotonic->modified-julian-day tim) )

(define (time->modified-julian-day tim)
  ;Note w/ (or ...) error-convert type dominates
  (let ((mjd (tm:time->modified-julian-day (check-time 'time->modified-julian-day tim))))
    (unless mjd
      (error-convert 'time->modified-julian-day 'time 'modified-julian-day tim))
    mjd ) )

;; Julian-day to Time

(define (julian-day->time-utc jdn)
  (tm:julian-day->time-utc (check-julian-day 'julian-day->time-utc jdn)) )

(define (julian-day->time-tai jdn)
  (let ((tim (tm:julian-day->time-utc (check-julian-day 'julian-day->time-tai jdn))))
    (tm:time-utc->time-tai tim tim) ) )

(define (julian-day->time-monotonic jdn)
  (let ((tim (julian-day->time-utc (check-julian-day 'julian-day->time-monotonic jdn))))
    (tm:time-utc->time-monotonic tim tim) ) )

(define (julian-day->date jdn . tzi)
  (tm:time-utc->date
    (tm:julian-day->time-utc (check-julian-day 'julian-day->date jdn))
    (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )

(define (modified-julian-day->time-utc mjdn)
  (tm:modified-julian-day->time-utc
    (check-julian-day 'modified-julian-day->time-utc mjdn)) )

(define (modified-julian-day->time-tai mjdn)
  (let ((tim
          (tm:modified-julian-day->time-utc
            (check-julian-day 'modified-julian-day->time-tai mjdn))) )
    (tm:time-utc->time-tai tim tim) ) )

(define (modified-julian-day->time-monotonic mjdn)
  (let ((tim
          (tm:modified-julian-day->time-utc
            (check-julian-day 'modified-julian-day->time-monotonic mjdn))) )
    (tm:time-utc->time-monotonic tim tim) ) )

(define (modified-julian-day->date mjdn . tzi)
  (tm:time-utc->date
    (tm:modified-julian-day->time-utc
      (check-julian-day 'modified-julian-day->date mjdn))
    (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )

;; The Julian-day

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

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

;;; Module Begin

(date-adjuster-create
  years           (year yrs yr y)                  date-adjuster-years
  quarters        (quarter qtrs qtr Q)             date-adjuster-quarters
  months          (month mons mon mns mn M)        date-adjuster-months
  weeks           (week wks wk w)                  date-adjuster-weeks
  days            (day dys dy d)                   date-adjuster-duration
  hours           (hour hrs hr h)                  date-adjuster-duration
  minutes         (minute mins min m)              date-adjuster-duration
  seconds         (second secs sec s)              date-adjuster-duration
  milliseconds    (millisecond millis milli ms)    date-adjuster-duration
  microseconds    (microsecond micros micro us)    date-adjuster-duration
  nanoseconds     (nanosecond nanos nano ns)       date-adjuster-duration)

) ;module srfi-19-date