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

Last change on this file since 38700 was 38700, checked in by Kon Lovett, 4 months ago

current-process-milliseconds -> total-cpu-milliseconds

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