;;;; srfi-19-support.scm
;;;; Chicken port, Kon Lovett, Dec '05

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

;; Issues
;;
;; - Gregorian calendar only.
;;
;; - Initialization is scattered throughout the code, so converting to a module will
;; involve some search.
;;
;; - Some errors have incorrect procedure labels (not the top-level loc)

;; Bugs
;;
;; - The 'date-dst?' field is problimatic. It is only valid on certain
;; platforms & only when current. A past or future date will not have this
;; field correct!
;;
;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
;; NOT the state of the converted date.

;; Notes
;;
;; - There is no year zero. So when converting from a BCE year on the sign of the year
;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
;;
;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
;; UTC & a subtracted offset is "towards" UTC.
;;
;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
;; conversion procedure.

(module srfi-19-support

  (;export
    ;
    time?
    time-type?
    time-seconds?
    time-nanoseconds?
    clock-type?
    date?
    date-nanoseconds?
    date-seconds?
    date-minutes?
    date-hours?
    date-day?
    date-month?
    date-year?
    week-day?
    julian-day?
    time-record-printer-format
    date-record-printer-format
    ;
    check-time
    check-time-type
    check-time-seconds
    check-time-nanoseconds
    check-raw-seconds
    check-raw-milliseconds
    check-time-has-type
    check-time-and-type
    check-duration
    check-time-elements
    #;check-times
    check-time-binop
    check-time-compare
    check-time-aritmetic
    check-clock-type
    check-date
    check-date-nanoseconds
    check-date-seconds
    check-date-minutes
    check-date-hours
    check-date-day
    check-date-month
    check-date-year
    check-date-elements
    check-date-compatible-timezone-offsets
    check-week-day
    check-julian-day
    ;
    error-time
    error-time-type
    error-time-seconds
    error-time-nanoseconds
    error-incompatible-time-types
    error-clock-type
    error-convert
    error-date
    error-date-nanoseconds
    error-date-seconds
    error-date-minutes
    error-date-hours
    error-date-day
    error-date-month
    error-date-year
    error-date-compatible-timezone
    error-week-day
    error-julian-day
    ;
    tm:read-tai-utc-data
    tm:calc-second-before-leap-second-table
    tm:read-leap-second-table
    (tm:any-time %make-time)
    (tm:some-time %make-time)
    (tm:as-some-time %time-type %make-time)
    (tm:time-type %time-type)
    (tm:time-nanosecond %time-second)
    (tm:time-second %time-nanosecond)
    (tm:time-type-set! %time-type-set!)
    (tm:time-nanosecond-set! %time-nanosecond-set!)
    (tm:time-second-set! %time-second-set!)
    tm:make-time
    (tm:copy-time %make-time)
    (tm:time-has-type? %time-type)
    tm:nanoseconds->time-values
    tm:time->nanoseconds
    tm:time->milliseconds
    tm:nanoseconds->seconds
    tm:milliseconds->seconds
    tm:time->seconds
    tm:duration-elements->time-values
    tm:milliseconds->time-values
    tm:seconds->time-values
    tm:seconds->time
    (tm:current-time-values tm:current-nanoseconds)
    tm:current-time-utc
    (tm:current-time-tai leap-second-delta)
    tm:current-time-monotonic
    (tm:current-time-thread current-thread-milliseconds)
    (tm:current-time-process current-process-milliseconds)
    (tm:current-time-gc current-gc-milliseconds total-gc-milliseconds)
    tm:time-resolution
    tm:time-compare
    tm:time=?
    tm:time<?
    tm:time<=?
    tm:time>?
    tm:time>=?
    tm:time-max
    tm:time-min
    tm:time-difference
    tm:add-duration
    tm:subtract-duration
    tm:divide-duration
    tm:multiply-duration
    tm:time-abs
    tm:time-negate
    tm:time-zero? tm:time-positive? tm:time-negative?
    (tm:time-tai->time-utc leap-second-neg-delta)
    tm:time-tai->time-monotonic
    tm:time-utc->time-tai
    tm:time-utc->time-monotonic
    tm:time-monotonic->time-tai
    tm:time-monotonic->time-utc
    tm:leap-year?
    (tm:leap-day? +leap-year-dys/mn+)
    (tm:days-in-month +leap-year-dys/mn+ +year-dys/mn+)
    (tm:date-nanosecond %date-nanosecond)
    (tm:date-second %date-second)
    (tm:date-minute %date-minute)
    (tm:date-hour %date-hour)
    (tm:date-day %date-day)
    (tm:date-month %date-month)
    (tm:date-year %date-year)
    (tm:date-zone-offset %date-zone-offset)
    (tm:date-zone-name %date-zone-name)
    (tm:date-dst? %date-dst?)
    tm:date-wday
    tm:date-yday
    tm:date-jday
    (tm:date-timezone-info %make-date-timezone-info)
    (tm:date-nanosecond-set! %date-nanosecond-set!)
    (tm:date-second-set! %date-second-set!)
    (tm:date-minute-set! %date-minute-set!)
    (tm:date-hour-set! %date-hour-set!)
    (tm:date-day-set! %date-day-set!)
    (tm:date-month-set! %date-month-set!)
    (tm:date-year-set! %date-year-set!)
    (tm:date-zone-offset-set! %date-zone-offset-set!)
    (tm:make-incomplete-date %make-date)
    (tm:make-date %make-date)
    (tm:copy-date %date-nanosecond %date-second %date-minute %date-hour
      %date-day %date-month %date-year
      %date-zone-offset %date-zone-name
      %date-jday %date-yday %date-wday
      %make-date)
    tm:seconds->date/type
    tm:current-date
    (tm:date-compare %date-nanosecond %date-second %date-minute %date-hour
      %date-day %date-month %date-year)
    tm:decode-julian-day-number
    tm:seconds->julian-day-number
    tm:tai-before-leap-second?
    tm:time-utc->date
    tm:time-tai->date
    tm:time->date
    tm:encode-julian-day-number
    tm:date->time-utc
    tm:date->time-tai
    tm:date->time-monotonic
    tm:date->time
    tm:natural-year
    tm:year-day
    tm:date-year-day
    tm:week-day
    tm:days-before-first-week
    tm:date-week-day
    tm:date-week-number
    tm:julian-day->modified-julian-day
    tm:julian-day
    (tm:date->julian-day %date-nanosecond %date-second %date-minute %date-hour
      %date-day %date-month %date-year
      %date-zone-offset
      %date-jday %date-jday-set!)
    tm:seconds->julian-day
    tm:time-utc->julian-day
    tm:time-tai->julian-day
    tm:time-monotonic->julian-day
    tm:time->julian-day
    tm:time-utc->modified-julian-day
    tm:time-tai->modified-julian-day
    tm:time-monotonic->modified-julian-day
    tm:time->modified-julian-day
    tm:julian-day->nanoseconds
    tm:julian-day->time-values
    tm:modified-julian-day->julian-day
    tm:julian-day->time-utc
    tm:default-date-adjust-integer)

  (import
    (except scheme
      + - * / remainder quotient
      abs round floor truncate
      real? integer? inexact? zero? negative? positive?
      = <= >= < >
      inexact->exact exact->inexact
      string->number)
    chicken
    (only srfi-1 fold)
    (only posix
      seconds->utc-time)
    (only extras
      format read-line)
    (only data-structures
      conc)
    (only ports
      with-input-from-port with-input-from-string)
    (only numbers
      + - * / remainder quotient
      abs round floor truncate
      real? integer? inexact? zero? negative? positive?
      = <= >= < >
      inexact->exact exact->inexact
      string->number)
    locale
    record-variants
    type-checks
    type-errors
    srfi-19-timezone)

  (require-library
    srfi-18 posix extras ports
    numbers locale record-variants type-checks type-errors
    srfi-19-timezone)

;;;

(include "srfi-19-common")

;;;NOTE the use of syntax for inlining is an experiment. no procedure w/ arithmetic can
;;;be exported as syntax.
;;
;; For storage savings since some aritmetic routines do not
;; return fixnums when possible.
;;
;; ##sys#integer?
;; returns #t for integer fixnum or flonum
;;
;; C_double_to_number
;; returns a fixnum for the flonum x iff x isa integer in fixnum-range
;; otherwise the flonum x
;;
;; When domain is integer and range is fixnum
;; Number MUST be a fixnum or flonum

(define-syntax number->genint
  (syntax-rules ()
    ((_ ?x)
      (let ((x ?x))
        #; ;DEBUG
        (when (or (< x -1073741824) (< 1073741823 x))
          (print "*** > 31 bits: " x " flonum?: " (flonum? x)))
        (if (fixnum? x)
          x
          (let ((x (floor x)))
            (if (fixnum? x)
              x
              (##core#inline "C_double_to_number" (exact->inexact x))) ) ) ) ) ) )

;;; Timing Routines

;; Provide system timing reporting procedures

(define total-gc-milliseconds
  (let ((accum-ms 0))
    (lambda ()
      (set! accum-ms (+ accum-ms (current-gc-milliseconds)))
      accum-ms ) ) )

(define (current-process-milliseconds)
  (let-values (((ums sms) (cpu-time)))
    (+ ums sms) ) )

;FIXME needs a srfi-18 extension
(define current-thread-milliseconds current-process-milliseconds)

;;; Constants

;; TAI-EPOCH: 1 January 1970 CE at 00:00:00 UTC

(define-constant TAI-EPOCH-YEAR 1970)

;(Chicken reader doesn't grok ratios w/o numbers egg at compile time.)

;; Used in julian calculation

(define ONE-HALF (string->number "1/2"))

;; Julian Day 0 = 1 January 4713 BCE at 12:00:00 UTC (Julian proleptic calendar)
;; Julian Day 0 = 24 November 4714 BCE at 12:00:00 UTC (Gregorian proleptic calendar)

(define TAI-EPOCH-IN-JD (string->number "4881175/2"))

;; Modified Julian Day 0 = 17 Nov 1858 CE at 00:00:00 UTC
;; Number of days less than a julian day.

(define TAI-EPOCH-IN-MODIFIED-JD (string->number "4800001/2"))

;; Julian conversion base century

(define-constant JDYR 4800)

;;; Leap Seconds

;; First leap year after epoch

(define-constant FIRST-LEAP-YEAR 1972)

;; Number of seconds after epoch of first leap year

(define LEAP-START
  (fx*
    (fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR)
    (fx* DY/YR SEC/DY)) )

;; A table of leap seconds
;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary.
;; Each entry is (utc seconds since epoch . # seconds to add for tai)
;; Note they go higher (2009) to lower (1972).

(define tm:leap-second-table
  '((1435708800 . 36)
    (1341100800 . 35)
    (1230768000 . 34)
    (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)
    #;(-60480000 . 4.21317)   ; Before 1972
    #;(-126230400 . 4.31317)
    #;(-136771200 . 3.84013)
    #;(-142128000 . 3.74013)
    #;(-152668800 . 3.64013)
    #;(-157766400 . 3.54013)
    #;(-168307200 . 3.44013)
    #;(-181526400 . 3.34013)
    #;(-189388800 . 3.24013)
    #;(-194659200 . 1.945858)
    #;(-252460800 . 1.845858)
    #;(-265680000 . 1.372818)
    #;(-283996800 . 1.422818) ) )

;; This procedure reads the file in the
;; ftp://maia.usno.navy.mil/ser7/tai-utc.dat format and
;; creates a leap second table

(define (tm:read-tai-utc-data flnm)

  (define (convert-jd jd)
    (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))

  (define (convert-sec sec)
    (inexact->exact sec))

  (define (read-data)
    (let loop ((ls '()))
      (let ((line (read-line)))
        (if (eof-object? line)
          ls
          (let ((data (with-input-from-string (string-append "(" line ")") read)))
            (let ((year (car data))
                  (jd   (cadddr (cdr data)))
                  (secs (cadddr (cdddr data))))
              (loop
                (if (< year FIRST-LEAP-YEAR) ls
                (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )

  (with-input-from-port (open-input-file flnm) read-data) )

;; Table of cummulative seconds, one second before the leap second.

(define (tm:calc-second-before-leap-second-table table)
  (let loop ((inlst table) (outlst '()))
    (if (null? inlst)
      (reverse outlst) ;keep input order anyway
      (let ((itm (car inlst)))
        (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )

(define tm:second-before-leap-second-table
  (tm:calc-second-before-leap-second-table tm:leap-second-table))

;; Read a leap second table file in U.S. Naval Observatory format

(define (tm:read-leap-second-table flnm)
  (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
  (set!
    tm:second-before-leap-second-table
    (tm:calc-second-before-leap-second-table tm:leap-second-table)) )

;; leap-second-delta algorithm

; 'leap-second-item' is like the 'it' in the anaphoric 'if'
;
(define-syntax find-leap-second-delta*
  (er-macro-transformer
    (lambda (form r c)
      (let ((_let (r 'let))
            (_if (r 'if))
            (_null? (r 'null?))
            (_car (r 'car))
            (_cdr (r 'cdr))
            (_leap-second-item (r 'leap-second-item)) )
        (let ((?secs (cadr form))
              (?ls (caddr form))
              (?tst (cadddr form)) )
          `(,_let loop ((lsvar ,?ls))
              (,_if (,_null? lsvar) 0
                (,_let ((leap-second-item (,_car lsvar)))
                    (,_if ,?tst
                        (,_cdr leap-second-item)
                        (loop (,_cdr lsvar)) ) ) ) ) ) ) ) ) )

(define-syntax leap-second-delta*
  (er-macro-transformer
    (lambda (form r c)
      (let ((_let (r 'let))
            (_if (r 'if))
            (_< (r '<))
            (_tm:leap-second-table (r 'tm:leap-second-table))
            (_LEAP-START (r 'LEAP-START))
            (_find-leap-second-delta* (r 'find-leap-second-delta*)) )
        (let ((?secs (cadr form))
              (?tst (caddr form)) )
          `(,_if (,_< ,?secs ,_LEAP-START)
              0
              (,_find-leap-second-delta* ,?secs ,_tm:leap-second-table ,?tst) ) ) ) ) ) )

;; Going from utc seconds ...

(define (leap-second-delta utc-seconds)
  (leap-second-delta*
    utc-seconds
    (<= (car leap-second-item) utc-seconds)) )

;; Going from tai seconds to utc seconds ...

(define (leap-second-neg-delta tai-seconds)
  (leap-second-delta*
    tai-seconds
    (<= (cdr leap-second-item) (- tai-seconds (car leap-second-item)))) )

;;; Time Object (Public Mutable)

;; There are 3 kinds of time record procedures:
;; *...   - generated
;; tm:... - argument processing then *...
;; ...    - argument checking then tm:...

#; ;
(define-record-type-variant time (unchecked inline unsafe)
  (%make-time tt ns sec)
  %time?
  (tt   %time-type        %time-type-set!)
  (ns   %time-nanosecond  %time-nanosecond-set!)
  (sec  %time-second      %time-second-set!) )

(define-record-type time
  (%make-time tt ns sec)
  %time?
  (tt   %time-type        %time-type-set!)
  (ns   %time-nanosecond  %time-nanosecond-set!)
  (sec  %time-second      %time-second-set!) )

(define time? %time?)

;; Time to Date

(define ONE-SECOND-DURATION (%make-time 'duration 0 1))

;;

;; <time-unit-value> -> <ns sec>

(define-inline (normalize-timeval t t/t+1)
  (values (remainder t t/t+1) (quotient t t/t+1)) )

(define (normalize-nanoseconds ns)
  (normalize-timeval ns NS/S) )

; <ns sec min hr> -> <ns sec min hr dy>
;
#; ;UNUSED
(define (normalize-time ns sec min hr)
  (let*-values (((ns ns-sec) (normalize-nanoseconds ns))
                ((sec sec-min) (normalize-timeval (+ sec ns-sec) SEC/MIN))
                ((min min-hr) (normalize-timeval (+ min sec-min) MIN/HR))
                ((hr hr-dy) (normalize-timeval (+ hr min-hr) HR/DY)) )
        (values ns sec min hr (+ dy hr-dy)) ) )

;;

(define-constant TIME-FORMAT-SRFI-10 "#,(time ~A ~A ~A)")

(define-constant TIME-FORMAT-BRACKET "<time ~A ~A ~A>")

(define time-record-printer-format (make-parameter TIME-FORMAT-SRFI-10
  (lambda (x)
    (if (string? x)
      x
      (begin
        (warning 'time-record-printer-format "invalid format" x)
        (time-record-printer-format) ) ) ) ) )

(define-record-printer (time tim out)
  (format out (time-record-printer-format)
    (%time-type tim)
    (%time-nanosecond tim)
    (%time-second tim)) )

(define-reader-ctor 'time
  (lambda (tt ns sec)
    (%make-time tt ns sec)))

;;

(define (time-type? obj)
  (memq obj '(monotonic utc tai gc duration process thread)) )

(define (time-seconds? obj)
  (integer? obj) )

(define (time-nanoseconds? obj)
  (and (fixnum? obj) (fx< -NS/S obj) (fx< obj NS/S)) )

;;

(define-check+error-type time %time?)
(define-check+error-type time-type)
(define-check+error-type time-seconds)
(define-check+error-type time-nanoseconds)

;; Output Argument CTORs

;Used to create an output time record where all fields will be set later
;
(define-syntax tm:any-time
	(syntax-rules ()
		((_)
      (%make-time #f #f #f) ) ) )

;Used to create a time record where ns & sec fields will be set later
;
(define-syntax tm:some-time
	(syntax-rules ()
		((_ ?tt)
		  (let ((tt ?tt))
        (%make-time tt #f #f) ) ) ) )

;Used to create a time record where ns & sec fields will be set later
;
(define-syntax tm:as-some-time
	(syntax-rules ()
		((_ ?tim)
		  (let ((tim ?tim))
        (%make-time (%time-type tim) #f #f) ) ) ) )

;;

(define-syntax tm:time-type
	(syntax-rules ()
		((_ ?tim)
		  (let ((tim ?tim))
        (%time-type tim) ) ) ) )

(define-syntax tm:time-second
	(syntax-rules ()
		((_ ?tim)
		  (let ((tim ?tim))
        (%time-second tim) ) ) ) )

(define-syntax tm:time-nanosecond
	(syntax-rules ()
		((_ ?tim)
		  (let ((tim ?tim))
        (%time-nanosecond tim) ) ) ) )

(define-syntax tm:time-type-set!
	(syntax-rules ()
		((_ ?tim ?typ)
 		  (let ((tim ?tim) (typ ?typ))
        (%time-type-set! tim typ) ) ) ) )

(define-syntax tm:time-nanosecond-set!
	(syntax-rules ()
		((_ ?tim ?ns)
		  (let ((tim ?tim) (ns ?ns))
        (%time-nanosecond-set! tim (number->genint ns)) ) ) ) )

(define-syntax tm:time-second-set!
	(syntax-rules ()
		((_ ?tim ?sec)
		  (let ((tim ?tim) (sec ?sec))
        (%time-second-set! tim (number->genint sec)) ) ) ) )

(define (tm:make-time tt ns sec)
  (let-values (((ns ns-sec) (normalize-nanoseconds ns)))
    (%make-time tt (number->genint ns) (number->genint (+ sec ns-sec))) ) )

(define-syntax tm:copy-time
	(syntax-rules ()
		((_ ?tim)
		  (let ((tim ?tim))
        (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) ) ) ) )

(define-syntax tm:time-has-type?
	(syntax-rules ()
		((_ ?tim ?tt)
		  (let ((tim ?tim) (tt ?tt))
        (eq? tt (%time-type tim)) ) ) ) )

;; Rem & Quo of nanoseconds per second

(define (tm:nanoseconds->time-values nanos)
  (values (remainder nanos NS/S) (quotient nanos NS/S)) )

;; Seconds Conversion

(define (check-raw-seconds loc obj) (check-real loc obj 'seconds))

(define (check-raw-milliseconds loc obj) (check-real loc obj 'milliseconds))

;;

(define (tm:time->nanoseconds tim)
  (+ (%time-nanosecond tim) (* (%time-second tim) NS/S)) )

(define (tm:time->milliseconds tim)
  (+ (/ (%time-nanosecond tim) NS/MS) (* (%time-second tim) MS/S)) )

(define (tm:nanoseconds->seconds ns)
  (/ ns NS/S) )

(define (tm:milliseconds->seconds ms)
  (/ (exact->inexact ms) MS/S) )

(define-syntax tm:time->seconds
	(syntax-rules ()
		((_ ?tim)
		  (let ((tim ?tim))
		    (tm:nanoseconds->seconds (tm:time->nanoseconds tim)) ) ) ) )

(define (tm:duration-elements->time-values
          days
          hours minutes seconds
          milliseconds microseconds nanoseconds)
	(let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
          (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
    (let-values (((ns-ns ns-secs)
                  (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))))
      (values ns-ns (+ (floor secs) ns-secs)) ) ) )

(define (tm:seconds->time-values sec)
  (let* ((tsec (number->genint (floor sec)))
         (ns (number->genint (exact->inexact (round (* (- sec tsec) NS/S))))) )
    (values ns tsec) ) )

(define (tm:milliseconds->time-values ms)
  (let ((ns (fx* (number->genint (remainder ms MS/S)) NS/MS))
        (sec (quotient ms MS/S)) )
    (values ns sec) ) )

(define-syntax tm:milliseconds->time
	(syntax-rules ()
		((_ ?ms ?tt)
		  (let ((ms ?ms) (tt ?tt))
        (let-values (((ns sec) (tm:milliseconds->time-values ms)))
          (tm:make-time tt ns sec) ) ) ) ) )

(define-syntax tm:seconds->time
	(syntax-rules ()
		((_ ?sec ?tt)
		  (let ((sec ?sec) (tt ?tt))
        (let-values (((ns sec) (tm:seconds->time-values sec)))
          (tm:make-time tt ns sec) ) ) ) ) )

;; Current time routines

; Throw away everything but the sub-second bit.
;
(define (tm:current-sub-milliseconds)
	(inexact->exact (remainder (current-milliseconds) MS/S)) )

(define (tm:current-nanoseconds)
  (fx* (tm:current-sub-milliseconds) NS/MS) )

;Use the 'official' seconds & nanoseconds values
;
(define-syntax tm:current-time-values
	(syntax-rules ()
		((_)
      (values (tm:current-nanoseconds) (current-seconds)) ) ) )

(define-syntax tm:current-time-utc
	(syntax-rules ()
		((_)
		  (let-values (((ns sec) (tm:current-time-values)))
        (tm:make-time 'utc ns sec) ) ) ) )

(define-syntax tm:current-time-tai
	(syntax-rules ()
		((_)
      (let-values (((ns sec) (tm:current-time-values)))
        (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) ) ) )

(define-syntax tm:current-time-monotonic
	(syntax-rules ()
		((_)
      (let ((tim (tm:current-time-tai)))
        ;time-monotonic is time-tai
        (%time-type-set! tim 'monotonic)
        tim ) ) ) )

(define-syntax tm:current-time-thread
	(syntax-rules ()
		((_)
      (tm:milliseconds->time (current-thread-milliseconds) 'thread) ) ) )

(define-syntax tm:current-time-process
	(syntax-rules ()
		((_)
      (tm:milliseconds->time (current-process-milliseconds) 'process) ) ) )

(define-syntax tm:current-time-gc
	(syntax-rules ()
		((_)
      (tm:milliseconds->time (total-gc-milliseconds) 'gc) ) ) )

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

(define (tm:time-resolution tt)
  NS/MS )

;; Specialized Time Parameter Checking

(define (error-incompatible-time-types loc tt1 tt2)
  (signal-type-error loc "incompatible time-types"  tt1 tt2) )

(define (check-time-has-type loc tim tt)
  (unless (tm:time-has-type? tim tt)
    (error-incompatible-time-types loc (%time-type tim) tt) ) )

(define (check-time-and-type loc tim tt)
  (check-time loc tim)
  (check-time-has-type loc tim tt) )

(define (check-duration loc obj) (check-time-and-type loc obj 'duration))

(define (check-time-elements loc obj1 obj2 obj3)
  (check-time-type loc obj1)
  (check-time-nanoseconds loc obj2)
  (check-time-seconds loc obj3) )

#; ;UNUSED
(define (check-times loc objs) (for-each (cut check-time loc <>) objs))

(define (check-time-binop loc obj1 obj2)
  (check-time loc obj1)
  (check-time loc obj2) )

(define (check-time-compare loc obj1 obj2)
  (check-time-binop loc obj1 obj2)
  (check-time-has-type loc obj1 (%time-type obj2)) )

(define (check-time-aritmetic loc tim dur)
  (check-time loc tim)
  (check-duration loc dur) )

;; Time Comparison

(define (tm:time-compare tim1 tim2)
  (let ((dif (- (%time-second tim1) (%time-second tim2))))
    (if (not (zero? dif))
      dif
      (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )

(define (tm:time=? tim1 tim2)
  (and
    (= (%time-second tim1) (%time-second tim2))
    (fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) )

(define (tm:time<? tim1 tim2)
  (or
    (< (%time-second tim1) (%time-second tim2))
    (and
      (= (%time-second tim1) (%time-second tim2))
      (fx< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )

(define (tm:time<=? tim1 tim2)
  (or
    (< (%time-second tim1) (%time-second tim2))
    (and
      (= (%time-second tim1) (%time-second tim2))
      (fx<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )

(define (tm:time>? tim1 tim2)
  (or
    (> (%time-second tim1) (%time-second tim2))
    (and
      (= (%time-second tim1) (%time-second tim2))
      (fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )

(define (tm:time>=? tim1 tim2)
  (or
    (> (%time-second tim1) (%time-second tim2))
    (and
      (= (%time-second tim1) (%time-second tim2))
      (fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )

(define-syntax tm:time-max
	(syntax-rules ()
		((_ ?tim1 ?tim2)
		  (let ((tim1 ?tim1) (tim2 ?tim2))
        (if (tm:time>? tim1 tim2) tim1 tim2) ) ) ) )

(define-syntax tm:time-min
	(syntax-rules ()
		((_ ?tim1 ?tim2)
		  (let ((tim1 ?tim1) (tim2 ?tim2))
        (if (tm:time<? tim1 tim2) tim1 tim2) ) ) ) )

;; Time Arithmetic

(define (tm:add-duration tim1 dur timout)
	(let-values (((ns sec)
                  (tm:nanoseconds->time-values
                    (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    (let ((secs (+ (%time-second tim1) (%time-second dur) sec)))
      (cond
        ((negative? ns) ;Borrow
          ;Should never happen
          (tm:time-second-set! timout (+ secs -1))
          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
        (else
          (tm:time-second-set! timout secs)
          (tm:time-nanosecond-set! timout ns) ) )
      timout ) ) )

(define (tm:subtract-duration tim1 dur timout)
  (let-values (((ns sec)
                    (tm:nanoseconds->time-values
                      (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
    (let ((secs (- (%time-second tim1) (%time-second dur) sec)))
      (cond
        ((negative? ns) ;Borrow
          (tm:time-second-set! timout (- secs 1))
          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
        (else
          (tm:time-second-set! timout secs)
          (tm:time-nanosecond-set! timout ns) ) )
      timout ) ) )

(define (tm:divide-duration dur1 num durout)
  (let-values (((ns sec)
                (tm:nanoseconds->time-values
                  (/ (tm:time->nanoseconds dur1) num))) )
    (tm:time-nanosecond-set! durout ns)
    (tm:time-second-set! durout sec)
    durout ) )

(define (tm:multiply-duration dur1 num durout)
	(let-values (((ns sec)
                (tm:nanoseconds->time-values
                  (* (tm:time->nanoseconds dur1) num))) )
    (tm:time-nanosecond-set! durout ns)
    (tm:time-second-set! durout sec)
    durout ) )

(define (tm:time-difference tim1 tim2 timout)
  (let-values (((ns sec)
                (tm:nanoseconds->time-values
                  (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
    (tm:time-second-set! timout sec)
    (tm:time-nanosecond-set! timout ns)
    timout ) )

(define-syntax tm:time-abs
	(syntax-rules ()
		((_ ?tim1 ?timout)
		  (let ((tim1 ?tim1)
		        (timout ?timout))
        (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
        (tm:time-second-set! timout (abs (%time-second tim1)))
        timout ) ) ) )

(define (tm:time-negate tim1 timout )
  (tm:time-nanosecond-set! timout (- (%time-nanosecond tim1)))
  (tm:time-second-set! timout (- (%time-second tim1)))
  timout )

(define (tm:time-negative? tim)
  ;nanoseconds irrelevant
  (negative? (tm:time-second tim)) )

(define (tm:time-positive? tim)
  ;nanoseconds irrelevant
  (positive? (tm:time-second tim)) )

(define (tm:time-zero? tim)
  (and
    (zero? (tm:time-nanosecond tim))
    (zero? (tm:time-second tim))) )

;; Time Type Converters

(define (tm:time-tai->time-utc timin timout)
  (%time-type-set! timout 'utc)
  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
  (tm:time-second-set!
    timout
    (-
      (%time-second timin)
      (leap-second-neg-delta (%time-second timin))))
  timout )

(define-syntax tm:time-tai->time-monotonic
	(syntax-rules ()
		((_ ?timin ?timout)
		  (let ((timin ?timin)
		        (timout ?timout))
        (%time-type-set! timout 'monotonic)
        (unless (eq? timin timout)
          (tm:time-nanosecond-set! timout (%time-nanosecond timin))
          (tm:time-second-set! timout (%time-second timin)))
        timout ) ) ) )

(define (tm:time-utc->time-tai timin timout)
  (%time-type-set! timout 'tai)
  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
  (tm:time-second-set!
    timout
    (+
      (%time-second timin)
      (leap-second-delta (%time-second timin))))
  timout )

(define-syntax tm:time-utc->time-monotonic
	(syntax-rules ()
		((_ ?timin ?timout)
		  (let ((timin ?timin)
		        (timout ?timout))
        (let ((ntim (tm:time-utc->time-tai timin timout)))
          (%time-type-set! ntim 'monotonic)
          ntim ) ) ) ) )

(define-syntax tm:time-monotonic->time-tai
	(syntax-rules ()
		((_ ?timin ?timout)
		  (let ((timin ?timin)
		        (timout ?timout))
        (%time-type-set! timout 'tai)
        (unless (eq? timin timout)
          (tm:time-nanosecond-set! timout (%time-nanosecond timin))
          (tm:time-second-set! timout (%time-second timin)))
        timout ) ) ) )

(define-syntax tm:time-monotonic->time-utc
	(syntax-rules ()
		((_ ?timin ?timout)
		  (let ((timin ?timin)
		        (timout ?timout))
        #;(%time-type-set! timin 'tai) ; fool converter (unnecessary)
        (tm:time-tai->time-utc timin timout) ) ) ) )

;;; Date Object (Public Immutable)

;; Leap Year Test

;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
;; The Journal of the Royal Astronomical Society of Canada.
;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
;; Part II, volume 58, number 2, pages 79-87 (April 1964).

(define-syntax tm:leap-year?
	(syntax-rules ()
		((_ ?yr)
		  (let ((yr ?yr))
        (and
          (not (fx= (fxmod yr 4000) 0)) ;Not officially adopted!
          (or
            (fx= (fxmod yr 400) 0)
            (and
              (fx= (fxmod yr 4) 0)
              (not (fx= (fxmod yr 100) 0))))) ) ) ) )

;; Days per Month

;Month range 1..12 so dys/mn range 0..12
(define      +year-dys/mn+ '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
(define +leap-year-dys/mn+ '#(0 31 29 31 30 31 30 31 31 30 31 30 31))

(define-syntax tm:leap-day?
	(syntax-rules ()
		((_ ?dy ?mn)
		  (let ((dy ?dy) (mn ?mn))
        (fx= dy (vector-ref +leap-year-dys/mn+ mn)) ) ) ) )

(define-syntax tm:days-in-month
	(syntax-rules ()
		((_ ?yr ?mn)
		  (let ((yr ?yr) (mn ?mn))
        (vector-ref
          (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+)
          mn) ) ) ) )

;;

#;
(define-record-type-variant date (unchecked inline unsafe)
  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
  %date?
  (ns     %date-nanosecond  %date-nanosecond-set!)
  (sec    %date-second      %date-second-set!)
  (min    %date-minute      %date-minute-set!)
  (hr     %date-hour        %date-hour-set!)
  (dy     %date-day         %date-day-set!)
  (mn     %date-month       %date-month-set!)
  (yr     %date-year        %date-year-set!)
  (tzo    %date-zone-offset %date-zone-offset-set!)
  ;; non-srfi extn
  (tzn    %date-zone-name   %date-zone-name-set!)
  (dstf   %date-dst?        %date-dst-set!)
  (wdy    %date-wday        %date-wday-set!)
  (ydy    %date-yday        %date-yday-set!)
  (jdy    %date-jday        %date-jday-set!) )

(define-record-type date
  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
  %date?
  (ns     %date-nanosecond  %date-nanosecond-set!)
  (sec    %date-second      %date-second-set!)
  (min    %date-minute      %date-minute-set!)
  (hr     %date-hour        %date-hour-set!)
  (dy     %date-day         %date-day-set!)
  (mn     %date-month       %date-month-set!)
  (yr     %date-year        %date-year-set!)
  (tzo    %date-zone-offset %date-zone-offset-set!)
  ;; non-srfi extn
  (tzn    %date-zone-name   %date-zone-name-set!)
  (dstf   %date-dst?        %date-dst-set!)
  (wdy    %date-wday        %date-wday-set!)
  (ydy    %date-yday        %date-yday-set!)
  (jdy    %date-jday        %date-jday-set!) )

(define date? %date?)

;;

(define-constant DATE-FORMAT-SRFI-10 "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)")

(define-constant DATE-FORMAT-BRACKET "<date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A>")

(define date-record-printer-format (make-parameter DATE-FORMAT-SRFI-10
  (lambda (x)
    (if (string? x)
      x
      (begin
        (warning 'date-record-printer-format "invalid format" x)
        (date-record-printer-format) ) ) ) ) )

(define-record-printer (date dat out)
  (format out (date-record-printer-format)
   (%date-nanosecond dat)
   (%date-second dat) (%date-minute dat) (%date-hour dat)
   (%date-day dat) (%date-month dat) (%date-year dat)
   (%date-zone-offset dat)
   (%date-zone-name dat) (%date-dst? dat)
   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )

(define-reader-ctor 'date
  (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))

;;

; Nanoseconds in [0 NS/S-1]
(define-syntax date-nanoseconds?
	(syntax-rules ()
		((_ ?obj)
		  (let ((obj ?obj))
        (and
          (fixnum? obj)
          (fx<= 0 obj)
          (fx< obj NS/S)) ) ) ) )

; Seconds in [0 SEC/MIN] ; SEC/MIN legal due to leap second
(define-syntax date-seconds?
	(syntax-rules ()
		((_ ?obj)
		  (let ((obj ?obj))
        (and
          (fixnum? obj)
          (fx<= 0 obj)
          (fx<= obj SEC/MIN)) ) ) ) )

; Minutes in [0 SEC/MIN-1]
(define-syntax date-minutes?
	(syntax-rules ()
		((_ ?obj)
		  (let ((obj ?obj))
        (and
          (fixnum? obj)
          (fx<= 0 obj)
          (fx< obj SEC/MIN)) ) ) ) )

; Hours in [0 HR/DY-1]
(define-syntax date-hours?
	(syntax-rules ()
		((_ ?obj)
		  (let ((obj ?obj))
        (and
          (fixnum? obj)
          (fx<= 0 obj)
          (fx< obj HR/DY)) ) ) ) )

; Days in [1 28/29/30/31] - depending on month & year
(define-syntax date-day?
	(syntax-rules ()
		((_ ?obj ?mn ?yr)
		  (let ((obj ?obj) (mn ?mn) (yr ?yr))
        (and
          (fixnum? obj)
          (fx<= 1 obj)
          (fx<= obj (tm:days-in-month yr mn))) ) ) ) )

; Months in [1 MN/YR]
(define-syntax date-month?
	(syntax-rules ()
		((_ ?obj)
		  (let ((obj ?obj))
        (and
          (fixnum? obj)
          (fx<= 1 obj)
          (fx<= obj MN/YR)) ) ) ) )

; No year 0!
(define (date-year? obj)
  (and
    (fixnum? obj)
    (not (fx= 0 obj))) )

;;

(define-check+error-type date-nanoseconds)
(define-check+error-type date-seconds)
(define-check+error-type date-minutes)
(define-check+error-type date-hours)
(define-error-type date-day)
(define (check-date-day loc obj mn yr) (unless (date-day? obj mn yr) (error-date-day loc obj)) )
(define-check+error-type date-month)
(define-check+error-type date-year)

(define (check-date-elements loc ns sec min hr dy mn yr tzo tzn)
  (check-date-nanoseconds loc ns)
  (check-date-seconds loc sec)
  (check-date-minutes loc min)
  (check-date-hours loc hr)
  (check-date-year loc yr)
  (check-date-month loc mn)
  (check-date-day loc dy mn yr)
  (check-timezone-offset loc tzo "date-timezone-offset")
  (check-timezone-name loc tzn "date-timezone-name") )

;;

(define (error-date-compatible-timezone loc dat1 dat2)
  (signal-type-error loc "not compatible timezones" dat1 dat2) )

(define (check-date-compatible-timezone-offsets loc dat1 dat2)
  (unless (fx= (%date-zone-offset dat1) (%date-zone-offset dat2))
    (error-date-compatible-timezone loc dat1 dat2) ) )

;;

(define (clock-type? obj) (memq obj '(monotonic tai utc)))

(define-check+error-type clock-type)

(define (error-convert loc srcnam dstnam obj)
  (signal-type-error loc (conc "cannot convert " srcnam " to " dstnam) obj) )

(define-check+error-type date %date?)

;;

;;; Getters

(define-syntax tm:date-nanosecond
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-nanosecond dat) ) ) ) )

(define-syntax tm:date-second
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-second dat) ) ) ) )

(define-syntax tm:date-minute
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-minute dat) ) ) ) )

(define-syntax tm:date-hour
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-hour dat) ) ) ) )

(define-syntax tm:date-day
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-day dat) ) ) ) )

(define-syntax tm:date-month
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-month dat) ) ) ) )

(define-syntax tm:date-year
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-year dat) ) ) ) )

(define-syntax tm:date-zone-offset
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-zone-offset dat) ) ) ) )

(define-syntax tm:date-zone-name
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-zone-name dat) ) ) ) )

(define-syntax tm:date-dst?
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-dst? dat) ) ) ) )

(define-syntax tm:date-wday
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-wday dat) ) ) ) )

(define-syntax tm:date-yday
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-yday dat) ) ) ) )

(define-syntax tm:date-jday
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%date-jday dat) ) ) ) )

;;; Setters

(define-syntax tm:date-nanosecond-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
        (%date-nanosecond-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-second-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-second-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-minute-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-minute-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-hour-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-hour-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-day-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-day-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-month-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-month-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-year-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-year-set! dat (number->genint x)) ) ) ) )

(define-syntax tm:date-zone-offset-set!
	(syntax-rules ()
		((_ ?dat ?x)
		  (let ((dat ?dat) (x ?x))
      	(%date-zone-offset-set! dat (number->genint x)) ) ) ) )

;; Date TZ information extract

;Belongs in srfi-19-timezone

#;
(define-record-type-variant date-timezone-info (unchecked inline unsafe)
  (%make-date-timezone-info n o d)
  %date-timezone-info?
  (n %date-timezone-info-name)
  (o %date-timezone-info-offset)
  (d %date-timezone-info-dst?) )

(define-record-type date-timezone-info
  (%make-date-timezone-info n o d)
  %date-timezone-info?
  (n %date-timezone-info-name)
  (o %date-timezone-info-offset)
  (d %date-timezone-info-dst?) )

(define-syntax tm:date-timezone-info
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        #;(make-timezone-locale (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat))
        (%make-date-timezone-info
          (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) ) ) ) )

;; Returns an invalid date record (for use by 'scan-date')

(define-syntax tm:make-incomplete-date
	(syntax-rules ()
		((_)
      (%make-date
        0
        0 0 0
        #f #f #f
        (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
        #f #f #f) ) ) )

;; Internal Date CTOR

(define-syntax tm:make-date
	(syntax-rules ()
		((_ ?ns ?sec ?min ?hr ?dy ?mn ?yr ?tzo ?tzn ?dstf ?wdy ?ydy ?jdy)
		  (let ((ns ?ns) (sec ?sec) (min ?min) (hr ?hr) (dy ?dy) (mn ?mn) (yr ?yr) (tzo ?tzo) (tzn ?tzn) (dstf ?dstf) (wdy ?wdy) (ydy ?ydy) (jdy ?jdy))
        (%make-date
          (number->genint ns)
          (number->genint sec) (number->genint min) (number->genint hr)
          (number->genint dy) (number->genint mn) (number->genint yr)
          (number->genint tzo) tzn dstf
          wdy ydy jdy) ) ) ) )

(define-syntax tm:copy-date
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (%make-date
          (%date-nanosecond dat)
          (%date-second dat) (%date-minute dat) (%date-hour dat)
          (%date-day dat) (%date-month dat) (%date-year dat)
          (%date-zone-offset dat)
          (%date-zone-name dat) (%date-dst? dat)
          (%date-wday dat) (%date-yday dat) (%date-jday dat)) ) ) ) )

(define (tm:seconds->date/type sec tzc)
  (let* ((fsec (exact->inexact sec))
           (isec (floor fsec))
           (tzo (timezone-locale-offset tzc))
           (tv (seconds->utc-time (+ isec tzo))))
      (tm:make-date
        (round (* (- fsec isec) NS/S))
        (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
        (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
        tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
        (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )

(define-syntax tm:current-date
	(syntax-rules ()
		((_ ?tzi) (let ((tzi ?tzi)) (tm:time-utc->date (tm:current-time-utc) tzi)) ) ) )

;; Date Comparison

(define-syntax tm:date-compare
	(syntax-rules ()
		((_ ?dat1 ?dat2)
		  (let ((dat1 ?dat1) (dat2 ?dat2))
        (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
          (if (not (fxzero? dif))
            dif
            (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
              (if (not (fxzero? dif))
                dif
                (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
                  (if (not (fxzero? dif))
                    dif
                    (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
                      (if (not (fxzero? dif))
                        dif
                        (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
                          (if (not (fxzero? dif))
                            dif
                            (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
                              (if (not (fxzero? dif))
                                dif
                                (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )

;; Gives the seconds/day/month/year

#; ;Original
(define (tm:decode-julian-day-number jdn)
  (let* ((days (floor 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) tm:sid)
     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
     (+ m 3 (* -12 (quotient m 10)))
     (if (>= 0 y) (- y 1) y)) ) )

(define (tm:decode-julian-day-number jdn)
  (let* ((dys (number->genint (floor jdn)))
         (a (fx+ dys 32044))
         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
         (c (fx- a (fx/ (fx* 146097 b) 4)))
         (d (fx/ (fx+ (fx* 4 c) 3) 1461))
         (e (fx- c (fx/ (fx* 1461 d) 4)))
         (m (fx/ (fx+ (fx* 5 e) 2) 153))
         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
    (values ; seconds date month year
      (number->genint (floor (* (- jdn dys) SEC/DY)))
      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
      (if (fx<= y 0) (fx- y 1) y)) ) )

;; Gives the Julian day number - rounds up to the nearest day

(define (tm:seconds->julian-day-number sec tzo)
  (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )

;; Is the time object one second before a leap second?

(define (tm:tai-before-leap-second? tim)
  (let ((sec (%time-second tim)))
    (let loop ((ls tm:second-before-leap-second-table))
      (and
        (not (null? ls))
        (or
          (= sec (car ls))
          (loop (cdr ls)) ) ) ) ) )

(define (tm:time-utc->date tim tzi)
  (let ((tzo tzi) ;assume an offset
        (tzn #f)
        (dstf #f))
      (cond
        ((%date-timezone-info? tzi)
          (set! dstf (%date-timezone-info-dst? tzi))
          (set! tzn (%date-timezone-info-name tzi))
          (set! tzo (%date-timezone-info-offset tzi)) )
        ((timezone-components? tzi)
          (set! dstf (timezone-locale-dst? tzi))
          (set! tzn (timezone-locale-name tzi))
          (set! tzo (timezone-locale-offset tzi)) ) )
    (let-values (((secs dy mn yr)
                    (tm:decode-julian-day-number
                      (tm:seconds->julian-day-number (%time-second tim) tzo))) )
      (let ((hr (fx/ secs SEC/HR))
            (rem (fxmod secs SEC/HR)))
        (let ((min (fx/ rem SEC/MIN))
              (sec (fxmod rem SEC/MIN)))
          (tm:make-date
            (%time-nanosecond tim)
            sec min hr
            dy mn yr
            tzo tzn dstf
            #f #f #f) ) ) ) ) )

(define (tm:time-tai->date tim tzi)
  (let ((tm-utc (tm:time-tai->time-utc tim (tm:any-time))))
    (if (not (tm:tai-before-leap-second? tim))
      (tm:time-utc->date tm-utc tzi)
      ; else time is *right* before the leap, we need to pretend to subtract a second ...
      (let ((dat (tm:time-utc->date (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
        (%date-second-set! dat SEC/MIN) ; Note full minute!
        dat ) ) ) )

(define (tm:time->date tim tzi)
  (case (%time-type tim)
    ((utc)       (tm:time-utc->date tim tzi))
    ((tai)       (tm:time-tai->date tim tzi))
    ((monotonic) (tm:time-utc->date tim tzi))
    (else        #f)) )

;; Date to Time

;; Gives the Julian day number - Gregorian proleptic calendar

(define (tm:encode-julian-day-number dy mn yr)
  (let* ((a (fx/ (fx- 14 mn) MN/YR))
         (b (fx- (fx+ yr JDYR) a))
         (y (if (fx< yr 0) (fx+ b 1) b)) ; BCE?
         (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
    (+
      dy
     (fx/ (fx+ (fx* 153 m) 2) 5)
     (fx* y DY/YR)
     (fx/ y 4)
     (fx/ y -100)
     (fx/ y 400)
     -32045) ) )

(define (tm:date->time-utc dat)
  (let ((ns (%date-nanosecond dat))
        (sec (%date-second dat))
        (min (%date-minute dat))
        (hr (%date-hour dat))
        (dy (%date-day dat))
        (mn (%date-month dat))
        (yr (%date-year dat))
        (tzo (%date-zone-offset dat)) )
    (let ((jdys
            (-
              (tm:encode-julian-day-number dy mn yr)
              TAI-EPOCH-IN-JD))
          (secs
            (fx+
              (fx+
                (fx* hr SEC/HR)
                (fx+
                  (fx* min SEC/MIN)
                  sec))
              (fxneg tzo))) )
      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )

(define (tm:date->time-tai dat)
  (let* ((tm-utc (tm:date->time-utc dat))
         (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
    (if (not (fx= SEC/MIN (%date-second dat)))
      tm-tai
      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )

(define (tm:date->time-monotonic dat)
  (let ((tim-utc (tm:date->time-utc dat)))
    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )

(define (tm:date->time dat tt)
  (case tt
    ((utc)        (tm:date->time-utc dat))
    ((tai)        (tm:date->time-tai dat))
    ((monotonic)  (tm:date->time-monotonic dat))
    (else         #f) ) )

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

(define (tm:natural-year n tzi)
  (if (or (fx< n 0) (fx>= n 100))
    n
    (let* ((current-year (%date-year (tm:current-date tzi)))
           (current-century (fx* (fx/ current-year 100) 100)))
      (if (fx<= (fx- (fx+ current-century n) current-year) 50)
        (fx+ current-century n)
        (fx+ (fx- current-century 100) n) ) ) ) )

;; Day of Year

(define +cumulative-month-days+ '#(0 0 31 59 90 120 151 181 212 243 273 304 334))

(define (tm:year-day dy mn yr)
  (let ((yrdy (fx+ dy (vector-ref +cumulative-month-days+ mn))))
    (if (and (tm:leap-year? yr) (fx< 2 mn))
      (fx+ yrdy 1)
      yrdy ) ) )

(define (tm:cache-date-year-day dat)
  (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
    (%date-yday-set! dat yrdy)
    yrdy ) )

(define (tm:date-year-day dat)
  (or
    (%date-yday dat)
    (tm:cache-date-year-day dat) ) )

;; Week Day

(define (week-day? obj)
  (and (fixnum? obj) (fx<= 0 obj) (fx<= obj 6)) )

(define-check+error-type week-day)

;; Using Gregorian Calendar (from Calendar FAQ)

(define (tm:week-day dy mn yr)
  (let* ((a (fx/ (fx- 14 mn) MN/YR))
         (y (fx- yr a))
         (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
    (fxmod
      (fx+
        (fx+ dy y)
        (fx+
          (fx-
            (fx/ y 4)
            (fx/ y 100))
          (fx+
            (fx/ y 400)
            (fx/ (fx* m DY/MN) MN/YR))))
      DY/WK) ) )

(define (tm:cache-date-week-day dat)
  (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
    (%date-wday-set! dat wdy)
    wdy ) )

(define (tm:date-week-day dat)
  (or
    (%date-wday dat)
    (tm:cache-date-week-day dat) ) )

(define (tm:days-before-first-week dat 1st-weekday)
  (fxmod (fx- 1st-weekday (tm:week-day 1 1 (%date-year dat))) DY/WK) )

(define (tm:date-week-number dat 1st-weekday)
  (fx/
    (fx- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
    DY/WK) )

;; Julian-day Operations

(define (julian-day? obj) (real? obj))

(define-check+error-type julian-day)

(define (tm:julian-day->modified-julian-day mjdn)
  (- mjdn TAI-EPOCH-IN-MODIFIED-JD) )

;; Date to Julian-day

; Does the nanoseconds value contribute anything to the julian day?
; The range is < 1 second here (but not in the reference).

(define (tm:julian-day ns sec min hr dy mn yr tzo)
  (let ((jdn
          (tm:encode-julian-day-number dy mn yr))
        (time-seconds
          (+
            (fx+
              (fx+
                (fx* hr SEC/HR)
                (fx+ (fx* min SEC/MIN) sec))
              (fxneg tzo))
              (/ ns NS/S))) )
    (+ (- jdn ONE-HALF) (/ time-seconds SEC/DY)) ) )

#; ; inexact version
(define (tm:julian-day ns sec min hr dy mn yr tzo)
  (let ((time-seconds
          (fx+
            (fx+
              (fx* hr SEC/HR)
              (fx+ (fx* min SEC/MIN) sec))
              (fxneg tzo)) ) )
    (fp+
      (fp-
        (exact->inexact (tm:encode-julian-day-number dy mn yr))
        (exact->inexact ONE-HALF))
      (fp/
        (fp+
          (exact->inexact time-seconds)
          (fp/ (exact->inexact ns) (exact->inexact NS/S)))
        (exact->inexact SEC/DY))) ) )

(define-syntax tm:date->julian-day
	(syntax-rules ()
		((_ ?dat)
		  (let ((dat ?dat))
        (or
          (%date-jday dat)
          (let ((jdn
                 (tm:julian-day
                  (%date-nanosecond dat)
                  (%date-second dat) (%date-minute dat) (%date-hour dat)
                  (%date-day dat) (%date-month dat) (%date-year dat)
                  (%date-zone-offset dat))))
            (%date-jday-set! dat jdn)
            jdn ) ) ) ) ) )

;; Time to Julian-day

(define (tm:seconds->julian-day ns sec)
  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )

(define (tm:time-utc->julian-day tim)
  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )

(define (tm:time-tai->julian-day tim)
  (let ((sec (%time-second tim)))
    (tm:seconds->julian-day
      (%time-nanosecond tim)
      (- sec (leap-second-delta sec))) ) )

(define tm:time-monotonic->julian-day tm:time-tai->julian-day)

(define (tm:time->julian-day tim)
  (case (%time-type tim)
    ((utc)       (tm:time-utc->julian-day tim))
    ((tai)       (tm:time-tai->julian-day tim))
    ((monotonic) (tm:time-monotonic->julian-day tim))
    (else        #f)) )

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

(define (tm:time-tai->modified-julian-day tim)
  (tm:julian-day->modified-julian-day (tm:time-tai->julian-day tim)) )

(define (tm:time-monotonic->modified-julian-day tim)
  (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )

(define (tm:time->modified-julian-day tim)
  (case (%time-type tim)
    ((utc)       (tm:time-utc->modified-julian-day tim))
    ((tai)       (tm:time-tai->modified-julian-day tim))
    ((monotonic) (tm:time-monotonic->modified-julian-day tim))
    (else        #f)) )

;; Julian-day to Time

(define (tm:julian-day->nanoseconds jdn)
  (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S) )

(define (tm:julian-day->time-values jdn)
  (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)) )

(define (tm:modified-julian-day->julian-day mjdn)
  (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) )

(define-syntax tm:julian-day->time-utc
	(syntax-rules ()
		((_ ?jdn)
		  (let ((jdn ?jdn))
        (let-values (((ns sec) (tm:julian-day->time-values jdn)))
          (tm:make-time 'time-utc ns sec) ) ) ) ) )

(define (tm:default-date-adjust-integer amt)
  (round amt) )

) ;module srfi-19-support