source: project/release/5/srfi-19/tags/4.1.0/srfi-19-support.scm @ 38113

;;;; 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)
;;
;; - The Private API but must be visible because of exported syntax

;; 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
  ;;Public
  time? check-time error-time
  time-type? check-time-type error-time-type
  time-seconds? check-time-seconds error-time-seconds
  time-nanoseconds? check-time-nanoseconds error-time-nanoseconds
  clock-type? check-clock-type error-clock-type
  date? check-date error-date
  date-nanoseconds? check-date-nanoseconds error-date-nanoseconds
  date-seconds? check-date-seconds error-date-seconds
  date-minutes? check-date-minutes error-date-minutes
  date-hours? check-date-hours error-date-hours
  date-day? check-date-day error-date-day
  date-month? check-date-month error-date-month
  date-year? check-date-year error-date-year
  week-day? check-week-day error-week-day
  julian-day? check-julian-day error-julian-day
  time-record-printer-format
  date-record-printer-format
  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-date-elements
  check-date-compatible-timezone-offsets
  error-incompatible-time-types
  error-convert
  error-date-compatible-timezone
  ;;Private
  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:modified-julian-day->time-utc
  tm:default-date-adjust-integer)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (only srfi-1 fold))
(import (only (chicken io) read-line))
(import (only (chicken read-syntax) define-reader-ctor))
(import (only (chicken gc) current-gc-milliseconds))
(import (only (chicken format) format))
(import (only (chicken time) cpu-time current-seconds current-milliseconds))
(import (only (chicken time posix) seconds->utc-time))
(import (only (chicken string) conc))
(import (only (chicken port) with-input-from-port with-input-from-string))
(import locale)
(import record-variants)
(import type-checks)
(import type-errors)
(import 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))
        (if (fixnum? x)
          x
          (inexact->exact (floor 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) SEC/YR))

;; A table of leap seconds
;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary.
;; See "https://www.ietf.org/timezones/data/leap-seconds.list"
;; seconds since 1900 - seconds since 1972 = 2208988800
;; 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
  '((1483228800 . 37)
    (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:...

;#| ;dependency
(define-constant srfi-19-time 'srfi-19-time)
(define-record-type-variant srfi-19-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!) )
;|#
#; ;no (define-record-type srfi-19-time
(define-record-type srfi-19-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? obj)
  (%time? obj) )

;; 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 "#,(srfi-19-time ~A ~A ~A)")
(define-constant TIME-FORMAT-BRACKET "#<srfi-19-time ~A ~A ~A>")

(define time-record-printer-format (make-parameter 'SRFI-10
  (lambda (x)
    (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
      x
      (begin
        (warning 'time-record-printer-format "invalid format" x)
        (time-record-printer-format) ) ) ) ) )

(define (time-record-printer-format-string)
  (case (time-record-printer-format)
    ((srfi-10 SRFI-10)
      TIME-FORMAT-SRFI-10 )
    (else
      TIME-FORMAT-BRACKET ) ) )

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

;SRFI-10
(define-reader-ctor 'srfi-19-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) )

(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 Officially Adopted!
          (not (fx= (fxmod yr 4000) 0))
          (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) ) ) ) )

;;

;#| ;dependency
(define-constant srfi-19-date 'srfi-19-date)
(define-record-type-variant srfi-19-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!) )
;|#
#; ;no dependency
(define-record-type srfi-19-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? obj)
  (%date? obj) )

;;

(define-constant DATE-FORMAT-SRFI-10 "#,(srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)")
(define-constant DATE-FORMAT-BRACKET "#<srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A>")

(define date-record-printer-format (make-parameter 'SRFI-10
  (lambda (x)
    (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
      x
      (begin
        (warning 'date-record-printer-format "invalid format" x)
        (date-record-printer-format) ) ) ) ) )

(define (date-record-printer-format-string)
  (case (date-record-printer-format)
    ((srfi-10 SRFI-10)
      DATE-FORMAT-SRFI-10 )
    (else
      DATE-FORMAT-BRACKET ) ) )

(define-record-printer (srfi-19-date dat out)
  (format out (date-record-printer-format-string)
   (%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 'srfi-19-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
;but won't fit since needs srfi-19-support (%date-*)

;#\ ;dependency
(define-constant date-timezone-info 'date-timezone-info)
(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?) )
;|#
#; ;no dependency
(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 (date-timezone-info? obj)
  (%date-timezone-info? obj) )

(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))
      (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)
  ;propagate the error
  (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) )
      (X                (fx- (fx+ current-century n) current-year) ) )
      (if (fx<= X 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)

(: tm:week-day (fixnum fixnum fixnum --> fixnum))

;Tomohiko Sakamoto algorithm
;Determination of the day of the week
;
;Jan 1st 1 AD is a Monday in Gregorian calendar.
;So Jan 0th 1 AD is a Sunday [It does not exist technically].
;
;Every 4 years we have a leap year. But xy00 cannot be a leap unless xy divides 4 with remainder 0.
;y/4 - y/100 + y/400 : this gives the number of leap years from 1AD to the
;given year. As each year has 365 days (divides 7 with remainder 1), unless it
;is a leap year or the date is in Jan or Feb, the day of a given date changes
;by 1 each year. In other cases it increases by 2.
;y -= m<3 : If the month is not Jan or Feb, we do not count the 29th Feb (if
;it exists) of the given year.
;So y + y/4 - y/100 + y/400  gives the day of Jan 0th (Dec 31st of prev year)
;of the year. (This gives the remainder with 7 of  the number of days passed
;before the given year began.)
;
;Array t:  Number of days passed before the month 'm+1' begins.
;
;So t[m-1]+d is the number of days passed in year 'y' up to the given date.
;(y + y/4 - y/100 + y/400 + t[m-1] + d) % 7 is remainder of the number of days
;from Jan 0 1AD to the given date which will be the day (0=Sunday,6=Saturday).
;
;Description credits: Sai Teja Pratap (quora.com/How-does-Tomohiko-Sakamotos-Algorithm-work).
(define tm:week-day
  (let (
    (t #(0 3 2 5 0 3 5 1 4 6 2 4)) )
    (lambda (dy mn yr)
      (let (
        (yr (if (< mn 3) (fx- yr 1) yr)) )
        (modulo (+ yr (/ yr 4) (/ yr -100) (vector-ref t (- mn 1)) dy) DY/WK) ) ) ) )

(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))
    (timsecs
      (+
        (fx+
          (fx+
            (fx* hr SEC/HR)
            (fx+ (fx* min SEC/MIN) sec))
          (fxneg tzo))
        (/ ns NS/S))) )
    (+ (- jdn ONE-HALF) (/ timsecs 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:modified-julian-day->time-utc mjdn)
  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )

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

) ;module srfi-19-support