;;;; srfi-19-support.scm ;;;; Chicken port, Kon Lovett, Dec '05 ;; SRFI-19: Time Data Types and Procedures. ;; ;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. ;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved. ;; ;; This document and translations of it may be copied and furnished to others, ;; and derivative works that comment on or otherwise explain it or assist in its ;; implementation may be prepared, copied, published and distributed, in whole or ;; in part, without restriction of any kind, provided that the above copyright ;; notice and this paragraph are included on all such copies and derivative works. ;; However, this document itself may not be modified in any way, such as by ;; removing the copyright notice or references to the Scheme Request For ;; Implementation process or editors, except as needed for the purpose of ;; developing SRFIs in which case the procedures for copyrights defined in the SRFI ;; process must be followed, or as required to translate it into languages other ;; than English. ;; ;; The limited permissions granted above are perpetual and will not be revoked ;; by the authors or their successors or assigns. ;; ;; This document and the information contained herein is provided on an "AS IS" ;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE ;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF ;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. ;; Issues ;; ;; - Gregorian calendar only. ;; ;; - Initialization is scattered throughout the code, so converting to a module will ;; involve some search. ;; ;; - Some errors have incorrect procedure labels (not the top-level loc) ;; Bugs ;; ;; - The 'date-dst?' field is problimatic. It is only valid on certain ;; platforms & only when current. A past or future date will not have this ;; field correct! ;; ;; - Time -> Date conversion takes account of the CURRENT daylight saving time state, ;; NOT the state of the converted date. ;; Notes ;; ;; - There is no year zero. So when converting from a BCE year on the sign of the year ;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713! ;; ;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from ;; UTC & a subtracted offset is "towards" UTC. ;; ;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every ;; conversion procedure. (include "chicken-primitive-object-inlines") (module srfi-19-support (;export ; time? time-type? time-seconds? time-nanoseconds? clock-type? date? date-nanoseconds? date-seconds? date-minutes? date-hours? date-day? date-month? date-year? week-day? julian-day? ; check-time check-time-type check-time-seconds check-time-nanoseconds check-raw-seconds check-raw-milliseconds check-time-has-type check-time-and-type check-duration check-time-elements #;check-times check-time-binop check-time-compare check-time-aritmetic check-clock-type check-date check-date-nanoseconds check-date-seconds check-date-minutes check-date-hours check-date-day check-date-month check-date-year check-date-elements check-date-compatible-timezone-offsets check-week-day check-julian-day ; error-time error-time-type error-time-seconds error-time-nanoseconds error-incompatible-time-types error-clock-type error-convert error-date error-date-nanoseconds error-date-seconds error-date-minutes error-date-hours error-date-day error-date-month error-date-year error-date-compatible-timezone error-week-day error-julian-day ; tm:read-tai-utc-data tm:calc-second-before-leap-second-table tm:read-leap-second-table tm:any-time 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: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-values 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-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-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: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-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:make-date tm:copy-date tm:seconds->date/type tm:current-date tm:date-compare tm:decode-julian-day-number tm:decode-julian-day-number tm:seconds->julian-day-number tm:tai-before-leap-second? tm:time-utc->date tm:time-utc->date tm:time-tai->date tm:time->date tm:encode-julian-day-number tm:encode-julian-day-number tm:date->time-utc 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: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) (import (except scheme + - * / remainder quotient abs round floor truncate real? integer? inexact? zero? negative? positive? = <= >= < > inexact->exact exact->inexact string->number) chicken (only posix seconds->utc-time) (only extras format read-line) (only data-structures conc) (only ports with-input-from-port with-input-from-string) (only numbers + - * / remainder quotient abs round floor truncate real? integer? inexact? zero? negative? positive? = <= >= < > inexact->exact exact->inexact string->number) locale record-variants type-checks type-errors srfi-19-timezone) (require-library srfi-18 posix extras ports numbers locale record-variants type-checks type-errors srfi-19-timezone) ;;; (include "srfi-19-common") ;;; 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) (receive (ums sms) (cpu-time) (+ ums sms))) ;FIXME needs a srfi-18 extension (define current-thread-milliseconds current-process-milliseconds) ;;; Constants ;; TAI-EPOCH: 1 January 1970 CE at 00:00:00 UTC (define-constant TAI-EPOCH-YEAR 1970) ;(Chicken reader doesn't grok ratios w/o numbers egg at compile time.) ;; Used in julian calculation (define ONE-HALF (string->number "1/2")) ;; Julian Day 0 = 1 January 4713 BCE at 12:00:00 UTC (Julian proleptic calendar) ;; Julian Day 0 = 24 November 4714 BCE at 12:00:00 UTC (Gregorian proleptic calendar) (define TAI-EPOCH-IN-JD (string->number "4881175/2")) ;; Modified Julian Day 0 = 17 Nov 1858 CE at 00:00:00 UTC ;; Number of days less than a julian day. (define TAI-EPOCH-IN-MODIFIED-JD (string->number "4800001/2")) ;; Julian conversion base century (define-constant JDYR 4800) ;;; Leap Seconds ;; First leap year after epoch (define-constant FIRST-LEAP-YEAR 1972) ;; Number of seconds after epoch of first leap year (define LEAP-START (%fx* (%fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR) (%fx* DY/YR SEC/DY))) ;; A table of leap seconds ;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary. ;; Each entry is (utc seconds since epoch . # seconds to add for tai) ;; Note they go higher (2009) to lower (1972). (define tm:leap-second-table '((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-inline (leap-second-delta utc-seconds) (leap-second-delta* utc-seconds (<= (%car leap-second-item) utc-seconds)) ) ;; Going from tai seconds to utc seconds ... (define-inline (leap-second-neg-delta tai-seconds) (leap-second-delta* tai-seconds (<= (%cdr leap-second-item) (- tai-seconds (%car leap-second-item)))) ) ;;; Time Object (Public Mutable) ;; There are 3 kinds of time record procedures: ;; *... - generated ;; tm:... - argument processing then *... ;; ... - argument checking then tm:... (define-record-type-variant time (unchecked inline unsafe) (%make-time tt ns sec) %time? (tt %time-type %time-type-set!) (ns %time-nanosecond %time-nanosecond-set!) (sec %time-second %time-second-set!) ) (define (time? obj) (%time? obj)) ;; (define-record-printer (time tim out) (format out "#,(time ~A ~A ~A)" (%time-type tim) (%time-nanosecond tim) (%time-second tim)) ) (define-reader-ctor 'time (lambda (tt ns sec) (%make-time tt ns sec))) ;; (define (time-type? obj) (%memq obj '(monotonic utc tai gc duration process thread))) (define (time-seconds? obj) (integer? obj)) (define (time-nanoseconds? obj) (and (%fixnum? obj) (%fx< -NS/S obj) (%fx< obj NS/S))) ;; (define-check+error-type time %time?) (define-check+error-type time-type) (define-check+error-type time-seconds) (define-check+error-type time-nanoseconds) ;; Output Argument CTORs ;Used to create an output time record where all fields will be set later ; (define (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 (gennum->fixnum ns))) (define (tm:time-second-set! tim sec) (%time-second-set! tim (genint->fixnum sec))) (define (tm:make-time tt ns sec) (%make-time tt (gennum->fixnum ns) (genint->fixnum 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) (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 (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 NS/MS) (* microseconds NS/MuS) nanoseconds)) (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) ) (receive (ns sec) (tm:nanoseconds->time-values nanos) (values ns (+ secs sec)) ) ) ) (define (tm:seconds->time-values sec) (let* ((tsec (genint->fixnum (truncate sec))) (ns (gennum->fixnum (exact->inexact (round (* (- sec tsec) NS/S))))) ) (values ns tsec) ) ) (define (tm:milliseconds->time-values ms) (let ((ns (%fx* (gennum->fixnum (remainder ms MS/S)) NS/MS)) (sec (quotient ms MS/S)) ) (values ns sec) ) ) (define (tm:milliseconds->time ms tt) (receive (ns sec) (tm:milliseconds->time-values ms) (tm:make-time tt ns sec) ) ) (define (tm:seconds->time sec tt) (receive (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-inline (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 (tm:current-time-values) (values (tm:current-nanoseconds) (current-seconds))) (define (tm:current-time-utc) (receive (ns sec) (tm:current-time-values) (tm:make-time 'utc ns sec)) ) (define (tm:current-time-tai) (receive (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) NS/MS ) ;; Specialized Time Parameter Checking (define (error-incompatible-time-types loc tt1 tt2) (signal-type-error loc "incompatible time-types" tt1 tt2) ) (define (check-time-has-type loc tim tt) (unless (tm:time-has-type? tim tt) (error-incompatible-time-types loc (%time-type tim) tt) ) ) (define (check-time-and-type loc tim tt) (check-time loc tim) (check-time-has-type loc tim tt) ) (define (check-duration loc obj) (check-time-and-type loc obj 'duration)) (define (check-time-elements loc obj1 obj2 obj3) (check-time-type loc obj1) (check-time-nanoseconds loc obj2) (check-time-seconds loc obj3) ) #; ;UNUSED (define (check-times loc objs) (for-each (cut check-time loc <>) objs)) (define (check-time-binop loc obj1 obj2) (check-time loc obj1) (check-time loc obj2) ) (define (check-time-compare loc obj1 obj2) (check-time-binop loc obj1 obj2) (check-time-has-type loc obj1 (%time-type obj2)) ) (define (check-time-aritmetic loc tim dur) (check-time loc tim) (check-duration loc dur) ) ;; Time Comparison (define (tm:time-compare tim1 tim2) (let ((dif (- (%time-second tim1) (%time-second tim2)))) (if (not (zero? dif)) dif (%fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) ) (define (tm:time=? tim1 tim2) (and (= (%time-second tim1) (%time-second tim2)) (%fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) ) (define (tm:time? tim1 tim2) (or (> (%time-second tim1) (%time-second tim2)) (and (= (%time-second tim1) (%time-second tim2)) (%fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) ) (define (tm:time>=? tim1 tim2) (or (> (%time-second tim1) (%time-second tim2)) (and (= (%time-second tim1) (%time-second tim2)) (%fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) ) (define (tm:time-max tim1 tim2) (if (tm:time>? tim1 tim2) tim1 tim2) ) (define (tm:time-min tim1 tim2) (if (tm:timetime-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) (receive (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) (receive (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) (receive (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) (receive (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 (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 ) ;; 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? year) (and (not (%fx= (%fxmod year 4000) 0)) ;Not officially adopted! (or (%fx= (%fxmod year 400) 0) (and (%fx= (%fxmod year 4) 0) (not (%fx= (%fxmod year 100) 0))))) ) ;; Days per Month (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 (tm:days-in-month yr mn) (%vector-ref (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+) mn) ) ;; (define-record-type-variant date (unchecked inline unsafe) (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy) %date? (ns %date-nanosecond %date-nanosecond-set!) (sec %date-second %date-second-set!) (min %date-minute %date-minute-set!) (hr %date-hour %date-hour-set!) (dy %date-day %date-day-set!) (mn %date-month %date-month-set!) (yr %date-year %date-year-set!) (tzo %date-zone-offset %date-zone-offset-set!) ;; non-srfi extn (tzn %date-zone-name %date-zone-name-set!) (dstf %date-dst? %date-dst-set!) (wdy %date-wday %date-wday-set!) (ydy %date-yday %date-yday-set!) (jdy %date-jday %date-jday-set!) ) (define (date? obj) (%date? obj)) ;; (define-record-printer (date dat out) (format out "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)" (%date-nanosecond dat) (%date-second dat) (%date-minute dat) (%date-hour dat) (%date-day dat) (%date-month dat) (%date-year dat) (%date-zone-offset dat) (%date-zone-name dat) (%date-dst? dat) (%date-wday dat) (%date-yday dat) (%date-jday dat)) ) (define-reader-ctor 'date (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy) (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy))) ; Nanoseconds in [0 NS/S-1] (define (date-nanoseconds? obj) (and (%fixnum? obj) (%fx<= 0 obj) (%fx< obj NS/S))) ; Seconds in [0 SEC/MIN] ; SEC/MIN legal due to leap second (define (date-seconds? obj) (and (%fixnum? obj) (%fx<= 0 obj) (%fx<= obj SEC/MIN))) ; Minutes in [0 SEC/MIN-1] (define (date-minutes? obj) (and (%fixnum? obj) (and (%fx<= 0 obj) (%fx< obj SEC/MIN)))) ; Hours in [0 HR/DY-1] (define (date-hours? obj) (and (%fixnum? obj) (and (%fx<= 0 obj) (%fx< obj HR/DY)))) ; Days in [1 28/29/30/31] - depending on month & year (define (date-day? obj mn yr) (and (%fixnum? obj) (%fx<= 1 obj) (%fx<= obj (tm:days-in-month yr mn)))) ; Months in [1 MN/YR] (define (date-month? 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?) ;; (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)) (define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (gennum->fixnum x))) (define (tm:date-second-set! dat x) (%date-second-set! dat (gennum->fixnum x))) (define (tm:date-minute-set! dat x) (%date-minute-set! dat (gennum->fixnum x))) (define (tm:date-hour-set! dat x) (%date-hour-set! dat (gennum->fixnum x))) (define (tm:date-day-set! dat x) (%date-day-set! dat (gennum->fixnum x))) (define (tm:date-month-set! dat x) (%date-month-set! dat (gennum->fixnum x))) (define (tm:date-year-set! dat x) (%date-year-set! dat (gennum->fixnum x))) (define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (gennum->fixnum x))) ;; Date TZ information extract ;Belongs in srfi-19-timezone (define-record-type-variant date-timezone-info (unchecked inline unsafe) (%make-date-timezone-info n o d) %date-timezone-info? (n %date-timezone-info-name) (o %date-timezone-info-offset) (d %date-timezone-info-dst?) ) (define (tm:date-timezone-info 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 (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 (gennum->fixnum ns) (gennum->fixnum sec) (gennum->fixnum min) (gennum->fixnum hr) (gennum->fixnum dy) (gennum->fixnum mn) (gennum->fixnum yr) (gennum->fixnum 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:seconds->date/type sec tzc) (let* ((fsec (exact->inexact sec)) (isec (truncate 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 (tm:current-date tzi) (tm:time-utc->date (tm:current-time-utc) tzi)) ;; Date Comparison (define (tm:date-compare dat1 dat2) (let ((dif (%fx- (%date-year dat1) (%date-year dat2)))) (if (not (%fx= 0 dif)) dif (let ((dif (%fx- (%date-month dat1) (%date-month dat2)))) (if (not (%fx= 0 dif)) dif (let ((dif (%fx- (%date-day dat1) (%date-day dat2)))) (if (not (%fx= 0 dif)) dif (let ((dif (%fx- (%date-hour dat1) (%date-hour dat2)))) (if (not (%fx= 0 dif)) dif (let ((dif (%fx- (%date-minute dat1) (%date-minute dat2)))) (if (not (%fx= 0 dif)) dif (let ((dif (%fx- (%date-second dat1) (%date-second dat2)))) (if (not (%fx= 0 dif)) dif (%fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) ;; Time to Date (define ONE-SECOND-DURATION (%make-time 'duration 0 1)) ;; Gives the seconds/day/month/year #; ;Original (define (tm:decode-julian-day-number jdn) (let* ((days (truncate jdn)) (a (+ days 32044)) (b (quotient (+ (* 4 a) 3) 146097)) (c (- a (quotient (* 146097 b) 4))) (d (quotient (+ (* 4 c) 3) 1461)) (e (- c (quotient (* 1461 d) 4))) (m (quotient (+ (* 5 e) 2) 153)) (y (+ (* 100 b) d -4800 (quotient m 10)))) (values ; seconds date month year (* (- jdn days) 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 (gennum->fixnum (truncate 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 (gennum->fixnum (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)) ) ) (receive (secs dy mn yr) (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo)) (let ((hr (%fx/ secs SEC/HR)) (rem (%fxmod secs SEC/HR))) (let ((min (%fx/ rem SEC/MIN)) (sec (%fxmod rem SEC/MIN))) (tm:make-date (%time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) ) (define (tm:time-tai->date tim tzi) (let ((tm-utc (tm:time-tai->time-utc tim (tm:any-time)))) (if (not (tm:tai-before-leap-second? tim)) (tm:time-utc->date tm-utc tzi) ; else time is *right* before the leap, we need to pretend to subtract a second ... (let ((dat (tm:time-utc->date (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi))) (%date-second-set! dat SEC/MIN) ; Note full minute! dat ) ) ) ) (define (tm:time->date tim tzi) (case (%time-type tim) ((monotonic) (tm:time-utc->date tim tzi)) ((utc) (tm:time-utc->date tim tzi)) ((tai) (tm:time-tai->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 ((monotonic) (tm:date->time-monotonic dat)) ((utc) (tm:date->time-utc dat)) ((tai) (tm:date->time-tai dat)) (else #f) ) ) ;; Given a 'two digit' number, find the year within 50 years +/- (define (tm:natural-year n tzi) (if (or (%fx< n 0) (%fx>= n 100)) n (let* ((current-year (%date-year (tm:current-date tzi))) (current-century (%fx* (%fx/ current-year 100) 100))) (if (%fx<= (%fx- (%fx+ current-century n) current-year) 50) (%fx+ current-century n) (%fx+ (%fx- current-century 100) n) ) ) ) ) ;; Day of Year (define +cumulative-month-days+ '#(0 0 31 59 90 120 151 181 212 243 273 304 334)) (define (tm:year-day dy mn yr) (let ((yrdy (%fx+ dy (%vector-ref +cumulative-month-days+ mn)))) (if (and (tm:leap-year? yr) (%fx< 2 mn)) (%fx+ yrdy 1) yrdy ) ) ) (define (tm:cache-date-year-day dat) (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat)))) (%date-yday-set! dat yrdy) yrdy ) ) (define (tm:date-year-day dat) (or (%date-yday dat) (tm:cache-date-year-day dat) ) ) ;; Week Day (define (week-day? obj) (and (%fixnum? obj) (%fx<= 0 obj) (%fx<= obj 6))) (define-check+error-type week-day) ;; Using Gregorian Calendar (from Calendar FAQ) (define (tm:week-day dy mn yr) (let* ((a (%fx/ (%fx- 14 mn) MN/YR)) (y (%fx- yr a)) (m (%fx- (%fx+ mn (%fx* a MN/YR)) 2))) (%fxmod (%fx+ (%fx+ dy y) (%fx+ (%fx- (%fx/ y 4) (%fx/ y 100)) (%fx+ (%fx/ y 400) (%fx/ (%fx* m DY/MN) MN/YR)))) DY/WK) ) ) (define (tm:cache-date-week-day dat) (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat)))) (%date-wday-set! dat wdy) wdy ) ) (define (tm:date-week-day dat) (or (%date-wday dat) (tm:cache-date-week-day dat) ) ) (define (tm:days-before-first-week dat 1st-weekday) (%fxmod (%fx- 1st-weekday (tm:week-day 1 1 (%date-year dat))) DY/WK) ) (define (tm:date-week-number dat 1st-weekday) (%fx/ (%fx- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday)) DY/WK) ) ;; Julian-day Operations (define (julian-day? obj) (real? obj)) (define-check+error-type julian-day) (define (tm:julian-day->modified-julian-day mjdn) (- mjdn TAI-EPOCH-IN-MODIFIED-JD)) ;; Date to Julian-day ; Does the nanoseconds value contribute anything to the julian day? ; The range is < 1 second here (but not in the reference). (define (tm:julian-day ns sec min hr dy mn yr tzo) (+ (- (tm:encode-julian-day-number dy mn yr) ONE-HALF) (/ (+ (%fx+ (%fx+ (%fx* hr SEC/HR) (%fx+ (%fx* min SEC/MIN) sec)) (%fxneg tzo)) (/ ns NS/S)) SEC/DY)) ) #; ; inexact version (define (tm:julian-day ns sec min hr dy mn yr tzo) (%fp+ (%fp- (exact->inexact (tm:encode-julian-day-number dy mn yr)) iONE-HALF) (%fp/ (%fp+ (exact->inexact (%fx+ (%fx+ (%fx* hr SEC/HR) (%fx+ (%fx* min SEC/MIN) sec)) (%fxneg tzo))) (%fp/ (exact->inexact ns) iNS/S)) iSEC/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 tim) tm:time-tai->julian-day) (define (tm:time->julian-day tim) (case (%time-type tim) ((monotonic) (tm:time-monotonic->julian-day tim)) ((utc) (tm:time-utc->julian-day tim)) ((tai) (tm:time-tai->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) ((monotonic) (tm:time-monotonic->modified-julian-day tim)) ((utc) (tm:time-utc->modified-julian-day tim)) ((tai) (tm:time-tai->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) (receive (ns sec) (tm:julian-day->time-values jdn) (tm:make-time 'time-utc ns sec) ) ) ) ;module srfi-19-support