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

Last change on this file since 38668 was 38668, checked in by Kon Lovett, 12 months ago

remove redundant -local, use -strict-types (#t is-a type? see -io zone-reader NOTE), isolate tm:ctm

File size: 38.7 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(import (only srfi-19-tmctm tm:current-time-values))
600
601(define (tm:current-time-utc)
602  (let-values (((ns sec) (tm:current-time-values)))
603    (tm:make-time 'utc ns sec) ) )
604
605(define (tm:current-time-tai)
606  (let-values (((ns sec) (tm:current-time-values)))
607    (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) )
608
609(define (tm:current-time-monotonic)
610  (let ((tim (tm:current-time-tai)))
611    ;time-monotonic is time-tai
612    (%time-type-set! tim 'monotonic)
613    tim ) )
614
615(define (tm:current-time-thread)
616  (tm:milliseconds->time (current-thread-milliseconds) 'thread) )
617
618(define (tm:current-time-process)
619  (tm:milliseconds->time (current-process-milliseconds) 'process) )
620
621(define (tm:current-time-gc)
622  (tm:milliseconds->time (total-gc-milliseconds) 'gc) )
623
624;; -- Time Resolution
625;; This is the resolution of the clock in nanoseconds.
626;; This will be implementation specific.
627
628(define (tm:time-resolution tt)
629  NS/MS )
630
631;; Time Comparison
632
633(define (tm:time-compare tim1 tim2)
634  (let ((dif (- (%time-second tim1) (%time-second tim2))))
635    (if (not (zero? dif))
636      dif
637      (- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
638
639(define (tm:time=? tim1 tim2)
640  (and
641    (= (%time-second tim1) (%time-second tim2))
642    (= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
643
644(define (tm:time<? tim1 tim2)
645  (or
646    (< (%time-second tim1) (%time-second tim2))
647    (and
648      (= (%time-second tim1) (%time-second tim2))
649      (< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
650
651(define (tm:time<=? tim1 tim2)
652  (or
653    (< (%time-second tim1) (%time-second tim2))
654    (and
655      (= (%time-second tim1) (%time-second tim2))
656      (<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
657
658(define (tm:time>? tim1 tim2)
659  (or
660    (> (%time-second tim1) (%time-second tim2))
661    (and
662      (= (%time-second tim1) (%time-second tim2))
663      (> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
664
665(define (tm:time>=? tim1 tim2)
666  (or
667    (> (%time-second tim1) (%time-second tim2))
668    (and
669      (= (%time-second tim1) (%time-second tim2))
670      (>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
671
672(define-syntax tm:time-max
673        (syntax-rules ()
674                ((tm:time-max ?tim1 ?tim2)
675                  (let ((tim1 ?tim1) (tim2 ?tim2))
676        (if (tm:time>? tim1 tim2) tim1 tim2) ) ) ) )
677
678(define-syntax tm:time-min
679        (syntax-rules ()
680                ((tm:time-min ?tim1 ?tim2)
681                  (let ((tim1 ?tim1) (tim2 ?tim2))
682        (if (tm:time<? tim1 tim2) tim1 tim2) ) ) ) )
683
684;; Time Arithmetic
685
686(define (tm:add-duration tim1 dur timout)
687        (let-values (
688          ((sec ns) (tm:nanoseconds->time-values (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
689    (let (
690      (secs (+ (%time-second tim1) (%time-second dur) sec)) )
691      (cond
692        ((negative? ns) ;Borrow
693          ;Should never happen
694          (tm:time-second-set! timout (+ secs -1))
695          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
696        (else
697          (tm:time-second-set! timout secs)
698          (tm:time-nanosecond-set! timout ns) ) )
699      timout ) ) )
700
701(define (tm:subtract-duration tim1 dur timout)
702  (let-values (
703    ((sec ns) (tm:nanoseconds->time-values (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
704    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
705    (let (
706      (secs (- (%time-second tim1) (%time-second dur) sec)) )
707      (cond
708        ((negative? ns) ;Borrow
709          (tm:time-second-set! timout (- secs 1))
710          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
711        (else
712          (tm:time-second-set! timout secs)
713          (tm:time-nanosecond-set! timout ns) ) )
714      timout ) ) )
715
716(define (tm:divide-duration dur1 num durout)
717  (let-values (
718    ((sec ns) (tm:nanoseconds->time-values (/ (tm:time->nanoseconds dur1) num))) )
719    (tm:time-nanosecond-set! durout ns)
720    (tm:time-second-set! durout sec)
721    durout ) )
722
723(define (tm:multiply-duration dur1 num durout)
724        (let-values (
725          ((sec ns) (tm:nanoseconds->time-values (* (tm:time->nanoseconds dur1) num))) )
726    (tm:time-nanosecond-set! durout ns)
727    (tm:time-second-set! durout sec)
728    durout ) )
729
730(define (tm:time-difference tim1 tim2 timout)
731  (let-values (
732    ((sec ns) (tm:nanoseconds->time-values (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
733    (tm:time-second-set! timout sec)
734    (tm:time-nanosecond-set! timout ns)
735    timout ) )
736
737(define (tm:time-abs tim1 timout)
738  (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
739  (tm:time-second-set! timout (abs (%time-second tim1)))
740  timout )
741
742(define (tm:time-negate tim1 timout )
743  (tm:time-nanosecond-set! timout (- (%time-nanosecond tim1)))
744  (tm:time-second-set! timout (- (%time-second tim1)))
745  timout )
746
747(define (tm:time-negative? tim)
748  ;nanoseconds irrelevant
749  (negative? (tm:time-second tim)) )
750
751(define (tm:time-positive? tim)
752  ;nanoseconds irrelevant
753  (positive? (tm:time-second tim)) )
754
755(define (tm:time-zero? tim)
756  (and (zero? (tm:time-second tim))) (zero? (tm:time-nanosecond tim)) )
757
758;; Time Type Converters
759
760(define (tm:time-tai->time-utc timin timout)
761  (%time-type-set! timout 'utc)
762  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
763  (tm:time-second-set! timout
764    (- (%time-second timin) (leap-second-neg-delta (%time-second timin))))
765  timout )
766
767(define (tm:time-tai->time-monotonic timin timout)
768  (%time-type-set! timout 'monotonic)
769  (unless (eq? timin timout)
770    (tm:time-nanosecond-set! timout (%time-nanosecond timin))
771    (tm:time-second-set! timout (%time-second timin)))
772  timout )
773
774(define (tm:time-utc->time-tai timin timout)
775  (%time-type-set! timout 'tai)
776  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
777  (tm:time-second-set! timout
778    (+ (%time-second timin) (leap-second-delta (%time-second timin))))
779  timout )
780
781(define (tm:time-utc->time-monotonic timin timout)
782  (let ((ntim (tm:time-utc->time-tai timin timout)))
783    (%time-type-set! ntim 'monotonic)
784    ntim ) )
785
786(define (tm:time-monotonic->time-tai timin timout)
787  (%time-type-set! timout 'tai)
788  (unless (eq? timin timout)
789    (tm:time-nanosecond-set! timout (%time-nanosecond timin))
790    (tm:time-second-set! timout (%time-second timin)))
791  timout )
792
793(define (tm:time-monotonic->time-utc timin timout)
794  #;(%time-type-set! timin 'tai) ;fool converter (unnecessary)
795  (tm:time-tai->time-utc timin timout) )
796
797;;; Date Object (Public Immutable)
798
799;; Leap Year Test
800
801;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
802;; The Journal of the Royal Astronomical Society of Canada.
803;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
804;; Part II, volume 58, number 2, pages 79-87 (April 1964).
805
806(define (tm:leap-year? yr)
807  (and
808    #; ;!NOT Officially Adopted!
809    (not (zero? (modulo yr 4000)))
810    (or
811      (zero? (modulo yr 400))
812      (and
813        (zero? (modulo yr 4))
814        (not (zero? (modulo yr 100)))))) )
815
816;; Days per Month
817
818;Month range 1..12 so dys/mn range 0..12
819(define      +year-dys/mn+ #(0 31 28 31 30 31 30 31 31 30 31 30 31))
820(define +leap-year-dys/mn+ #(0 31 29 31 30 31 30 31 31 30 31 30 31))
821
822(define-inline (days/month yr)
823  (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+) )
824
825(define (tm:leap-day? dy mn)
826  (= dy (vector-ref +leap-year-dys/mn+ mn)) )
827
828(define (tm:days-in-month yr mn)
829  (vector-ref (days/month yr) mn) )
830
831;;; Date Object (Public Mutable)
832
833(define-record-type-variant *date-tag* (unchecked inline unsafe)
834  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
835  %date?
836  (ns     %date-nanosecond  %date-nanosecond-set!)
837  (sec    %date-second      %date-second-set!)
838  (min    %date-minute      %date-minute-set!)
839  (hr     %date-hour        %date-hour-set!)
840  (dy     %date-day         %date-day-set!)
841  (mn     %date-month       %date-month-set!)
842  (yr     %date-year        %date-year-set!)
843  (tzo    %date-zone-offset %date-zone-offset-set!)
844  ;; non-srfi extn
845  (tzn    %date-zone-name   %date-zone-name-set!)
846  (dstf   %date-dst?        %date-dst-set!)
847  (wdy    %date-wday        %date-wday-set!)
848  (ydy    %date-yday        %date-yday-set!)
849  (jdy    %date-jday        %date-jday-set!) )
850
851;;
852
853;;; Getters
854
855(define (tm:date-nanosecond dat)
856  (%date-nanosecond dat) )
857
858(define (tm:date-second dat)
859  (%date-second dat) )
860
861(define (tm:date-minute dat)
862  (%date-minute dat) )
863
864(define (tm:date-hour dat)
865  (%date-hour dat) )
866
867(define (tm:date-day dat)
868  (%date-day dat) )
869
870(define (tm:date-month dat)
871  (%date-month dat) )
872
873(define (tm:date-year dat)
874  (%date-year dat) )
875
876(define (tm:date-zone-offset dat)
877  (%date-zone-offset dat) )
878
879(define (tm:date-zone-name dat)
880  (%date-zone-name dat) )
881
882(define (tm:date-dst? dat)
883  (%date-dst? dat) )
884
885(define (tm:date-wday dat)
886  (%date-wday dat) )
887
888(define (tm:date-yday dat)
889  (%date-yday dat) )
890
891(define (tm:date-jday dat)
892  (%date-jday dat) )
893
894;;; Setters
895
896(define (tm:date-nanosecond-set! dat x)
897  (%date-nanosecond-set! dat (number->integer x)) )
898
899(define (tm:date-second-set! dat x)
900  (%date-second-set! dat (number->integer x)) )
901
902(define (tm:date-minute-set! dat x)
903  (%date-minute-set! dat (number->integer x)) )
904
905(define (tm:date-hour-set! dat x)
906  (%date-hour-set! dat (number->integer x)) )
907
908(define (tm:date-day-set! dat x)
909  (%date-day-set! dat (number->integer x)) )
910
911(define (tm:date-month-set! dat x)
912  (%date-month-set! dat (number->integer x)) )
913
914(define (tm:date-year-set! dat x)
915  (%date-year-set! dat (number->integer x)) )
916
917(define (tm:date-zone-offset-set! dat x)
918  (%date-zone-offset-set! dat (number->integer x)) )
919
920;; Date TZ information extract
921
922(define (tm:date-timezone-info? obj)
923  (%date-timezone-info? obj) )
924
925(define (tm:date-timezone-info dat)
926  (%make-date-timezone-info
927    (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) )
928
929(define (tm:date? obj)
930  (%date? obj) )
931
932;; Returns an invalid date record (for use by 'scan-date')
933
934(define (tm:make-incomplete-date)
935  (%make-date
936    0
937    0 0 0
938    #f #f #f
939    (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
940    #f #f #f) )
941
942;; Internal Date CTOR
943
944(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
945  (%make-date
946    (number->integer ns)
947    (number->integer sec) (number->integer min) (number->integer hr)
948    (number->integer dy) (number->integer mn) (number->integer yr)
949    (number->integer tzo) tzn dstf
950    wdy ydy jdy) )
951
952(define (tm:copy-date dat)
953  (%make-date
954    (%date-nanosecond dat)
955    (%date-second dat) (%date-minute dat) (%date-hour dat)
956    (%date-day dat) (%date-month dat) (%date-year dat)
957    (%date-zone-offset dat)
958    (%date-zone-name dat) (%date-dst? dat)
959    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
960
961(define (tm:date-complete? dat)
962  (and
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
968(define (tm:seconds->date/type sec tzc)
969  (let* (
970    (isec (number->genint sec))
971    (tzo (timezone-locale-offset tzc))
972    ;seconds->utc-time cannot accept inexact-integer
973    (tv (seconds->utc-time (+ isec tzo))) )
974    (tm:make-date
975      (round (* (- sec isec) NS/S))
976      (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
977      (vector-ref tv 3) (+ 1 (vector-ref tv 4)) (+ 1900 (vector-ref tv 5))
978      tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
979      (vector-ref tv 6) (+ 1 (vector-ref tv 7)) #f) ) )
980
981(define (tm:current-date tzi)
982  (tm:time-utc->date (tm:current-time-utc) tzi) )
983
984;; Date Comparison
985
986(define (tm:date-compare dat1 dat2)
987  (let ((dif (- (%date-year dat1) (%date-year dat2))))
988    (if (not (zero? dif))
989      dif
990      (let ((dif (- (%date-month dat1) (%date-month dat2))))
991        (if (not (zero? dif))
992          dif
993          (let ((dif (- (%date-day dat1) (%date-day dat2))))
994            (if (not (zero? dif))
995              dif
996              (let ((dif (- (%date-hour dat1) (%date-hour dat2))))
997                (if (not (zero? dif))
998                  dif
999                  (let ((dif (- (%date-minute dat1) (%date-minute dat2))))
1000                    (if (not (zero? dif))
1001                      dif
1002                      (let ((dif (- (%date-second dat1) (%date-second dat2))))
1003                        (if (not (zero? dif))
1004                          dif
1005                          (- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) )
1006
1007;; Gives the seconds/day/month/year
1008
1009(define (tm:decode-julian-day-number jdn)
1010  (let* (
1011    (days (floor jdn))
1012    (a (+ days 32044))
1013    (b (quotient (+ (* 4 a) 3) 146097))
1014    (c (- a (quotient (* 146097 b) 4)))
1015    (d (quotient (+ (* 4 c) 3) 1461))
1016    (e (- c (quotient (* 1461 d) 4)))
1017    (m (quotient (+ (* 5 e) 2) 153))
1018    (y (+ (* 100 b) d (- JDYR) (quotient m 10))) )
1019    (values ;seconds date month year
1020     (* (- jdn days) SEC/DY)
1021     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
1022     (+ m 3 (* (- MN/YR) (quotient m 10)))
1023     (if (>= 0 y) (- y 1) y)) ) )
1024
1025;; Gives the Julian day number - rounds up to the nearest day
1026
1027(define (tm:seconds->julian-day-number sec tzo)
1028  (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
1029
1030;; Is the time object one second before a leap second?
1031
1032(define (tm:tai-before-leap-second? tim)
1033  (let ((sec (%time-second tim)))
1034    (let loop ((ls tm:second-before-leap-second-table))
1035      (and
1036        (not (null? ls))
1037        (or
1038          (= sec (car ls))
1039          (loop (cdr ls)) ) ) ) ) )
1040
1041(define (optional-tzinfo tzi)
1042  (cond
1043    ((%date-timezone-info? tzi)
1044      (values
1045        (%date-timezone-info-offset tzi)
1046        (%date-timezone-info-name tzi)
1047        (%date-timezone-info-dst? tzi)) )
1048    ((timezone-components? tzi)
1049      (values
1050        (timezone-locale-offset tzi)
1051        (timezone-locale-name tzi)
1052        (timezone-locale-dst? tzi)) )
1053    (else
1054      ;assume an offset
1055      (values tzi #f #f) ) ) )
1056
1057(define (tm:time-utc->date tim tzi)
1058  (let-values (
1059    ((tzo tzn dstf) (optional-tzinfo tzi)) )
1060    (let*-values (
1061      ((secs dy mn yr)
1062        (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo)))
1063      ((hr rem)
1064        (quotient&remainder secs SEC/HR))
1065      ((min sec)
1066        (quotient&remainder rem SEC/MIN)) )
1067      (tm:make-date
1068        (%time-nanosecond tim)
1069        sec min hr
1070        dy mn yr
1071        tzo tzn dstf
1072        #f #f #f) ) ) )
1073
1074(define (tm:time-tai->date tim tzi)
1075  (let (
1076    (tm-utc (tm:time-tai->time-utc tim (tm:any-time))) )
1077    (if (not (tm:tai-before-leap-second? tim))
1078      (tm:time-utc->date tm-utc tzi)
1079      ;else time is *right* before the leap,
1080      ;we need to pretend to subtract a second ...
1081      (let (
1082        (dat
1083          (tm:time-utc->date
1084            (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)) )
1085        (%date-second-set! dat SEC/MIN) ;Note full minute!
1086        dat ) ) ) )
1087
1088(define (tm:time->date tim tzi)
1089  (case (%time-type tim)
1090    ((utc)       (tm:time-utc->date tim tzi))
1091    ((tai)       (tm:time-tai->date tim tzi))
1092    ((monotonic) (tm:time-utc->date tim tzi))
1093    (else        #f)) )
1094
1095;; Date to Time
1096
1097;; Gives the Julian day number - Gregorian proleptic calendar
1098
1099(define (tm:encode-julian-day-number dy mn yr)
1100  (let* (
1101    (a (quotient (- 14 mn) MN/YR))
1102    (b (+ yr JDYR (- a)))
1103    (y (if (negative? yr) (+ 1 b) b)) ;BCE?
1104    (m (+ mn (* a MN/YR) -3)))
1105    (+ dy
1106      (quotient (+ (* 153 m) 2) 5)
1107      (* y DY/YR)
1108      (quotient y 4)
1109      (quotient y -100)
1110      (quotient y 400)
1111      -32045) ) )
1112
1113(define (tm:date->time-utc dat)
1114  (let (
1115    (ns (%date-nanosecond dat))
1116    (sec (%date-second dat))
1117    (min (%date-minute dat))
1118    (hr (%date-hour dat))
1119    (dy (%date-day dat))
1120    (mn (%date-month dat))
1121    (yr (%date-year dat))
1122    (tzo (%date-zone-offset dat)) )
1123    (let (
1124      (jdys
1125        (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
1126      (secs
1127        (+ (* hr SEC/HR) (* min SEC/MIN) sec (- tzo))) )
1128      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
1129
1130(define (tm:date->time-tai dat)
1131  (let* (
1132    (tm-utc (tm:date->time-utc dat))
1133    (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
1134    (if (not (= SEC/MIN (%date-second dat)))
1135      tm-tai
1136      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
1137
1138(define (tm:date->time-monotonic dat)
1139  (let ((tim-utc (tm:date->time-utc dat)))
1140    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
1141
1142(define (tm:date->time dat tt)
1143  (case tt
1144    ((utc)        (tm:date->time-utc dat))
1145    ((tai)        (tm:date->time-tai dat))
1146    ((monotonic)  (tm:date->time-monotonic dat))
1147    (else         #f) ) )
1148
1149;; Given a 'two digit' number, find the year within 50 years +/-
1150
1151(define (tm:natural-year n tzi)
1152  ;propagate the error
1153  (if (or (< n 0) (>= n 100))
1154    n
1155    (let* (
1156      (current-year     (%date-year (tm:current-date tzi)) )
1157      (current-century  (* (quotient current-year 100) 100) )
1158      (X                (+ current-century n (- current-year)) ) )
1159      (if (<= X 50)
1160        (+ current-century n)
1161        (+ (- current-century 100) n) ) ) ) )
1162
1163;; Day of Year
1164
1165(define +cumulative-month-days+ #(0 0 31 59 90 120 151 181 212 243 273 304 334))
1166
1167(define (tm:year-day dy mn yr)
1168  (let ((yrdy (+ dy (vector-ref +cumulative-month-days+ mn))))
1169    (if (and (tm:leap-year? yr) (< 2 mn))
1170      (+ yrdy 1)
1171      yrdy ) ) )
1172
1173(define (tm:cache-date-year-day dat)
1174  (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
1175    (%date-yday-set! dat yrdy)
1176    yrdy ) )
1177
1178(define (tm:date-year-day dat)
1179  (or
1180    (%date-yday dat)
1181    (tm:cache-date-year-day dat) ) )
1182
1183;; Week Day
1184
1185;; Using Gregorian Calendar (from Calendar FAQ)
1186
1187(: tm:week-day (fixnum fixnum fixnum --> fixnum))
1188
1189;Tomohiko Sakamoto algorithm
1190;Determination of the day of the week
1191;
1192;Jan 1st 1 AD is a Monday in Gregorian calendar.
1193;So Jan 0th 1 AD is a Sunday [It does not exist technically].
1194;
1195;Every 4 years we have a leap year. But xy00 cannot be a leap unless xy divides 4 with remainder 0.
1196;y/4 - y/100 + y/400 : this gives the number of leap years from 1AD to the
1197;given year. As each year has 365 days (divides 7 with remainder 1), unless it
1198;is a leap year or the date is in Jan or Feb, the day of a given date changes
1199;by 1 each year. In other cases it increases by 2.
1200;y -= m<3 : If the month is not Jan or Feb, we do not count the 29th Feb (if
1201;it exists) of the given year.
1202;So y + y/4 - y/100 + y/400  gives the day of Jan 0th (Dec 31st of prev year)
1203;of the year. (This gives the remainder with 7 of  the number of days passed
1204;before the given year began.)
1205;
1206;Array t:  Number of days passed before the month 'm+1' begins.
1207;
1208;So t[m-1]+d is the number of days passed in year 'y' up to the given date.
1209;(y + y/4 - y/100 + y/400 + t[m-1] + d) % 7 is remainder of the number of days
1210;from Jan 0 1AD to the given date which will be the day (0=Sunday,6=Saturday).
1211;
1212;Description credits: Sai Teja Pratap (quora.com/How-does-Tomohiko-Sakamotos-Algorithm-work)
1213#; ;???
1214(define tm:week-day
1215  (let (
1216    (t #(0 3 2 5 0 3 5 1 4 6 2 4)) )
1217    (lambda (dy mn yr)
1218      (let (
1219        (yr (if (< mn 3) (- yr 1) yr)) )
1220        (modulo (+ yr (/ yr 4) (/ yr -100) (vector-ref t (- mn 1)) dy) DY/WK) ) ) ) )
1221
1222(define (tm:week-day dy mn yr)
1223  (let* (
1224    (a (quotient (- 14 mn) MN/YR))
1225    (y (- yr a))
1226    (m (- (+ mn (* a MN/YR)) 2)) )
1227    (modulo
1228      (+ dy y
1229         (- (quotient y 4) (quotient y 100))
1230         (quotient y 400)
1231         (quotient (* m DY/MN) MN/YR))
1232      DY/WK) ) )
1233
1234(define (tm:cache-date-week-day dat)
1235  (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
1236    (%date-wday-set! dat wdy)
1237    wdy ) )
1238
1239(define (tm:date-week-day dat)
1240  (or
1241    (%date-wday dat)
1242    (tm:cache-date-week-day dat) ) )
1243
1244(define (tm:days-before-first-week dat 1st-weekday)
1245  (modulo
1246    (- 1st-weekday (tm:week-day 1 1 (%date-year dat)))
1247    DY/WK) )
1248
1249(define (tm:date-week-number dat 1st-weekday)
1250  (quotient
1251    (- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
1252    DY/WK) )
1253
1254;; Julian-day Operations
1255
1256(define (tm:julian-day->modified-julian-day mjdn)
1257  (- mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1258
1259;; Date to Julian-day
1260
1261(define (tm:jd-time->seconds ns sec min hr tzo)
1262  (+ (* hr SEC/HR) (* min SEC/MIN) sec (- tzo) (/ ns NS/S)) )
1263
1264; Does the nanoseconds value contribute anything to the julian day?
1265; The range is < 1 second here (but not in the reference).
1266
1267(define (tm:julian-day ns sec min hr dy mn yr tzo)
1268  (let (
1269    (jdn
1270      (tm:encode-julian-day-number dy mn yr))
1271    (timsecs
1272      (tm:jd-time->seconds ns sec min hr tzo)) )
1273    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
1274
1275(define (tm:date->julian-day dat)
1276  (or
1277    (%date-jday dat)
1278    (let (
1279      (jdn
1280        (tm:julian-day
1281          (%date-nanosecond dat)
1282          (%date-second dat) (%date-minute dat) (%date-hour dat)
1283          (%date-day dat) (%date-month dat) (%date-year dat)
1284          (%date-zone-offset dat))))
1285      (%date-jday-set! dat jdn)
1286      jdn ) ) )
1287
1288;; Time to Julian-day
1289
1290(define (tm:seconds->julian-day ns sec)
1291  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
1292
1293(define (tm:time-utc->julian-day tim)
1294  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
1295
1296(define (tm:time-tai->julian-day tim)
1297  (let ((sec (%time-second tim)))
1298    (tm:seconds->julian-day
1299      (%time-nanosecond tim)
1300      (- sec (leap-second-delta sec))) ) )
1301
1302(define tm:time-monotonic->julian-day tm:time-tai->julian-day)
1303
1304(define (tm:time->julian-day tim)
1305  (case (%time-type tim)
1306    ((utc)        (tm:time-utc->julian-day tim))
1307    ((tai)        (tm:time-tai->julian-day tim))
1308    ((monotonic)  (tm:time-monotonic->julian-day tim))
1309    (else         #f)) )
1310
1311(define (tm:time-utc->modified-julian-day tim)
1312  (tm:julian-day->modified-julian-day (tm:time-utc->julian-day tim)) )
1313
1314(define (tm:time-tai->modified-julian-day tim)
1315  (tm:julian-day->modified-julian-day (tm:time-tai->julian-day tim)) )
1316
1317(define (tm:time-monotonic->modified-julian-day tim)
1318  (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )
1319
1320(define (tm:time->modified-julian-day tim)
1321  (case (%time-type tim)
1322    ((utc)        (tm:time-utc->modified-julian-day tim))
1323    ((tai)        (tm:time-tai->modified-julian-day tim))
1324    ((monotonic)  (tm:time-monotonic->modified-julian-day tim))
1325    (else         #f)) )
1326
1327;; Julian-day to Time
1328
1329(define (tm:julian-day->nanoseconds jdn)
1330  (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S) )
1331
1332(define (tm:julian-day->time-values jdn)
1333  (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)) )
1334
1335(define (tm:modified-julian-day->julian-day mjdn)
1336  (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1337
1338(define (tm:julian-day->time-utc jdn)
1339  (let-values (((sec ns) (tm:julian-day->time-values jdn)))
1340    (tm:make-time 'time-utc ns sec) ) )
1341
1342(define (tm:modified-julian-day->time-utc mjdn)
1343  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
1344
1345(define (tm:default-date-adjust-integer amt)
1346  (round amt) )
1347
1348) ;module srfi-19-tm
Note: See TracBrowser for help on using the repository browser.