source: project/release/5/srfi-19/trunk/srfi-19-tm.scm @ 38336

Last change on this file since 38336 was 38336, checked in by Kon Lovett, 14 months ago

use remainder not modulo (dividend always +, sign of divisor significant), use quotient&remainder, add tz format test

File size: 39.0 KB
Line 
1;;;; srfi-19-tm.scm  -*- Scheme -*-
2;;;; Chicken port, Kon Lovett, Dec '05
3
4;; SRFI-19: Time Data Types and Procedures.
5;;
6;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
7;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
8;;
9;; This document and translations of it may be copied and furnished to others,
10;; and derivative works that comment on or otherwise explain it or assist in its
11;; implementation may be prepared, copied, published and distributed, in whole or
12;; in part, without restriction of any kind, provided that the above copyright
13;; notice and this paragraph are included on all such copies and derivative works.
14;; However, this document itself may not be modified in any way, such as by
15;; removing the copyright notice or references to the Scheme Request For
16;; Implementation process or editors, except as needed for the purpose of
17;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
18;; process must be followed, or as required to translate it into languages other
19;; than English.
20;;
21;; The limited permissions granted above are perpetual and will not be revoked
22;; by the authors or their successors or assigns.
23;;
24;; This document and the information contained herein is provided on an "AS IS"
25;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
26;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
27;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
28;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
29
30;; Issues
31;;
32;; - Gregorian calendar only.
33;;
34;; - Initialization is scattered throughout the code, so converting to a module will
35;; involve some search.
36;;
37;; - Some errors have incorrect procedure labels (not the top-level loc)
38;;
39;; - The Private API but must be visible because of exported syntax
40;;
41;; - Forces module component of global time/date struct identifiers
42;;
43;; - Use of modulo vs remainder - differing sign problem
44
45;; Bugs
46;;
47;; - The 'date-dst?' field is problimatic. It is only valid on certain
48;; platforms & only when current. A past or future date will not have this
49;; field correct!
50;;
51;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
52;; NOT the state of the converted date.
53
54;; Notes
55;;
56;; - There is no year zero. So when converting from a BCE year on the sign of the year
57;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
58;;
59;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
60;; UTC & a subtracted offset is "towards" UTC.
61;;
62;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
63;; conversion procedure.
64
65(module srfi-19-tm
66
67(;export
68  tm:read-tai-utc-data
69  tm:calc-second-before-leap-second-table
70  tm:read-leap-second-table
71  tm:any-time
72  tm:some-time
73  tm:as-some-time
74  tm:time-type
75  tm:time-nanosecond
76  tm:time-second
77  tm:time-type-set!
78  tm:time-nanosecond-set!
79  tm:time-second-set!
80  tm:time?
81  tm:make-time
82  tm:copy-time
83  tm:time-has-type?
84  tm:nanoseconds->time-values
85  tm:time->nanoseconds
86  tm:time->milliseconds
87  tm:nanoseconds->seconds
88  tm:milliseconds->seconds
89  tm:time->seconds
90  tm:duration-elements->time-values
91  tm:milliseconds->time-values
92  tm:seconds->time-values
93  tm:seconds->time
94  tm:current-time-values
95  tm:current-time-utc
96  tm:current-time-tai
97  tm:current-time-monotonic
98  tm:current-time-thread
99  tm:current-time-process
100  tm:current-time-gc
101  tm:time-resolution
102  tm:time-compare
103  tm:time=?
104  tm:time<?
105  tm:time<=?
106  tm:time>?
107  tm:time>=?
108  tm:time-max
109  tm:time-min
110  tm:time-difference
111  tm:add-duration
112  tm:subtract-duration
113  tm:divide-duration
114  tm:multiply-duration
115  tm:time-abs
116  tm:time-negate
117  tm:time-zero? tm:time-positive? tm:time-negative?
118  tm:time-tai->time-utc
119  tm:time-tai->time-monotonic
120  tm:time-utc->time-tai
121  tm:time-utc->time-monotonic
122  tm:time-monotonic->time-tai
123  tm:time-monotonic->time-utc
124  tm:leap-year?
125  tm:leap-day?
126  tm:days-in-month
127  tm:date-nanosecond
128  tm:date-second
129  tm:date-minute
130  tm:date-hour
131  tm:date-day
132  tm:date-month
133  tm:date-year
134  tm:date-zone-offset
135  tm:date-zone-name
136  tm:date-dst?
137  tm:date-wday
138  tm:date-yday
139  tm:date-jday
140  tm:date-timezone-info?
141  tm:date-timezone-info
142  tm:date-nanosecond-set!
143  tm:date-second-set!
144  tm:date-minute-set!
145  tm:date-hour-set!
146  tm:date-day-set!
147  tm:date-month-set!
148  tm:date-year-set!
149  tm:date-zone-offset-set!
150  tm:make-incomplete-date
151  tm:date?
152  tm:make-date
153  tm:copy-date
154  tm:date-complete?
155  tm:seconds->date/type
156  tm:current-date
157  tm:date-compare
158  tm:decode-julian-day-number
159  tm:seconds->julian-day-number
160  tm:tai-before-leap-second?
161  tm:time-utc->date
162  tm:time-tai->date
163  tm:time->date
164  tm:encode-julian-day-number
165  tm:date->time-utc
166  tm:date->time-tai
167  tm:date->time-monotonic
168  tm:date->time
169  tm:natural-year
170  tm:year-day
171  tm:date-year-day
172  tm:week-day
173  tm:days-before-first-week
174  tm:date-week-day
175  tm:date-week-number
176  tm:julian-day->modified-julian-day
177  tm:julian-day
178  tm:date->julian-day
179  tm:seconds->julian-day
180  tm:time-utc->julian-day
181  tm:time-tai->julian-day
182  tm:time-monotonic->julian-day
183  tm:time->julian-day
184  tm:time-utc->modified-julian-day
185  tm:time-tai->modified-julian-day
186  tm:time-monotonic->modified-julian-day
187  tm:time->modified-julian-day
188  tm:julian-day->nanoseconds
189  tm:julian-day->time-values
190  tm:modified-julian-day->julian-day
191  tm:julian-day->time-utc
192  tm:modified-julian-day->time-utc
193  tm:default-date-adjust-integer)
194
195(import scheme)
196(import (chicken base))
197(import (chicken type))
198(import (only (chicken io) read-line))
199(import (only (chicken gc) current-gc-milliseconds))
200(import (only (chicken format) format))
201(import (only (chicken time) cpu-time current-seconds current-milliseconds))
202(import (only (chicken time posix) seconds->utc-time))
203(import (only (chicken port) with-input-from-port with-input-from-string))
204(import locale)
205(import record-variants)
206(import type-checks)
207(import type-errors)
208(import srfi-19-timezone)
209
210;;;
211
212(include "srfi-19-common")
213
214;-> integer, exact!
215(define-syntax number->genint
216  (syntax-rules ()
217    ((number->genint ?x)
218      (let ((x ?x))
219        (if (fixnum? x) x
220          (inexact->exact (floor x)) ) ) ) ) )
221
222;-> integer, inexact or exact!
223(define-syntax number->integer
224  (syntax-rules ()
225    ((number->integer ?x)
226      (let ((x ?x))
227        (if (integer? x) x
228          (inexact->exact (floor x)) ) ) ) ) )
229
230;;; Timing Routines
231
232;; Provide system timing reporting procedures
233
234(define total-gc-milliseconds
235  (let ((accum-ms 0))
236    (lambda ()
237      (set! accum-ms (+ accum-ms (current-gc-milliseconds)))
238      accum-ms ) ) )
239
240(define (current-process-milliseconds)
241  (let-values (((ums sms) (cpu-time)))
242    (+ ums sms) ) )
243
244;FIXME needs a srfi-18 extension
245(define current-thread-milliseconds current-process-milliseconds)
246
247;;; Date TZ information extract
248
249(define-record-type-variant *date-timezone-info-tag* (unchecked inline unsafe)
250  (%make-date-timezone-info n o d)
251  %date-timezone-info?
252  (n %date-timezone-info-name)
253  (o %date-timezone-info-offset)
254  (d %date-timezone-info-dst?) )
255
256;;; Constants
257
258;; TAI-EPOCH: 1 January 1970 CE at 00:00:00 UTC
259
260(define-constant TAI-EPOCH-YEAR 1970)
261
262;; Used in julian calculation
263
264(define-constant ONE-HALF 1/2)
265
266;; Julian Day 0 = 1 January 4713 BCE at 12:00:00 UTC (Julian proleptic calendar)
267;; Julian Day 0 = 24 November 4714 BCE at 12:00:00 UTC (Gregorian proleptic calendar)
268
269(define-constant TAI-EPOCH-IN-JD 4881175/2)
270
271;; Modified Julian Day 0 = 17 Nov 1858 CE at 00:00:00 UTC
272;; Number of days less than a julian day.
273
274(define-constant TAI-EPOCH-IN-MODIFIED-JD 4800001/2)
275
276;; Julian conversion base century
277
278(define-constant JDYR 4800)
279
280;;; Leap Seconds
281
282;; First leap year after epoch
283
284(define-constant FIRST-LEAP-YEAR 1972)
285
286;; Number of seconds after epoch of first leap year
287
288(define-constant LEAP-START (* (- FIRST-LEAP-YEAR TAI-EPOCH-YEAR) SEC/YR))
289
290;; A table of leap seconds
291;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary.
292;; See "https://www.ietf.org/timezones/data/leap-seconds.list"
293;; seconds since 1900 - seconds since 1972 = 2208988800
294;; Each entry is (utc seconds since epoch . # seconds to add for tai)
295;; Note they go higher (2009) to lower (1972).
296
297(define tm:leap-second-table
298  '((1483228800 . 37)
299    (1435708800 . 36)
300    (1341100800 . 35)
301    (1230768000 . 34)
302    (1136073600 . 33)
303    (915148800 . 32)
304    (867715200 . 31)
305    (820454400 . 30)
306    (773020800 . 29)
307    (741484800 . 28)
308    (709948800 . 27)
309    (662688000 . 26)
310    (631152000 . 25)
311    (567993600 . 24)
312    (489024000 . 23)
313    (425865600 . 22)
314    (394329600 . 21)
315    (362793600 . 20)
316    (315532800 . 19)
317    (283996800 . 18)
318    (252460800 . 17)
319    (220924800 . 16)
320    (189302400 . 15)
321    (157766400 . 14)
322    (126230400 . 13)
323    (94694400 . 12)
324    (78796800 . 11)
325    (63072000 . 10)
326    #;(-60480000 . 4.21317)   ;Before 1972
327    #;(-126230400 . 4.31317)
328    #;(-136771200 . 3.84013)
329    #;(-142128000 . 3.74013)
330    #;(-152668800 . 3.64013)
331    #;(-157766400 . 3.54013)
332    #;(-168307200 . 3.44013)
333    #;(-181526400 . 3.34013)
334    #;(-189388800 . 3.24013)
335    #;(-194659200 . 1.945858)
336    #;(-252460800 . 1.845858)
337    #;(-265680000 . 1.372818)
338    #;(-283996800 . 1.422818) ) )
339
340;; This procedure reads the file in the
341;; ftp://maia.usno.navy.mil/ser7/tai-utc.dat format and
342;; creates a leap second table
343
344(define (tm:read-tai-utc-data flnm)
345  ;
346  (define (convert-jd jd)
347    (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))
348  ;
349  (define (convert-sec sec)
350    (inexact->exact sec))
351  ;
352  (define (read-data)
353    (let loop ((ls '()))
354      (let ((line (read-line)))
355        (if (eof-object? line) ls
356          (let (
357            (data (with-input-from-string (string-append "(" line ")") read)) )
358            (let (
359              (year (car data))
360              (jd   (cadddr (cdr data)))
361              (secs (cadddr (cdddr data))) )
362              (loop
363                (if (< year FIRST-LEAP-YEAR) ls
364                  (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
365  ;
366  (with-input-from-port (open-input-file flnm) read-data) )
367
368;; Table of cummulative seconds, one second before the leap second.
369
370(define (tm:calc-second-before-leap-second-table table)
371  (let loop ((inlst table) (outlst '()))
372    (if (null? inlst)
373      (reverse outlst) ;keep input order anyway
374      (let ((itm (car inlst)))
375        (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )
376
377(define tm:second-before-leap-second-table
378  (tm:calc-second-before-leap-second-table tm:leap-second-table))
379
380;; Read a leap second table file in U.S. Naval Observatory format
381
382(define (tm:read-leap-second-table flnm)
383  (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
384  (set!
385    tm:second-before-leap-second-table
386    (tm:calc-second-before-leap-second-table tm:leap-second-table)) )
387
388;; leap-second-delta algorithm
389
390; 'leap-second-item' is like the 'it' in the anaphoric 'if'
391;
392(define-syntax find-leap-second-delta*
393  (er-macro-transformer
394    (lambda (form r c)
395      (let (
396        (_let (r 'let))
397        (_if (r 'if))
398        (_null? (r 'null?))
399        (_car (r 'car))
400        (_cdr (r 'cdr))
401        (_leap-second-item (r 'leap-second-item)) )
402        (let (
403          (?secs (cadr form))
404          (?ls (caddr form))
405          (?tst (cadddr form)) )
406          `(,_let loop ((lsvar ,?ls))
407              (,_if (,_null? lsvar)
408                0
409                (,_let ((leap-second-item (,_car lsvar)))
410                    (,_if ,?tst
411                      (,_cdr leap-second-item)
412                      (loop (,_cdr lsvar)) ) ) ) ) ) ) ) ) )
413
414(define-syntax leap-second-delta*
415  (er-macro-transformer
416    (lambda (form r c)
417      (let (
418        (_let (r 'let))
419        (_if (r 'if))
420        (_< (r '<))
421        (_tm:leap-second-table (r 'tm:leap-second-table))
422        (_LEAP-START (r 'LEAP-START))
423        (_find-leap-second-delta* (r 'find-leap-second-delta*)) )
424        (let (
425          (?secs (cadr form))
426          (?tst (caddr form)) )
427          `(,_if (,_< ,?secs ,_LEAP-START)
428            0
429            (,_find-leap-second-delta* ,?secs ,_tm:leap-second-table ,?tst) ) ) ) ) ) )
430
431;; Going from utc seconds ...
432
433(define (leap-second-delta utc-seconds)
434  (leap-second-delta*
435    utc-seconds
436    (<= (car leap-second-item) utc-seconds)) )
437
438;; Going from tai seconds to utc seconds ...
439
440(define (leap-second-neg-delta tai-seconds)
441  (leap-second-delta*
442    tai-seconds
443    (<= (cdr leap-second-item) (- tai-seconds (car leap-second-item)))) )
444
445;;; Time Object (Public Mutable)
446
447;; There are 3 kinds of time record procedures:
448;; *...   - generated
449;; tm:... - argument processing then *...
450;; ...    - argument checking then tm:...
451
452(define-record-type-variant *time-tag* (unchecked inline unsafe)
453  (%make-time tt ns sec)
454  %time?
455  (tt   %time-type        %time-type-set!)
456  (ns   %time-nanosecond  %time-nanosecond-set!)
457  (sec  %time-second      %time-second-set!) )
458
459;; Time to Date
460
461(define ONE-SECOND-DURATION (%make-time 'duration 0 1))
462
463;;
464
465;; <time-unit-value> -> <ns sec>
466
467(define-inline (normalize-timeval t per)
468  (quotient&remainder t per) )
469
470(define-inline (normalize-nanoseconds ns)
471  (normalize-timeval ns NS/S) )
472
473; <ns sec min hr> -> <ns sec min hr dy>
474;
475#; ;UNUSED
476(define (normalize-time ns sec min hr)
477  (let*-values (
478    ((ns-sec ns)    (normalize-nanoseconds ns))
479    ((sec-min sec)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
480    ((min-hr min)   (normalize-timeval (+ min sec-min) MIN/HR))
481    ((hr-dy hr)     (normalize-timeval (+ hr min-hr) HR/DY)) )
482    (values ns sec min hr (+ dy hr-dy)) ) )
483
484;; Output Argument CTORs
485
486;Used to create an output time record where all fields will be set later
487;
488(define (tm:any-time)
489  (%make-time #f #f #f) )
490
491;Used to create a time record where ns & sec fields will be set later
492;
493(define (tm:some-time tt)
494  (%make-time tt #f #f) )
495
496;Used to create a time record where ns & sec fields will be set later
497;
498(define (tm:as-some-time tim)
499  (%make-time (%time-type tim) #f #f) )
500
501;;
502
503(define (tm:time-type tim)
504  (%time-type tim) )
505
506(define (tm:time-second tim)
507  (%time-second tim) )
508
509(define (tm:time-nanosecond tim)
510  (%time-nanosecond tim) )
511
512(define (tm:time-type-set! tim typ)
513  (%time-type-set! tim typ) )
514
515(define (tm:time-nanosecond-set! tim ns)
516  (%time-nanosecond-set! tim (number->integer ns)) )
517
518(define (tm:time-second-set! tim sec)
519  (%time-second-set! tim (number->integer sec)) )
520
521(define (tm:time? obj)
522  (%time? obj) )
523
524(define (tm:make-time tt ns sec)
525  (let-values (
526    ((ns-sec ns) (normalize-nanoseconds ns)) )
527    (%make-time tt (number->integer ns) (number->integer (+ sec ns-sec))) ) )
528
529(define (tm:copy-time tim)
530  (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) )
531
532(define (tm:time-has-type? tim tt)
533  (eq? tt (%time-type tim)) )
534
535;; Rem & Quo of nanoseconds per second
536
537(define (tm:nanoseconds->time-values nanos)
538  (quotient&remainder nanos NS/S) )
539
540;; Seconds Conversion
541
542;;
543
544(define (tm:time->nanoseconds tim)
545  (+ (%time-nanosecond tim) (* (%time-second tim) NS/S)) )
546
547(define (tm:time->milliseconds tim)
548  (+ (/ (%time-nanosecond tim) NS/MS) (* (%time-second tim) MS/S)) )
549
550(define (tm:nanoseconds->seconds ns)
551  (/ ns NS/S) )
552
553(define (tm:milliseconds->seconds ms)
554  (/ ms MS/S) )
555
556(define-syntax tm:time->seconds
557        (syntax-rules ()
558                ((tm:time->seconds ?tim)
559                  (tm:nanoseconds->seconds (tm:time->nanoseconds ?tim)) ) ) )
560
561(define (tm:duration-elements->time-values
562          days
563          hours minutes seconds
564          milliseconds microseconds nanoseconds)
565        (let (
566          (nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
567    (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
568    (let-values (
569      ((ns-secs ns-ns) (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))) )
570      (values ns-ns (+ (floor secs) ns-secs)) ) ) )
571
572(define (tm:seconds->time-values sec)
573  (let* (
574    (isec (number->integer sec))
575    (ns (number->integer (round (* (- sec isec) NS/S)))) )
576    (values ns isec) ) )
577
578(define (tm:milliseconds->time-values ms)
579  (let-values (
580    ((sec ms-sec) (quotient&remainder ms MS/S)) )
581    (let (
582      (ns (* (number->integer ms-sec) NS/MS)) )
583      (values ns sec) ) ) )
584
585(define-syntax tm:milliseconds->time
586        (syntax-rules ()
587                ((tm:milliseconds->time ?ms ?tt)
588                  (let-values (((ns sec) (tm:milliseconds->time-values ?ms)))
589        (tm:make-time ?tt ns sec) ) ) ) )
590
591(define-syntax tm:seconds->time
592        (syntax-rules ()
593                ((tm:seconds->time ?sec ?tt)
594                  (let-values (((ns sec) (tm:seconds->time-values ?sec)))
595        (tm:make-time ?tt ns sec) ) ) ) )
596
597;; Current time routines
598
599; Throw away everything but the sub-second bit.
600;
601(define (tm:current-sub-milliseconds)
602        (inexact->exact (remainder (current-milliseconds) MS/S)) )
603
604(define (tm:current-nanoseconds)
605  (* (tm:current-sub-milliseconds) NS/MS) )
606
607;Use the 'official' seconds & nanoseconds values
608;
609(define (tm:current-time-values)
610  (values (tm:current-nanoseconds) (current-seconds)) )
611
612(define (tm:current-time-utc)
613  (let-values (((ns sec) (tm:current-time-values)))
614    (tm:make-time 'utc ns sec) ) )
615
616(define (tm:current-time-tai)
617  (let-values (((ns sec) (tm:current-time-values)))
618    (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) )
619
620(define (tm:current-time-monotonic)
621  (let ((tim (tm:current-time-tai)))
622    ;time-monotonic is time-tai
623    (%time-type-set! tim 'monotonic)
624    tim ) )
625
626(define (tm:current-time-thread)
627  (tm:milliseconds->time (current-thread-milliseconds) 'thread) )
628
629(define (tm:current-time-process)
630  (tm:milliseconds->time (current-process-milliseconds) 'process) )
631
632(define (tm:current-time-gc)
633  (tm:milliseconds->time (total-gc-milliseconds) 'gc) )
634
635;; -- Time Resolution
636;; This is the resolution of the clock in nanoseconds.
637;; This will be implementation specific.
638
639(define (tm:time-resolution tt)
640  NS/MS )
641
642;; Time Comparison
643
644(define (tm:time-compare tim1 tim2)
645  (let ((dif (- (%time-second tim1) (%time-second tim2))))
646    (if (not (zero? dif))
647      dif
648      (- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
649
650(define (tm:time=? tim1 tim2)
651  (and
652    (= (%time-second tim1) (%time-second tim2))
653    (= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
654
655(define (tm:time<? tim1 tim2)
656  (or
657    (< (%time-second tim1) (%time-second tim2))
658    (and
659      (= (%time-second tim1) (%time-second tim2))
660      (< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
661
662(define (tm:time<=? tim1 tim2)
663  (or
664    (< (%time-second tim1) (%time-second tim2))
665    (and
666      (= (%time-second tim1) (%time-second tim2))
667      (<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
668
669(define (tm:time>? tim1 tim2)
670  (or
671    (> (%time-second tim1) (%time-second tim2))
672    (and
673      (= (%time-second tim1) (%time-second tim2))
674      (> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
675
676(define (tm:time>=? tim1 tim2)
677  (or
678    (> (%time-second tim1) (%time-second tim2))
679    (and
680      (= (%time-second tim1) (%time-second tim2))
681      (>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
682
683(define-syntax tm:time-max
684        (syntax-rules ()
685                ((tm:time-max ?tim1 ?tim2)
686                  (let ((tim1 ?tim1) (tim2 ?tim2))
687        (if (tm:time>? tim1 tim2) tim1 tim2) ) ) ) )
688
689(define-syntax tm:time-min
690        (syntax-rules ()
691                ((tm:time-min ?tim1 ?tim2)
692                  (let ((tim1 ?tim1) (tim2 ?tim2))
693        (if (tm:time<? tim1 tim2) tim1 tim2) ) ) ) )
694
695;; Time Arithmetic
696
697(define (tm:add-duration tim1 dur timout)
698        (let-values (
699          ((sec ns) (tm:nanoseconds->time-values (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
700    (let (
701      (secs (+ (%time-second tim1) (%time-second dur) sec)) )
702      (cond
703        ((negative? ns) ;Borrow
704          ;Should never happen
705          (tm:time-second-set! timout (+ secs -1))
706          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
707        (else
708          (tm:time-second-set! timout secs)
709          (tm:time-nanosecond-set! timout ns) ) )
710      timout ) ) )
711
712(define (tm:subtract-duration tim1 dur timout)
713  (let-values (
714    ((sec ns) (tm:nanoseconds->time-values (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
715    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
716    (let (
717      (secs (- (%time-second tim1) (%time-second dur) sec)) )
718      (cond
719        ((negative? ns) ;Borrow
720          (tm:time-second-set! timout (- secs 1))
721          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
722        (else
723          (tm:time-second-set! timout secs)
724          (tm:time-nanosecond-set! timout ns) ) )
725      timout ) ) )
726
727(define (tm:divide-duration dur1 num durout)
728  (let-values (
729    ((sec ns) (tm:nanoseconds->time-values (/ (tm:time->nanoseconds dur1) num))) )
730    (tm:time-nanosecond-set! durout ns)
731    (tm:time-second-set! durout sec)
732    durout ) )
733
734(define (tm:multiply-duration dur1 num durout)
735        (let-values (
736          ((sec ns) (tm:nanoseconds->time-values (* (tm:time->nanoseconds dur1) num))) )
737    (tm:time-nanosecond-set! durout ns)
738    (tm:time-second-set! durout sec)
739    durout ) )
740
741(define (tm:time-difference tim1 tim2 timout)
742  (let-values (
743    ((sec ns) (tm:nanoseconds->time-values (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
744    (tm:time-second-set! timout sec)
745    (tm:time-nanosecond-set! timout ns)
746    timout ) )
747
748(define (tm:time-abs tim1 timout)
749  (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
750  (tm:time-second-set! timout (abs (%time-second tim1)))
751  timout )
752
753(define (tm:time-negate tim1 timout )
754  (tm:time-nanosecond-set! timout (- (%time-nanosecond tim1)))
755  (tm:time-second-set! timout (- (%time-second tim1)))
756  timout )
757
758(define (tm:time-negative? tim)
759  ;nanoseconds irrelevant
760  (negative? (tm:time-second tim)) )
761
762(define (tm:time-positive? tim)
763  ;nanoseconds irrelevant
764  (positive? (tm:time-second tim)) )
765
766(define (tm:time-zero? tim)
767  (and (zero? (tm:time-second tim))) (zero? (tm:time-nanosecond tim)) )
768
769;; Time Type Converters
770
771(define (tm:time-tai->time-utc timin timout)
772  (%time-type-set! timout 'utc)
773  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
774  (tm:time-second-set! timout
775    (- (%time-second timin) (leap-second-neg-delta (%time-second timin))))
776  timout )
777
778(define (tm:time-tai->time-monotonic timin timout)
779  (%time-type-set! timout 'monotonic)
780  (unless (eq? timin timout)
781    (tm:time-nanosecond-set! timout (%time-nanosecond timin))
782    (tm:time-second-set! timout (%time-second timin)))
783  timout )
784
785(define (tm:time-utc->time-tai timin timout)
786  (%time-type-set! timout 'tai)
787  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
788  (tm:time-second-set! timout
789    (+ (%time-second timin) (leap-second-delta (%time-second timin))))
790  timout )
791
792(define (tm:time-utc->time-monotonic timin timout)
793  (let ((ntim (tm:time-utc->time-tai timin timout)))
794    (%time-type-set! ntim 'monotonic)
795    ntim ) )
796
797(define (tm:time-monotonic->time-tai timin timout)
798  (%time-type-set! timout 'tai)
799  (unless (eq? timin timout)
800    (tm:time-nanosecond-set! timout (%time-nanosecond timin))
801    (tm:time-second-set! timout (%time-second timin)))
802  timout )
803
804(define (tm:time-monotonic->time-utc timin timout)
805  #;(%time-type-set! timin 'tai) ;fool converter (unnecessary)
806  (tm:time-tai->time-utc timin timout) )
807
808;;; Date Object (Public Immutable)
809
810;; Leap Year Test
811
812;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
813;; The Journal of the Royal Astronomical Society of Canada.
814;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
815;; Part II, volume 58, number 2, pages 79-87 (April 1964).
816
817(define (tm:leap-year? yr)
818  (and
819    #; ;!NOT Officially Adopted!
820    (not (zero? (modulo yr 4000)))
821    (or
822      (zero? (modulo yr 400))
823      (and
824        (zero? (modulo yr 4))
825        (not (zero? (modulo yr 100)))))) )
826
827;; Days per Month
828
829;Month range 1..12 so dys/mn range 0..12
830(define      +year-dys/mn+ #(0 31 28 31 30 31 30 31 31 30 31 30 31))
831(define +leap-year-dys/mn+ #(0 31 29 31 30 31 30 31 31 30 31 30 31))
832
833(define-inline (days/month yr)
834  (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+) )
835
836(define (tm:leap-day? dy mn)
837  (= dy (vector-ref +leap-year-dys/mn+ mn)) )
838
839(define (tm:days-in-month yr mn)
840  (vector-ref (days/month yr) mn) )
841
842;;; Date Object (Public Mutable)
843
844(define-record-type-variant *date-tag* (unchecked inline unsafe)
845  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
846  %date?
847  (ns     %date-nanosecond  %date-nanosecond-set!)
848  (sec    %date-second      %date-second-set!)
849  (min    %date-minute      %date-minute-set!)
850  (hr     %date-hour        %date-hour-set!)
851  (dy     %date-day         %date-day-set!)
852  (mn     %date-month       %date-month-set!)
853  (yr     %date-year        %date-year-set!)
854  (tzo    %date-zone-offset %date-zone-offset-set!)
855  ;; non-srfi extn
856  (tzn    %date-zone-name   %date-zone-name-set!)
857  (dstf   %date-dst?        %date-dst-set!)
858  (wdy    %date-wday        %date-wday-set!)
859  (ydy    %date-yday        %date-yday-set!)
860  (jdy    %date-jday        %date-jday-set!) )
861
862;;
863
864;;; Getters
865
866(define (tm:date-nanosecond dat)
867  (%date-nanosecond dat) )
868
869(define (tm:date-second dat)
870  (%date-second dat) )
871
872(define (tm:date-minute dat)
873  (%date-minute dat) )
874
875(define (tm:date-hour dat)
876  (%date-hour dat) )
877
878(define (tm:date-day dat)
879  (%date-day dat) )
880
881(define (tm:date-month dat)
882  (%date-month dat) )
883
884(define (tm:date-year dat)
885  (%date-year dat) )
886
887(define (tm:date-zone-offset dat)
888  (%date-zone-offset dat) )
889
890(define (tm:date-zone-name dat)
891  (%date-zone-name dat) )
892
893(define (tm:date-dst? dat)
894  (%date-dst? dat) )
895
896(define (tm:date-wday dat)
897  (%date-wday dat) )
898
899(define (tm:date-yday dat)
900  (%date-yday dat) )
901
902(define (tm:date-jday dat)
903  (%date-jday dat) )
904
905;;; Setters
906
907(define (tm:date-nanosecond-set! dat x)
908  (%date-nanosecond-set! dat (number->integer x)) )
909
910(define (tm:date-second-set! dat x)
911  (%date-second-set! dat (number->integer x)) )
912
913(define (tm:date-minute-set! dat x)
914  (%date-minute-set! dat (number->integer x)) )
915
916(define (tm:date-hour-set! dat x)
917  (%date-hour-set! dat (number->integer x)) )
918
919(define (tm:date-day-set! dat x)
920  (%date-day-set! dat (number->integer x)) )
921
922(define (tm:date-month-set! dat x)
923  (%date-month-set! dat (number->integer x)) )
924
925(define (tm:date-year-set! dat x)
926  (%date-year-set! dat (number->integer x)) )
927
928(define (tm:date-zone-offset-set! dat x)
929  (%date-zone-offset-set! dat (number->integer x)) )
930
931;; Date TZ information extract
932
933(define (tm:date-timezone-info? obj)
934  (%date-timezone-info? obj) )
935
936(define (tm:date-timezone-info dat)
937  (%make-date-timezone-info
938    (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) )
939
940(define (tm:date? obj)
941  (%date? obj) )
942
943;; Returns an invalid date record (for use by 'scan-date')
944
945(define (tm:make-incomplete-date)
946  (%make-date
947    0
948    0 0 0
949    #f #f #f
950    (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
951    #f #f #f) )
952
953;; Internal Date CTOR
954
955(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
956  (%make-date
957    (number->integer ns)
958    (number->integer sec) (number->integer min) (number->integer hr)
959    (number->integer dy) (number->integer mn) (number->integer yr)
960    (number->integer tzo) tzn dstf
961    wdy ydy jdy) )
962
963(define (tm:copy-date dat)
964  (%make-date
965    (%date-nanosecond dat)
966    (%date-second dat) (%date-minute dat) (%date-hour dat)
967    (%date-day dat) (%date-month dat) (%date-year dat)
968    (%date-zone-offset dat)
969    (%date-zone-name dat) (%date-dst? dat)
970    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
971
972(define (tm:date-complete? dat)
973  (and
974    (%date-nanosecond dat)
975    (%date-second dat) (%date-minute dat) (%date-hour dat)
976    (%date-day dat) (%date-month dat) (%date-year dat)
977    (%date-zone-offset dat)) )
978
979(define (tm:seconds->date/type sec tzc)
980  (let* (
981    (isec (number->genint sec))
982    (tzo (timezone-locale-offset tzc))
983    ;seconds->utc-time cannot accept inexact-integer
984    (tv (seconds->utc-time (+ isec tzo))) )
985    (tm:make-date
986      (round (* (- sec isec) NS/S))
987      (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
988      (vector-ref tv 3) (+ 1 (vector-ref tv 4)) (+ 1900 (vector-ref tv 5))
989      tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
990      (vector-ref tv 6) (+ 1 (vector-ref tv 7)) #f) ) )
991
992(define (tm:current-date tzi)
993  (tm:time-utc->date (tm:current-time-utc) tzi) )
994
995;; Date Comparison
996
997(define (tm:date-compare dat1 dat2)
998  (let ((dif (- (%date-year dat1) (%date-year dat2))))
999    (if (not (zero? dif))
1000      dif
1001      (let ((dif (- (%date-month dat1) (%date-month dat2))))
1002        (if (not (zero? dif))
1003          dif
1004          (let ((dif (- (%date-day dat1) (%date-day dat2))))
1005            (if (not (zero? dif))
1006              dif
1007              (let ((dif (- (%date-hour dat1) (%date-hour dat2))))
1008                (if (not (zero? dif))
1009                  dif
1010                  (let ((dif (- (%date-minute dat1) (%date-minute dat2))))
1011                    (if (not (zero? dif))
1012                      dif
1013                      (let ((dif (- (%date-second dat1) (%date-second dat2))))
1014                        (if (not (zero? dif))
1015                          dif
1016                          (- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) )
1017
1018;; Gives the seconds/day/month/year
1019
1020(define (tm:decode-julian-day-number jdn)
1021  (let* (
1022    (days (floor jdn))
1023    (a (+ days 32044))
1024    (b (quotient (+ (* 4 a) 3) 146097))
1025    (c (- a (quotient (* 146097 b) 4)))
1026    (d (quotient (+ (* 4 c) 3) 1461))
1027    (e (- c (quotient (* 1461 d) 4)))
1028    (m (quotient (+ (* 5 e) 2) 153))
1029    (y (+ (* 100 b) d (- JDYR) (quotient m 10))) )
1030    (values ;seconds date month year
1031     (* (- jdn days) SEC/DY)
1032     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
1033     (+ m 3 (* (- MN/YR) (quotient m 10)))
1034     (if (>= 0 y) (- y 1) y)) ) )
1035
1036;; Gives the Julian day number - rounds up to the nearest day
1037
1038(define (tm:seconds->julian-day-number sec tzo)
1039  (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
1040
1041;; Is the time object one second before a leap second?
1042
1043(define (tm:tai-before-leap-second? tim)
1044  (let ((sec (%time-second tim)))
1045    (let loop ((ls tm:second-before-leap-second-table))
1046      (and
1047        (not (null? ls))
1048        (or
1049          (= sec (car ls))
1050          (loop (cdr ls)) ) ) ) ) )
1051
1052(define (optional-tzinfo tzi)
1053  (cond
1054    ((%date-timezone-info? tzi)
1055      (values
1056        (%date-timezone-info-offset tzi)
1057        (%date-timezone-info-name tzi)
1058        (%date-timezone-info-dst? tzi)) )
1059    ((timezone-components? tzi)
1060      (values
1061        (timezone-locale-offset tzi)
1062        (timezone-locale-name tzi)
1063        (timezone-locale-dst? tzi)) )
1064    (else
1065      ;assume an offset
1066      (values tzi #f #f) ) ) )
1067
1068(define (tm:time-utc->date tim tzi)
1069  (let-values (
1070    ((tzo tzn dstf) (optional-tzinfo tzi)) )
1071    (let*-values (
1072      ((secs dy mn yr)
1073        (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo)))
1074      ((hr rem)
1075        (quotient&remainder secs SEC/HR))
1076      ((min sec)
1077        (quotient&remainder rem SEC/MIN)) )
1078      (tm:make-date
1079        (%time-nanosecond tim)
1080        sec min hr
1081        dy mn yr
1082        tzo tzn dstf
1083        #f #f #f) ) ) )
1084
1085(define (tm:time-tai->date tim tzi)
1086  (let (
1087    (tm-utc (tm:time-tai->time-utc tim (tm:any-time))) )
1088    (if (not (tm:tai-before-leap-second? tim))
1089      (tm:time-utc->date tm-utc tzi)
1090      ;else time is *right* before the leap,
1091      ;we need to pretend to subtract a second ...
1092      (let (
1093        (dat
1094          (tm:time-utc->date
1095            (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)) )
1096        (%date-second-set! dat SEC/MIN) ;Note full minute!
1097        dat ) ) ) )
1098
1099(define (tm:time->date tim tzi)
1100  (case (%time-type tim)
1101    ((utc)       (tm:time-utc->date tim tzi))
1102    ((tai)       (tm:time-tai->date tim tzi))
1103    ((monotonic) (tm:time-utc->date tim tzi))
1104    (else        #f)) )
1105
1106;; Date to Time
1107
1108;; Gives the Julian day number - Gregorian proleptic calendar
1109
1110(define (tm:encode-julian-day-number dy mn yr)
1111  (let* (
1112    (a (quotient (- 14 mn) MN/YR))
1113    (b (+ yr JDYR (- a)))
1114    (y (if (negative? yr) (+ 1 b) b)) ;BCE?
1115    (m (+ mn (* a MN/YR) -3)))
1116    (+ dy
1117      (quotient (+ (* 153 m) 2) 5)
1118      (* y DY/YR)
1119      (quotient y 4)
1120      (quotient y -100)
1121      (quotient y 400)
1122      -32045) ) )
1123
1124(define (tm:date->time-utc dat)
1125  (let (
1126    (ns (%date-nanosecond dat))
1127    (sec (%date-second dat))
1128    (min (%date-minute dat))
1129    (hr (%date-hour dat))
1130    (dy (%date-day dat))
1131    (mn (%date-month dat))
1132    (yr (%date-year dat))
1133    (tzo (%date-zone-offset dat)) )
1134    (let (
1135      (jdys
1136        (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
1137      (secs
1138        (+ (* hr SEC/HR) (* min SEC/MIN) sec (- tzo))) )
1139      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
1140
1141(define (tm:date->time-tai dat)
1142  (let* (
1143    (tm-utc (tm:date->time-utc dat))
1144    (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
1145    (if (not (= SEC/MIN (%date-second dat)))
1146      tm-tai
1147      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
1148
1149(define (tm:date->time-monotonic dat)
1150  (let ((tim-utc (tm:date->time-utc dat)))
1151    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
1152
1153(define (tm:date->time dat tt)
1154  (case tt
1155    ((utc)        (tm:date->time-utc dat))
1156    ((tai)        (tm:date->time-tai dat))
1157    ((monotonic)  (tm:date->time-monotonic dat))
1158    (else         #f) ) )
1159
1160;; Given a 'two digit' number, find the year within 50 years +/-
1161
1162(define (tm:natural-year n tzi)
1163  ;propagate the error
1164  (if (or (< n 0) (>= n 100))
1165    n
1166    (let* (
1167      (current-year     (%date-year (tm:current-date tzi)) )
1168      (current-century  (* (quotient current-year 100) 100) )
1169      (X                (+ current-century n (- current-year)) ) )
1170      (if (<= X 50)
1171        (+ current-century n)
1172        (+ (- current-century 100) n) ) ) ) )
1173
1174;; Day of Year
1175
1176(define +cumulative-month-days+ #(0 0 31 59 90 120 151 181 212 243 273 304 334))
1177
1178(define (tm:year-day dy mn yr)
1179  (let ((yrdy (+ dy (vector-ref +cumulative-month-days+ mn))))
1180    (if (and (tm:leap-year? yr) (< 2 mn))
1181      (+ yrdy 1)
1182      yrdy ) ) )
1183
1184(define (tm:cache-date-year-day dat)
1185  (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
1186    (%date-yday-set! dat yrdy)
1187    yrdy ) )
1188
1189(define (tm:date-year-day dat)
1190  (or
1191    (%date-yday dat)
1192    (tm:cache-date-year-day dat) ) )
1193
1194;; Week Day
1195
1196;; Using Gregorian Calendar (from Calendar FAQ)
1197
1198(: tm:week-day (fixnum fixnum fixnum --> fixnum))
1199
1200;Tomohiko Sakamoto algorithm
1201;Determination of the day of the week
1202;
1203;Jan 1st 1 AD is a Monday in Gregorian calendar.
1204;So Jan 0th 1 AD is a Sunday [It does not exist technically].
1205;
1206;Every 4 years we have a leap year. But xy00 cannot be a leap unless xy divides 4 with remainder 0.
1207;y/4 - y/100 + y/400 : this gives the number of leap years from 1AD to the
1208;given year. As each year has 365 days (divides 7 with remainder 1), unless it
1209;is a leap year or the date is in Jan or Feb, the day of a given date changes
1210;by 1 each year. In other cases it increases by 2.
1211;y -= m<3 : If the month is not Jan or Feb, we do not count the 29th Feb (if
1212;it exists) of the given year.
1213;So y + y/4 - y/100 + y/400  gives the day of Jan 0th (Dec 31st of prev year)
1214;of the year. (This gives the remainder with 7 of  the number of days passed
1215;before the given year began.)
1216;
1217;Array t:  Number of days passed before the month 'm+1' begins.
1218;
1219;So t[m-1]+d is the number of days passed in year 'y' up to the given date.
1220;(y + y/4 - y/100 + y/400 + t[m-1] + d) % 7 is remainder of the number of days
1221;from Jan 0 1AD to the given date which will be the day (0=Sunday,6=Saturday).
1222;
1223;Description credits: Sai Teja Pratap (quora.com/How-does-Tomohiko-Sakamotos-Algorithm-work)
1224#; ;???
1225(define tm:week-day
1226  (let (
1227    (t #(0 3 2 5 0 3 5 1 4 6 2 4)) )
1228    (lambda (dy mn yr)
1229      (let (
1230        (yr (if (< mn 3) (- yr 1) yr)) )
1231        (modulo (+ yr (/ yr 4) (/ yr -100) (vector-ref t (- mn 1)) dy) DY/WK) ) ) ) )
1232
1233(define (tm:week-day dy mn yr)
1234  (let* (
1235    (a (quotient (- 14 mn) MN/YR))
1236    (y (- yr a))
1237    (m (- (+ mn (* a MN/YR)) 2)) )
1238    (modulo
1239      (+ dy y
1240         (- (quotient y 4) (quotient y 100))
1241         (quotient y 400)
1242         (quotient (* m DY/MN) MN/YR))
1243      DY/WK) ) )
1244
1245(define (tm:cache-date-week-day dat)
1246  (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
1247    (%date-wday-set! dat wdy)
1248    wdy ) )
1249
1250(define (tm:date-week-day dat)
1251  (or
1252    (%date-wday dat)
1253    (tm:cache-date-week-day dat) ) )
1254
1255(define (tm:days-before-first-week dat 1st-weekday)
1256  (modulo
1257    (- 1st-weekday (tm:week-day 1 1 (%date-year dat)))
1258    DY/WK) )
1259
1260(define (tm:date-week-number dat 1st-weekday)
1261  (quotient
1262    (- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
1263    DY/WK) )
1264
1265;; Julian-day Operations
1266
1267(define (tm:julian-day->modified-julian-day mjdn)
1268  (- mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1269
1270;; Date to Julian-day
1271
1272(define (tm:jd-time->seconds ns sec min hr tzo)
1273  (+ (* hr SEC/HR) (* min SEC/MIN) sec (- tzo) (/ ns NS/S)) )
1274
1275; Does the nanoseconds value contribute anything to the julian day?
1276; The range is < 1 second here (but not in the reference).
1277
1278(define (tm:julian-day ns sec min hr dy mn yr tzo)
1279  (let (
1280    (jdn
1281      (tm:encode-julian-day-number dy mn yr))
1282    (timsecs
1283      (tm:jd-time->seconds ns sec min hr tzo)) )
1284    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
1285
1286(define (tm:date->julian-day dat)
1287  (or
1288    (%date-jday dat)
1289    (let (
1290      (jdn
1291        (tm:julian-day
1292          (%date-nanosecond dat)
1293          (%date-second dat) (%date-minute dat) (%date-hour dat)
1294          (%date-day dat) (%date-month dat) (%date-year dat)
1295          (%date-zone-offset dat))))
1296      (%date-jday-set! dat jdn)
1297      jdn ) ) )
1298
1299;; Time to Julian-day
1300
1301(define (tm:seconds->julian-day ns sec)
1302  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
1303
1304(define (tm:time-utc->julian-day tim)
1305  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
1306
1307(define (tm:time-tai->julian-day tim)
1308  (let ((sec (%time-second tim)))
1309    (tm:seconds->julian-day
1310      (%time-nanosecond tim)
1311      (- sec (leap-second-delta sec))) ) )
1312
1313(define tm:time-monotonic->julian-day tm:time-tai->julian-day)
1314
1315(define (tm:time->julian-day tim)
1316  (case (%time-type tim)
1317    ((utc)        (tm:time-utc->julian-day tim))
1318    ((tai)        (tm:time-tai->julian-day tim))
1319    ((monotonic)  (tm:time-monotonic->julian-day tim))
1320    (else         #f)) )
1321
1322(define (tm:time-utc->modified-julian-day tim)
1323  (tm:julian-day->modified-julian-day (tm:time-utc->julian-day tim)) )
1324
1325(define (tm:time-tai->modified-julian-day tim)
1326  (tm:julian-day->modified-julian-day (tm:time-tai->julian-day tim)) )
1327
1328(define (tm:time-monotonic->modified-julian-day tim)
1329  (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )
1330
1331(define (tm:time->modified-julian-day tim)
1332  (case (%time-type tim)
1333    ((utc)        (tm:time-utc->modified-julian-day tim))
1334    ((tai)        (tm:time-tai->modified-julian-day tim))
1335    ((monotonic)  (tm:time-monotonic->modified-julian-day tim))
1336    (else         #f)) )
1337
1338;; Julian-day to Time
1339
1340(define (tm:julian-day->nanoseconds jdn)
1341  (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S) )
1342
1343(define (tm:julian-day->time-values jdn)
1344  (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)) )
1345
1346(define (tm:modified-julian-day->julian-day mjdn)
1347  (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1348
1349(define (tm:julian-day->time-utc jdn)
1350  (let-values (((sec ns) (tm:julian-day->time-values jdn)))
1351    (tm:make-time 'time-utc ns sec) ) )
1352
1353(define (tm:modified-julian-day->time-utc mjdn)
1354  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
1355
1356(define (tm:default-date-adjust-integer amt)
1357  (round amt) )
1358
1359) ;module srfi-19-tm
Note: See TracBrowser for help on using the repository browser.