source: project/release/5/srfi-19/tags/4.4.2/srfi-19-tm.scm @ 38677

;;;; srfi-19-tm.scm  -*- Scheme -*-
;;;; 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
;;
;; - Forces module component of global time/date struct identifiers
;;
;; - Use of modulo vs remainder - differing sign problem

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

(;export
  tm:read-tai-utc-data
  tm:calc-second-before-leap-second-table
  tm:read-leap-second-table
  tm:any-time
  tm:some-time
  tm:as-some-time
  tm:time-type
  tm:time-nanosecond
  tm:time-second
  tm:time-type-set!
  tm:time-nanosecond-set!
  tm:time-second-set!
  tm:time?
  tm:make-time
  tm:copy-time
  tm:time-has-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-utc
  tm:current-time-tai
  tm:current-time-monotonic
  tm:current-time-thread
  tm:current-time-process
  tm:current-time-gc
  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
  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?
  tm:days-in-month
  tm:date-nanosecond
  tm:date-second
  tm:date-minute
  tm:date-hour
  tm:date-day
  tm:date-month
  tm:date-year
  tm:date-zone-offset
  tm:date-zone-name
  tm:date-dst?
  tm:date-wday
  tm:date-yday
  tm:date-jday
  tm:date-timezone-info?
  tm:date-timezone-info
  tm:date-nanosecond-set!
  tm:date-second-set!
  tm:date-minute-set!
  tm:date-hour-set!
  tm:date-day-set!
  tm:date-month-set!
  tm:date-year-set!
  tm:date-zone-offset-set!
  tm:make-incomplete-date
  tm:date?
  tm:make-date
  tm:copy-date
  tm:date-complete?
  tm:seconds->date/type
  tm:current-date
  tm:date-compare
  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
  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 (only (chicken io) read-line))
(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 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")

;-> integer, exact!
(define-syntax number->genint
  (syntax-rules ()
    ((number->genint ?x)
      (let ((x ?x))
        (if (fixnum? x) x
          (inexact->exact (floor x)) ) ) ) ) )

;-> integer, inexact or exact!
(define-syntax number->integer
  (syntax-rules ()
    ((number->integer ?x)
      (let ((x ?x))
        (if (integer? 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)

;;; Date TZ information extract

(define-record-type-variant *date-timezone-info-tag* (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?) )

;;; Constants

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

(define-constant TAI-EPOCH-YEAR 1970)

;; Used in julian calculation

(define-constant ONE-HALF 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-constant TAI-EPOCH-IN-JD 4881175/2)

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

(define-constant TAI-EPOCH-IN-MODIFIED-JD 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-constant LEAP-START (* (- 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:...

(define-record-type-variant *time-tag* (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!) )

;; Time to Date

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

;;

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

(define-inline (normalize-timeval t per)
  (quotient&remainder t per) )

(define-inline (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-sec ns)    (normalize-nanoseconds ns))
    ((sec-min sec)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
    ((min-hr min)   (normalize-timeval (+ min sec-min) MIN/HR))
    ((hr-dy hr)     (normalize-timeval (+ hr min-hr) HR/DY)) )
    (values ns sec min hr (+ dy hr-dy)) ) )

;; Output Argument CTORs

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

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

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

;;

(define (tm:time-type tim)
  (%time-type tim) )

(define (tm:time-second tim)
  (%time-second tim) )

(define (tm:time-nanosecond tim)
  (%time-nanosecond tim) )

(define (tm:time-type-set! tim typ)
  (%time-type-set! tim typ) )

(define (tm:time-nanosecond-set! tim ns)
  (%time-nanosecond-set! tim (number->integer ns)) )

(define (tm:time-second-set! tim sec)
  (%time-second-set! tim (number->integer sec)) )

(define (tm:time? obj)
  (%time? obj) )

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

(define (tm:copy-time tim)
  (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) )

(define (tm:time-has-type? tim tt)
  (eq? tt (%time-type tim)) )

;; Rem & Quo of nanoseconds per second

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

;; Seconds Conversion

;;

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

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

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

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

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

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

(define (tm:seconds->time-values sec)
  (let* (
    (isec (number->integer sec))
    (ns (number->integer (round (* (- sec isec) NS/S)))) )
    (values ns isec) ) )

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

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

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

;; Current time routines

(cond-expand
  (unix
    ;add back C_startup_time_seconds
    (define tm:current-time-values
      (let ((t0 (current-seconds)))
        (lambda ()
          (let-values (((s ms) (quotient&remainder (current-milliseconds) MS/S)))
            (values (* ms MS/NS) (+ t0 s)) ) ) ) ) )
  (else
    (define (tm:current-time-values)
      (values 0 (current-seconds)) ) ) )

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

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

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

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

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

(define (tm:current-time-gc)
  (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)
  MS/NS )

;; Time Comparison

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

(define (tm:time=? tim1 tim2)
  (and
    (= (%time-second tim1) (%time-second tim2))
    (= (%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))
      (< (%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))
      (<= (%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))
      (> (%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))
      (>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )

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

(define-syntax tm:time-min
        (syntax-rules ()
                ((tm:time-min ?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 (
          ((sec ns) (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 (
    ((sec ns) (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 (
    ((sec ns) (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 (
          ((sec ns) (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 (
    ((sec ns) (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 (tm:time-abs tim1 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-second tim))) (zero? (tm:time-nanosecond 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 (tm:time-tai->time-monotonic timin 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 (tm:time-utc->time-monotonic timin timout)
  (let ((ntim (tm:time-utc->time-tai timin timout)))
    (%time-type-set! ntim 'monotonic)
    ntim ) )

(define (tm:time-monotonic->time-tai timin 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 (tm:time-monotonic->time-utc timin 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 (tm:leap-year? yr)
  (and
    #; ;!NOT Officially Adopted!
    (not (zero? (modulo yr 4000)))
    (or
      (zero? (modulo yr 400))
      (and
        (zero? (modulo yr 4))
        (not (zero? (modulo yr 100)))))) )

;; 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-inline (days/month yr)
  (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+) )

(define (tm:leap-day? dy mn)
  (= dy (vector-ref +leap-year-dys/mn+ mn)) )

(define (tm:days-in-month yr mn)
  (vector-ref (days/month yr) mn) )

;;; Date Object (Public Mutable)

(define-record-type-variant *date-tag* (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!) )

;;

;;; Getters

(define (tm:date-nanosecond dat)
  (%date-nanosecond dat) )

(define (tm:date-second dat)
  (%date-second dat) )

(define (tm:date-minute dat)
  (%date-minute dat) )

(define (tm:date-hour dat)
  (%date-hour dat) )

(define (tm:date-day dat)
  (%date-day dat) )

(define (tm:date-month dat)
  (%date-month dat) )

(define (tm:date-year dat)
  (%date-year dat) )

(define (tm:date-zone-offset dat)
  (%date-zone-offset dat) )

(define (tm:date-zone-name dat)
  (%date-zone-name dat) )

(define (tm:date-dst? dat)
  (%date-dst? dat) )

(define (tm:date-wday dat)
  (%date-wday dat) )

(define (tm:date-yday dat)
  (%date-yday dat) )

(define (tm:date-jday dat)
  (%date-jday dat) )

;;; Setters

(define (tm:date-nanosecond-set! dat x)
  (%date-nanosecond-set! dat (number->integer x)) )

(define (tm:date-second-set! dat x)
  (%date-second-set! dat (number->integer x)) )

(define (tm:date-minute-set! dat x)
  (%date-minute-set! dat (number->integer x)) )

(define (tm:date-hour-set! dat x)
  (%date-hour-set! dat (number->integer x)) )

(define (tm:date-day-set! dat x)
  (%date-day-set! dat (number->integer x)) )

(define (tm:date-month-set! dat x)
  (%date-month-set! dat (number->integer x)) )

(define (tm:date-year-set! dat x)
  (%date-year-set! dat (number->integer x)) )

(define (tm:date-zone-offset-set! dat x)
  (%date-zone-offset-set! dat (number->integer x)) )

;; Date TZ information extract

(define (tm:date-timezone-info? obj)
  (%date-timezone-info? obj) )

(define (tm:date-timezone-info dat)
  (%make-date-timezone-info
    (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) )

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

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

(define (tm:make-incomplete-date)
  (%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 (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
  (%make-date
    (number->integer ns)
    (number->integer sec) (number->integer min) (number->integer hr)
    (number->integer dy) (number->integer mn) (number->integer yr)
    (number->integer tzo) tzn dstf
    wdy ydy jdy) )

(define (tm:copy-date 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:date-complete? dat)
  (and
    (%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)) )

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

(define (tm:current-date tzi)
  (tm:time-utc->date (tm:current-time-utc) tzi) )

;; Date Comparison

(define (tm:date-compare dat1 dat2)
  (let ((dif (- (%date-year dat1) (%date-year dat2))))
    (if (not (zero? dif))
      dif
      (let ((dif (- (%date-month dat1) (%date-month dat2))))
        (if (not (zero? dif))
          dif
          (let ((dif (- (%date-day dat1) (%date-day dat2))))
            (if (not (zero? dif))
              dif
              (let ((dif (- (%date-hour dat1) (%date-hour dat2))))
                (if (not (zero? dif))
                  dif
                  (let ((dif (- (%date-minute dat1) (%date-minute dat2))))
                    (if (not (zero? dif))
                      dif
                      (let ((dif (- (%date-second dat1) (%date-second dat2))))
                        (if (not (zero? dif))
                          dif
                          (- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) )

;; Gives the seconds/day/month/year

(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 (- JDYR) (quotient m 10))) )
    (values ;seconds date month year
     (* (- jdn days) SEC/DY)
     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
     (+ m 3 (* (- MN/YR) (quotient m 10)))
     (if (>= 0 y) (- 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 (optional-tzinfo tzi)
  (cond
    ((%date-timezone-info? tzi)
      (values
        (%date-timezone-info-offset tzi)
        (%date-timezone-info-name tzi)
        (%date-timezone-info-dst? tzi)) )
    ((timezone-components? tzi)
      (values
        (timezone-locale-offset tzi)
        (timezone-locale-name tzi)
        (timezone-locale-dst? tzi)) )
    (else
      ;assume an offset
      (values tzi #f #f) ) ) )

(define (tm:time-utc->date tim tzi)
  (let-values (
    ((tzo tzn dstf) (optional-tzinfo tzi)) )
    (let*-values (
      ((secs dy mn yr)
        (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo)))
      ((hr rem)
        (quotient&remainder secs SEC/HR))
      ((min sec)
        (quotient&remainder 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 (quotient (- 14 mn) MN/YR))
    (b (+ yr JDYR (- a)))
    (y (if (negative? yr) (+ 1 b) b)) ;BCE?
    (m (+ mn (* a MN/YR) -3)))
    (+ dy
      (quotient (+ (* 153 m) 2) 5)
      (* y DY/YR)
      (quotient y 4)
      (quotient y -100)
      (quotient 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
        (+ (* hr SEC/HR) (* min SEC/MIN) sec (- 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 (= 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 (< n 0) (>= n 100))
    n
    (let* (
      (current-year     (%date-year (tm:current-date tzi)) )
      (current-century  (* (quotient current-year 100) 100) )
      (X                (+ current-century n (- current-year)) ) )
      (if (<= X 50)
        (+ current-century n)
        (+ (- 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 (+ dy (vector-ref +cumulative-month-days+ mn))))
    (if (and (tm:leap-year? yr) (< 2 mn))
      (+ 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

;; 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) (- 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 (quotient (- 14 mn) MN/YR))
    (y (- yr a))
    (m (- (+ mn (* a MN/YR)) 2)) )
    (modulo
      (+ dy y
         (- (quotient y 4) (quotient y 100))
         (quotient y 400)
         (quotient (* 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)
  (modulo
    (- 1st-weekday (tm:week-day 1 1 (%date-year dat)))
    DY/WK) )

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

;; Julian-day Operations

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

;; Date to Julian-day

(define (tm:jd-time->seconds ns sec min hr tzo)
  (+ (* hr SEC/HR) (* min SEC/MIN) sec (- tzo) (/ ns NS/S)) )

; 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
      (tm:jd-time->seconds ns sec min hr tzo)) )
    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )

(define (tm:date->julian-day 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 (tm:julian-day->time-utc jdn)
  (let-values (((sec ns) (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-tm