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

Last change on this file since 38676 was 38676, checked in by Kon Lovett, 5 months ago

fix NS/MS & NS/MuS name, only unix ts

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