source: project/release/5/srfi-19/trunk/srfi-19-support.scm @ 38121

Last change on this file since 38121 was 38121, checked in by Kon Lovett, 3 months ago

fix seconds->utc-time C4 arg type assumption (reported by tokyo_jesus on #chicken irc), generalize number->genint, ...->genint already floors

File size: 54.7 KB
Line 
1;;;; srfi-19-support.scm
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;; Bugs
42;;
43;; - The 'date-dst?' field is problimatic. It is only valid on certain
44;; platforms & only when current. A past or future date will not have this
45;; field correct!
46;;
47;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
48;; NOT the state of the converted date.
49
50;; Notes
51;;
52;; - There is no year zero. So when converting from a BCE year on the sign of the year
53;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
54;;
55;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
56;; UTC & a subtracted offset is "towards" UTC.
57;;
58;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
59;; conversion procedure.
60
61(module srfi-19-support
62
63(;export
64  ;;Public
65  time? check-time error-time
66  time-type? check-time-type error-time-type
67  time-seconds? check-time-seconds error-time-seconds
68  time-nanoseconds? check-time-nanoseconds error-time-nanoseconds
69  clock-type? check-clock-type error-clock-type
70  date? check-date error-date
71  date-nanoseconds? check-date-nanoseconds error-date-nanoseconds
72  date-seconds? check-date-seconds error-date-seconds
73  date-minutes? check-date-minutes error-date-minutes
74  date-hours? check-date-hours error-date-hours
75  date-day? check-date-day error-date-day
76  date-month? check-date-month error-date-month
77  date-year? check-date-year error-date-year
78  week-day? check-week-day error-week-day
79  julian-day? check-julian-day error-julian-day
80  time-record-printer-format
81  date-record-printer-format
82  check-raw-seconds
83  check-raw-milliseconds
84  check-time-has-type
85  check-time-and-type
86  check-duration
87  check-time-elements
88  check-times
89  check-time-binop
90  check-time-compare
91  check-time-aritmetic
92  check-date-elements
93  check-date-compatible-timezone-offsets
94  error-incompatible-time-types
95  error-convert
96  error-date-compatible-timezone
97  ;;Private
98  tm:read-tai-utc-data
99  tm:calc-second-before-leap-second-table
100  tm:read-leap-second-table
101  (tm:any-time %make-time)
102  (tm:some-time %make-time)
103  (tm:as-some-time %time-type %make-time)
104  (tm:time-type %time-type)
105  (tm:time-nanosecond %time-second)
106  (tm:time-second %time-nanosecond)
107  (tm:time-type-set! %time-type-set!)
108  (tm:time-nanosecond-set! %time-nanosecond-set!)
109  (tm:time-second-set! %time-second-set!)
110  tm:make-time
111  (tm:copy-time %make-time)
112  (tm:time-has-type? %time-type)
113  tm:nanoseconds->time-values
114  tm:time->nanoseconds
115  tm:time->milliseconds
116  tm:nanoseconds->seconds
117  tm:milliseconds->seconds
118  tm:time->seconds
119  tm:duration-elements->time-values
120  tm:milliseconds->time-values
121  tm:seconds->time-values
122  tm:seconds->time
123  (tm:current-time-values tm:current-nanoseconds)
124  tm:current-time-utc
125  (tm:current-time-tai leap-second-delta)
126  tm:current-time-monotonic
127  (tm:current-time-thread current-thread-milliseconds)
128  (tm:current-time-process current-process-milliseconds)
129  (tm:current-time-gc current-gc-milliseconds total-gc-milliseconds)
130  tm:time-resolution
131  tm:time-compare
132  tm:time=?
133  tm:time<?
134  tm:time<=?
135  tm:time>?
136  tm:time>=?
137  tm:time-max
138  tm:time-min
139  tm:time-difference
140  tm:add-duration
141  tm:subtract-duration
142  tm:divide-duration
143  tm:multiply-duration
144  tm:time-abs
145  tm:time-negate
146  tm:time-zero? tm:time-positive? tm:time-negative?
147  (tm:time-tai->time-utc leap-second-neg-delta)
148  tm:time-tai->time-monotonic
149  tm:time-utc->time-tai
150  tm:time-utc->time-monotonic
151  tm:time-monotonic->time-tai
152  tm:time-monotonic->time-utc
153  tm:leap-year?
154  (tm:leap-day? +leap-year-dys/mn+)
155  (tm:days-in-month +leap-year-dys/mn+ +year-dys/mn+)
156  (tm:date-nanosecond %date-nanosecond)
157  (tm:date-second %date-second)
158  (tm:date-minute %date-minute)
159  (tm:date-hour %date-hour)
160  (tm:date-day %date-day)
161  (tm:date-month %date-month)
162  (tm:date-year %date-year)
163  (tm:date-zone-offset %date-zone-offset)
164  (tm:date-zone-name %date-zone-name)
165  (tm:date-dst? %date-dst?)
166  tm:date-wday
167  tm:date-yday
168  tm:date-jday
169  (tm:date-timezone-info %make-date-timezone-info)
170  (tm:date-nanosecond-set! %date-nanosecond-set!)
171  (tm:date-second-set! %date-second-set!)
172  (tm:date-minute-set! %date-minute-set!)
173  (tm:date-hour-set! %date-hour-set!)
174  (tm:date-day-set! %date-day-set!)
175  (tm:date-month-set! %date-month-set!)
176  (tm:date-year-set! %date-year-set!)
177  (tm:date-zone-offset-set! %date-zone-offset-set!)
178  (tm:make-incomplete-date %make-date)
179  (tm:make-date %make-date)
180  (tm:copy-date %date-nanosecond %date-second %date-minute %date-hour
181    %date-day %date-month %date-year
182    %date-zone-offset %date-zone-name
183    %date-jday %date-yday %date-wday
184    %make-date)
185  tm:seconds->date/type
186  tm:current-date
187  (tm:date-compare %date-nanosecond %date-second %date-minute %date-hour
188    %date-day %date-month %date-year)
189  tm:decode-julian-day-number
190  tm:seconds->julian-day-number
191  tm:tai-before-leap-second?
192  tm:time-utc->date
193  tm:time-tai->date
194  tm:time->date
195  tm:encode-julian-day-number
196  tm:date->time-utc
197  tm:date->time-tai
198  tm:date->time-monotonic
199  tm:date->time
200  tm:natural-year
201  tm:year-day
202  tm:date-year-day
203  tm:week-day
204  tm:days-before-first-week
205  tm:date-week-day
206  tm:date-week-number
207  tm:julian-day->modified-julian-day
208  tm:julian-day
209  (tm:date->julian-day %date-nanosecond %date-second %date-minute %date-hour
210    %date-day %date-month %date-year
211    %date-zone-offset
212    %date-jday %date-jday-set!)
213  tm:seconds->julian-day
214  tm:time-utc->julian-day
215  tm:time-tai->julian-day
216  tm:time-monotonic->julian-day
217  tm:time->julian-day
218  tm:time-utc->modified-julian-day
219  tm:time-tai->modified-julian-day
220  tm:time-monotonic->modified-julian-day
221  tm:time->modified-julian-day
222  tm:julian-day->nanoseconds
223  tm:julian-day->time-values
224  tm:modified-julian-day->julian-day
225  tm:julian-day->time-utc
226  tm:modified-julian-day->time-utc
227  tm:default-date-adjust-integer)
228
229(import scheme)
230(import (chicken base))
231(import (chicken type))
232(import (chicken fixnum))
233(import (only srfi-1 fold))
234(import (only (chicken io) read-line))
235(import (only (chicken read-syntax) define-reader-ctor))
236(import (only (chicken gc) current-gc-milliseconds))
237(import (only (chicken format) format))
238(import (only (chicken time) cpu-time current-seconds current-milliseconds))
239(import (only (chicken time posix) seconds->utc-time))
240(import (only (chicken string) conc))
241(import (only (chicken port) with-input-from-port with-input-from-string))
242(import locale)
243(import record-variants)
244(import type-checks)
245(import type-errors)
246(import srfi-19-timezone)
247
248;;;
249
250(include "srfi-19-common")
251
252;;;NOTE the use of syntax for inlining is an experiment. no procedure w/
253;;;arithmetic can be exported as syntax.
254;;
255;; For storage savings since some aritmetic routines do not
256;; return fixnums when possible.
257;;
258;; ##sys#integer?
259;; returns #t for integer fixnum or flonum
260;;
261;; C_double_to_number
262;; returns a fixnum for the flonum x iff x isa integer in fixnum-range
263;; otherwise the flonum x
264;;
265;; When domain is integer and range is fixnum
266;; Number MUST be a fixnum or flonum
267
268(define-syntax number->genint
269  (syntax-rules ()
270    ((_ ?x)
271      (let ((x ?x))
272        (if (exact? x)
273          x
274          (inexact->exact (floor x)) ) ) ) ) )
275
276;;; Timing Routines
277
278;; Provide system timing reporting procedures
279
280(define total-gc-milliseconds
281  (let ((accum-ms 0))
282    (lambda ()
283      (set! accum-ms (+ accum-ms (current-gc-milliseconds)))
284      accum-ms ) ) )
285
286(define (current-process-milliseconds)
287  (let-values (((ums sms) (cpu-time)))
288    (+ ums sms) ) )
289
290;FIXME needs a srfi-18 extension
291(define current-thread-milliseconds current-process-milliseconds)
292
293;;; Constants
294
295;; TAI-EPOCH: 1 January 1970 CE at 00:00:00 UTC
296
297(define-constant TAI-EPOCH-YEAR 1970)
298
299;(Chicken reader doesn't grok ratios w/o numbers egg at compile time.)
300
301;; Used in julian calculation
302
303(define ONE-HALF (string->number "1/2"))
304
305;; Julian Day 0 = 1 January 4713 BCE at 12:00:00 UTC (Julian proleptic calendar)
306;; Julian Day 0 = 24 November 4714 BCE at 12:00:00 UTC (Gregorian proleptic calendar)
307
308(define TAI-EPOCH-IN-JD (string->number "4881175/2"))
309
310;; Modified Julian Day 0 = 17 Nov 1858 CE at 00:00:00 UTC
311;; Number of days less than a julian day.
312
313(define TAI-EPOCH-IN-MODIFIED-JD (string->number "4800001/2"))
314
315;; Julian conversion base century
316
317(define-constant JDYR 4800)
318
319;;; Leap Seconds
320
321;; First leap year after epoch
322
323(define-constant FIRST-LEAP-YEAR 1972)
324
325;; Number of seconds after epoch of first leap year
326
327(define LEAP-START (fx* (fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR) SEC/YR))
328
329;; A table of leap seconds
330;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary.
331;; See "https://www.ietf.org/timezones/data/leap-seconds.list"
332;; seconds since 1900 - seconds since 1972 = 2208988800
333;; Each entry is (utc seconds since epoch . # seconds to add for tai)
334;; Note they go higher (2009) to lower (1972).
335
336(define tm:leap-second-table
337  '((1483228800 . 37)
338    (1435708800 . 36)
339    (1341100800 . 35)
340    (1230768000 . 34)
341    (1136073600 . 33)
342    (915148800 . 32)
343    (867715200 . 31)
344    (820454400 . 30)
345    (773020800 . 29)
346    (741484800 . 28)
347    (709948800 . 27)
348    (662688000 . 26)
349    (631152000 . 25)
350    (567993600 . 24)
351    (489024000 . 23)
352    (425865600 . 22)
353    (394329600 . 21)
354    (362793600 . 20)
355    (315532800 . 19)
356    (283996800 . 18)
357    (252460800 . 17)
358    (220924800 . 16)
359    (189302400 . 15)
360    (157766400 . 14)
361    (126230400 . 13)
362    (94694400 . 12)
363    (78796800 . 11)
364    (63072000 . 10)
365    #;(-60480000 . 4.21317)   ;Before 1972
366    #;(-126230400 . 4.31317)
367    #;(-136771200 . 3.84013)
368    #;(-142128000 . 3.74013)
369    #;(-152668800 . 3.64013)
370    #;(-157766400 . 3.54013)
371    #;(-168307200 . 3.44013)
372    #;(-181526400 . 3.34013)
373    #;(-189388800 . 3.24013)
374    #;(-194659200 . 1.945858)
375    #;(-252460800 . 1.845858)
376    #;(-265680000 . 1.372818)
377    #;(-283996800 . 1.422818) ) )
378
379;; This procedure reads the file in the
380;; ftp://maia.usno.navy.mil/ser7/tai-utc.dat format and
381;; creates a leap second table
382
383(define (tm:read-tai-utc-data flnm)
384  ;
385  (define (convert-jd jd)
386    (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))
387  ;
388  (define (convert-sec sec)
389    (inexact->exact sec))
390  ;
391  (define (read-data)
392    (let loop ((ls '()))
393      (let ((line (read-line)))
394        (if (eof-object? line)
395          ls
396          (let ((data (with-input-from-string (string-append "(" line ")") read)))
397            (let ((year (car data))
398                  (jd   (cadddr (cdr data)))
399                  (secs (cadddr (cdddr data))))
400              (loop
401                (if (< year FIRST-LEAP-YEAR) ls
402                (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
403  ;
404  (with-input-from-port (open-input-file flnm) read-data) )
405
406;; Table of cummulative seconds, one second before the leap second.
407
408(define (tm:calc-second-before-leap-second-table table)
409  (let loop ((inlst table) (outlst '()))
410    (if (null? inlst)
411      (reverse outlst) ;keep input order anyway
412      (let ((itm (car inlst)))
413        (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )
414
415(define tm:second-before-leap-second-table
416  (tm:calc-second-before-leap-second-table tm:leap-second-table))
417
418;; Read a leap second table file in U.S. Naval Observatory format
419
420(define (tm:read-leap-second-table flnm)
421  (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
422  (set!
423    tm:second-before-leap-second-table
424    (tm:calc-second-before-leap-second-table tm:leap-second-table)) )
425
426;; leap-second-delta algorithm
427
428; 'leap-second-item' is like the 'it' in the anaphoric 'if'
429;
430(define-syntax find-leap-second-delta*
431  (er-macro-transformer
432    (lambda (form r c)
433      (let ((_let (r 'let))
434            (_if (r 'if))
435            (_null? (r 'null?))
436            (_car (r 'car))
437            (_cdr (r 'cdr))
438            (_leap-second-item (r 'leap-second-item)) )
439        (let ((?secs (cadr form))
440              (?ls (caddr form))
441              (?tst (cadddr form)) )
442          `(,_let loop ((lsvar ,?ls))
443              (,_if (,_null? lsvar) 0
444                (,_let ((leap-second-item (,_car lsvar)))
445                    (,_if ,?tst
446                        (,_cdr leap-second-item)
447                        (loop (,_cdr lsvar)) ) ) ) ) ) ) ) ) )
448
449(define-syntax leap-second-delta*
450  (er-macro-transformer
451    (lambda (form r c)
452      (let ((_let (r 'let))
453            (_if (r 'if))
454            (_< (r '<))
455            (_tm:leap-second-table (r 'tm:leap-second-table))
456            (_LEAP-START (r 'LEAP-START))
457            (_find-leap-second-delta* (r 'find-leap-second-delta*)) )
458        (let ((?secs (cadr form))
459              (?tst (caddr form)) )
460          `(,_if (,_< ,?secs ,_LEAP-START)
461              0
462              (,_find-leap-second-delta* ,?secs ,_tm:leap-second-table ,?tst) ) ) ) ) ) )
463
464;; Going from utc seconds ...
465
466(define (leap-second-delta utc-seconds)
467  (leap-second-delta*
468    utc-seconds
469    (<= (car leap-second-item) utc-seconds)) )
470
471;; Going from tai seconds to utc seconds ...
472
473(define (leap-second-neg-delta tai-seconds)
474  (leap-second-delta*
475    tai-seconds
476    (<= (cdr leap-second-item) (- tai-seconds (car leap-second-item)))) )
477
478;;; Time Object (Public Mutable)
479
480;; There are 3 kinds of time record procedures:
481;; *...   - generated
482;; tm:... - argument processing then *...
483;; ...    - argument checking then tm:...
484
485;#| ;dependency
486(define-constant srfi-19-time 'srfi-19-time)
487(define-record-type-variant srfi-19-time (unchecked #;inline unsafe)
488  (%make-time tt ns sec)
489  %time?
490  (tt   %time-type        %time-type-set!)
491  (ns   %time-nanosecond  %time-nanosecond-set!)
492  (sec  %time-second      %time-second-set!) )
493;|#
494#; ;no (define-record-type srfi-19-time
495(define-record-type srfi-19-time
496  (%make-time tt ns sec)
497  %time?
498  (tt   %time-type        %time-type-set!)
499  (ns   %time-nanosecond  %time-nanosecond-set!)
500  (sec  %time-second      %time-second-set!) )
501
502(define (time? obj)
503  (%time? obj) )
504
505;; Time to Date
506
507(define ONE-SECOND-DURATION (%make-time 'duration 0 1))
508
509;;
510
511;; <time-unit-value> -> <ns sec>
512
513(define-inline (normalize-timeval t t/t+1)
514  (values (remainder t t/t+1) (quotient t t/t+1)) )
515
516(define (normalize-nanoseconds ns)
517  (normalize-timeval ns NS/S) )
518
519; <ns sec min hr> -> <ns sec min hr dy>
520;
521#; ;UNUSED
522(define (normalize-time ns sec min hr)
523  (let*-values (
524      ((ns ns-sec)    (normalize-nanoseconds ns))
525      ((sec sec-min)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
526      ((min min-hr)   (normalize-timeval (+ min sec-min) MIN/HR))
527      ((hr hr-dy)     (normalize-timeval (+ hr min-hr) HR/DY)) )
528    (values ns sec min hr (+ dy hr-dy)) ) )
529
530;;
531
532(define-constant TIME-FORMAT-SRFI-10 "#,(srfi-19-time ~A ~A ~A)")
533(define-constant TIME-FORMAT-BRACKET "#<srfi-19-time ~A ~A ~A>")
534
535(define time-record-printer-format (make-parameter 'SRFI-10
536  (lambda (x)
537    (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
538      x
539      (begin
540        (warning 'time-record-printer-format "invalid format" x)
541        (time-record-printer-format) ) ) ) ) )
542
543(define (time-record-printer-format-string)
544  (case (time-record-printer-format)
545    ((srfi-10 SRFI-10)
546      TIME-FORMAT-SRFI-10 )
547    (else
548      TIME-FORMAT-BRACKET ) ) )
549
550(define-record-printer (srfi-19-time tim out)
551  (format out (time-record-printer-format-string)
552    (%time-type tim)
553    (%time-nanosecond tim)
554    (%time-second tim)) )
555
556;SRFI-10
557(define-reader-ctor 'srfi-19-time
558  (lambda (tt ns sec)
559    (%make-time tt ns sec)))
560
561;;
562
563(define (time-type? obj)
564  (memq obj '(monotonic utc tai gc duration process thread)) )
565
566(define (time-seconds? obj)
567  (integer? obj) )
568
569(define (time-nanoseconds? obj)
570  (and (fixnum? obj) (fx< -NS/S obj) (fx< obj NS/S)) )
571
572;;
573
574(define-check+error-type time %time?)
575(define-check+error-type time-type)
576(define-check+error-type time-seconds)
577(define-check+error-type time-nanoseconds)
578
579;; Output Argument CTORs
580
581;Used to create an output time record where all fields will be set later
582;
583(define-syntax tm:any-time
584        (syntax-rules ()
585                ((_)
586      (%make-time #f #f #f) ) ) )
587
588;Used to create a time record where ns & sec fields will be set later
589;
590(define-syntax tm:some-time
591        (syntax-rules ()
592                ((_ ?tt)
593                  (let ((tt ?tt))
594        (%make-time tt #f #f) ) ) ) )
595
596;Used to create a time record where ns & sec fields will be set later
597;
598(define-syntax tm:as-some-time
599        (syntax-rules ()
600                ((_ ?tim)
601                  (let ((tim ?tim))
602        (%make-time (%time-type tim) #f #f) ) ) ) )
603
604;;
605
606(define-syntax tm:time-type
607        (syntax-rules ()
608                ((_ ?tim)
609                  (let ((tim ?tim))
610        (%time-type tim) ) ) ) )
611
612(define-syntax tm:time-second
613        (syntax-rules ()
614                ((_ ?tim)
615                  (let ((tim ?tim))
616        (%time-second tim) ) ) ) )
617
618(define-syntax tm:time-nanosecond
619        (syntax-rules ()
620                ((_ ?tim)
621                  (let ((tim ?tim))
622        (%time-nanosecond tim) ) ) ) )
623
624(define-syntax tm:time-type-set!
625        (syntax-rules ()
626                ((_ ?tim ?typ)
627                  (let ((tim ?tim) (typ ?typ))
628        (%time-type-set! tim typ) ) ) ) )
629
630(define-syntax tm:time-nanosecond-set!
631        (syntax-rules ()
632                ((_ ?tim ?ns)
633                  (let ((tim ?tim) (ns ?ns))
634        (%time-nanosecond-set! tim (number->genint ns)) ) ) ) )
635
636(define-syntax tm:time-second-set!
637        (syntax-rules ()
638                ((_ ?tim ?sec)
639                  (let ((tim ?tim) (sec ?sec))
640        (%time-second-set! tim (number->genint sec)) ) ) ) )
641
642(define (tm:make-time tt ns sec)
643  (let-values (((ns ns-sec) (normalize-nanoseconds ns)))
644    (%make-time tt (number->genint ns) (number->genint (+ sec ns-sec))) ) )
645
646(define-syntax tm:copy-time
647        (syntax-rules ()
648                ((_ ?tim)
649                  (let ((tim ?tim))
650        (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) ) ) ) )
651
652(define-syntax tm:time-has-type?
653        (syntax-rules ()
654                ((_ ?tim ?tt)
655                  (let ((tim ?tim) (tt ?tt))
656        (eq? tt (%time-type tim)) ) ) ) )
657
658;; Rem & Quo of nanoseconds per second
659
660(define (tm:nanoseconds->time-values nanos)
661  (values (remainder nanos NS/S) (quotient nanos NS/S)) )
662
663;; Seconds Conversion
664
665(define (check-raw-seconds loc obj) (check-real loc obj 'seconds))
666
667(define (check-raw-milliseconds loc obj) (check-real loc obj 'milliseconds))
668
669;;
670
671(define (tm:time->nanoseconds tim)
672  (+ (%time-nanosecond tim) (* (%time-second tim) NS/S)) )
673
674(define (tm:time->milliseconds tim)
675  (+ (/ (%time-nanosecond tim) NS/MS) (* (%time-second tim) MS/S)) )
676
677(define (tm:nanoseconds->seconds ns)
678  (/ ns NS/S) )
679
680(define (tm:milliseconds->seconds ms)
681  (/ (exact->inexact ms) MS/S) )
682
683(define-syntax tm:time->seconds
684        (syntax-rules ()
685                ((_ ?tim)
686                  (let ((tim ?tim))
687                    (tm:nanoseconds->seconds (tm:time->nanoseconds tim)) ) ) ) )
688
689(define (tm:duration-elements->time-values
690          days
691          hours minutes seconds
692          milliseconds microseconds nanoseconds)
693        (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
694        (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
695    (let-values (((ns-ns ns-secs)
696                  (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))))
697      (values ns-ns (+ (floor secs) ns-secs)) ) ) )
698
699(define (tm:seconds->time-values sec)
700  (let* ((tsec (number->genint sec))
701         (ns (number->genint (exact->inexact (round (* (- sec tsec) NS/S))))) )
702    (values ns tsec) ) )
703
704(define (tm:milliseconds->time-values ms)
705  (let ((ns (fx* (number->genint (remainder ms MS/S)) NS/MS))
706        (sec (quotient ms MS/S)) )
707    (values ns sec) ) )
708
709(define-syntax tm:milliseconds->time
710        (syntax-rules ()
711                ((_ ?ms ?tt)
712                  (let ((ms ?ms) (tt ?tt))
713        (let-values (((ns sec) (tm:milliseconds->time-values ms)))
714          (tm:make-time tt ns sec) ) ) ) ) )
715
716(define-syntax tm:seconds->time
717        (syntax-rules ()
718                ((_ ?sec ?tt)
719                  (let ((sec ?sec) (tt ?tt))
720        (let-values (((ns sec) (tm:seconds->time-values sec)))
721          (tm:make-time tt ns sec) ) ) ) ) )
722
723;; Current time routines
724
725; Throw away everything but the sub-second bit.
726;
727(define (tm:current-sub-milliseconds)
728        (inexact->exact (remainder (current-milliseconds) MS/S)) )
729
730(define (tm:current-nanoseconds)
731  (fx* (tm:current-sub-milliseconds) NS/MS) )
732
733;Use the 'official' seconds & nanoseconds values
734;
735(define-syntax tm:current-time-values
736        (syntax-rules ()
737                ((_)
738      (values (tm:current-nanoseconds) (current-seconds)) ) ) )
739
740(define-syntax tm:current-time-utc
741        (syntax-rules ()
742                ((_)
743                  (let-values (((ns sec) (tm:current-time-values)))
744        (tm:make-time 'utc ns sec) ) ) ) )
745
746(define-syntax tm:current-time-tai
747        (syntax-rules ()
748                ((_)
749      (let-values (((ns sec) (tm:current-time-values)))
750        (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) ) ) )
751
752(define-syntax tm:current-time-monotonic
753        (syntax-rules ()
754                ((_)
755      (let ((tim (tm:current-time-tai)))
756        ;time-monotonic is time-tai
757        (%time-type-set! tim 'monotonic)
758        tim ) ) ) )
759
760(define-syntax tm:current-time-thread
761        (syntax-rules ()
762                ((_)
763      (tm:milliseconds->time (current-thread-milliseconds) 'thread) ) ) )
764
765(define-syntax tm:current-time-process
766        (syntax-rules ()
767                ((_)
768      (tm:milliseconds->time (current-process-milliseconds) 'process) ) ) )
769
770(define-syntax tm:current-time-gc
771        (syntax-rules ()
772                ((_)
773      (tm:milliseconds->time (total-gc-milliseconds) 'gc) ) ) )
774
775;; -- Time Resolution
776;; This is the resolution of the clock in nanoseconds.
777;; This will be implementation specific.
778
779(define (tm:time-resolution tt)
780  NS/MS )
781
782;; Specialized Time Parameter Checking
783
784(define (error-incompatible-time-types loc tt1 tt2)
785  (signal-type-error loc "incompatible time-types"  tt1 tt2) )
786
787(define (check-time-has-type loc tim tt)
788  (unless (tm:time-has-type? tim tt)
789    (error-incompatible-time-types loc (%time-type tim) tt) ) )
790
791(define (check-time-and-type loc tim tt)
792  (check-time loc tim)
793  (check-time-has-type loc tim tt) )
794
795(define (check-duration loc obj)
796  (check-time-and-type loc obj 'duration) )
797
798(define (check-time-elements loc obj1 obj2 obj3)
799  (check-time-type loc obj1)
800  (check-time-nanoseconds loc obj2)
801  (check-time-seconds loc obj3) )
802
803(define (check-times loc objs)
804  (for-each (cut check-time loc <>) objs) )
805
806(define (check-time-binop loc obj1 obj2)
807  (check-time loc obj1)
808  (check-time loc obj2) )
809
810(define (check-time-compare loc obj1 obj2)
811  (check-time-binop loc obj1 obj2)
812  (check-time-has-type loc obj1 (%time-type obj2)) )
813
814(define (check-time-aritmetic loc tim dur)
815  (check-time loc tim)
816  (check-duration loc dur) )
817
818;; Time Comparison
819
820(define (tm:time-compare tim1 tim2)
821  (let ((dif (- (%time-second tim1) (%time-second tim2))))
822    (if (not (zero? dif))
823      dif
824      (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
825
826(define (tm:time=? tim1 tim2)
827  (and
828    (= (%time-second tim1) (%time-second tim2))
829    (fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
830
831(define (tm:time<? tim1 tim2)
832  (or
833    (< (%time-second tim1) (%time-second tim2))
834    (and
835      (= (%time-second tim1) (%time-second tim2))
836      (fx< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
837
838(define (tm:time<=? tim1 tim2)
839  (or
840    (< (%time-second tim1) (%time-second tim2))
841    (and
842      (= (%time-second tim1) (%time-second tim2))
843      (fx<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
844
845(define (tm:time>? tim1 tim2)
846  (or
847    (> (%time-second tim1) (%time-second tim2))
848    (and
849      (= (%time-second tim1) (%time-second tim2))
850      (fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
851
852(define (tm:time>=? tim1 tim2)
853  (or
854    (> (%time-second tim1) (%time-second tim2))
855    (and
856      (= (%time-second tim1) (%time-second tim2))
857      (fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
858
859(define-syntax tm:time-max
860        (syntax-rules ()
861                ((_ ?tim1 ?tim2)
862                  (let ((tim1 ?tim1) (tim2 ?tim2))
863        (if (tm:time>? tim1 tim2) tim1 tim2) ) ) ) )
864
865(define-syntax tm:time-min
866        (syntax-rules ()
867                ((_ ?tim1 ?tim2)
868                  (let ((tim1 ?tim1) (tim2 ?tim2))
869        (if (tm:time<? tim1 tim2) tim1 tim2) ) ) ) )
870
871;; Time Arithmetic
872
873(define (tm:add-duration tim1 dur timout)
874        (let-values (((ns sec)
875                (tm:nanoseconds->time-values
876                  (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
877    (let ((secs (+ (%time-second tim1) (%time-second dur) sec)))
878      (cond
879        ((negative? ns) ;Borrow
880          ;Should never happen
881          (tm:time-second-set! timout (+ secs -1))
882          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
883        (else
884          (tm:time-second-set! timout secs)
885          (tm:time-nanosecond-set! timout ns) ) )
886      timout ) ) )
887
888(define (tm:subtract-duration tim1 dur timout)
889  (let-values (((ns sec)
890                (tm:nanoseconds->time-values
891                  (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
892    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
893    (let ((secs (- (%time-second tim1) (%time-second dur) sec)))
894      (cond
895        ((negative? ns) ;Borrow
896          (tm:time-second-set! timout (- secs 1))
897          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
898        (else
899          (tm:time-second-set! timout secs)
900          (tm:time-nanosecond-set! timout ns) ) )
901      timout ) ) )
902
903(define (tm:divide-duration dur1 num durout)
904  (let-values (((ns sec)
905                (tm:nanoseconds->time-values
906                  (/ (tm:time->nanoseconds dur1) num))) )
907    (tm:time-nanosecond-set! durout ns)
908    (tm:time-second-set! durout sec)
909    durout ) )
910
911(define (tm:multiply-duration dur1 num durout)
912        (let-values (((ns sec)
913                (tm:nanoseconds->time-values
914                  (* (tm:time->nanoseconds dur1) num))) )
915    (tm:time-nanosecond-set! durout ns)
916    (tm:time-second-set! durout sec)
917    durout ) )
918
919(define (tm:time-difference tim1 tim2 timout)
920  (let-values (((ns sec)
921                (tm:nanoseconds->time-values
922                  (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
923    (tm:time-second-set! timout sec)
924    (tm:time-nanosecond-set! timout ns)
925    timout ) )
926
927(define-syntax tm:time-abs
928        (syntax-rules ()
929                ((_ ?tim1 ?timout)
930                  (let ((tim1 ?tim1)
931                        (timout ?timout))
932        (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
933        (tm:time-second-set! timout (abs (%time-second tim1)))
934        timout ) ) ) )
935
936(define (tm:time-negate tim1 timout )
937  (tm:time-nanosecond-set! timout (- (%time-nanosecond tim1)))
938  (tm:time-second-set! timout (- (%time-second tim1)))
939  timout )
940
941(define (tm:time-negative? tim)
942  ;nanoseconds irrelevant
943  (negative? (tm:time-second tim)) )
944
945(define (tm:time-positive? tim)
946  ;nanoseconds irrelevant
947  (positive? (tm:time-second tim)) )
948
949(define (tm:time-zero? tim)
950  (and
951    (zero? (tm:time-nanosecond tim))
952    (zero? (tm:time-second tim))) )
953
954;; Time Type Converters
955
956(define (tm:time-tai->time-utc timin timout)
957  (%time-type-set! timout 'utc)
958  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
959  (tm:time-second-set!
960    timout
961    (-
962      (%time-second timin)
963      (leap-second-neg-delta (%time-second timin))))
964  timout )
965
966(define-syntax tm:time-tai->time-monotonic
967        (syntax-rules ()
968                ((_ ?timin ?timout)
969                  (let ((timin ?timin)
970                        (timout ?timout))
971        (%time-type-set! timout 'monotonic)
972        (unless (eq? timin timout)
973          (tm:time-nanosecond-set! timout (%time-nanosecond timin))
974          (tm:time-second-set! timout (%time-second timin)))
975        timout ) ) ) )
976
977(define (tm:time-utc->time-tai timin timout)
978  (%time-type-set! timout 'tai)
979  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
980  (tm:time-second-set!
981    timout
982    (+
983      (%time-second timin)
984      (leap-second-delta (%time-second timin))))
985  timout )
986
987(define-syntax tm:time-utc->time-monotonic
988        (syntax-rules ()
989                ((_ ?timin ?timout)
990                  (let ((timin ?timin)
991                        (timout ?timout))
992        (let ((ntim (tm:time-utc->time-tai timin timout)))
993          (%time-type-set! ntim 'monotonic)
994          ntim ) ) ) ) )
995
996(define-syntax tm:time-monotonic->time-tai
997        (syntax-rules ()
998                ((_ ?timin ?timout)
999                  (let ((timin ?timin)
1000                        (timout ?timout))
1001        (%time-type-set! timout 'tai)
1002        (unless (eq? timin timout)
1003          (tm:time-nanosecond-set! timout (%time-nanosecond timin))
1004          (tm:time-second-set! timout (%time-second timin)))
1005        timout ) ) ) )
1006
1007(define-syntax tm:time-monotonic->time-utc
1008        (syntax-rules ()
1009                ((_ ?timin ?timout)
1010                  (let ((timin ?timin)
1011                        (timout ?timout))
1012        #;(%time-type-set! timin 'tai) ;fool converter (unnecessary)
1013        (tm:time-tai->time-utc timin timout) ) ) ) )
1014
1015;;; Date Object (Public Immutable)
1016
1017;; Leap Year Test
1018
1019;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
1020;; The Journal of the Royal Astronomical Society of Canada.
1021;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
1022;; Part II, volume 58, number 2, pages 79-87 (April 1964).
1023
1024(define-syntax tm:leap-year?
1025        (syntax-rules ()
1026                ((_ ?yr)
1027                  (let ((yr ?yr))
1028        (and
1029          #; ;!NOT Officially Adopted!
1030          (not (fx= (fxmod yr 4000) 0))
1031          (or
1032            (fx= (fxmod yr 400) 0)
1033            (and
1034              (fx= (fxmod yr 4) 0)
1035              (not (fx= (fxmod yr 100) 0))))) ) ) ) )
1036
1037;; Days per Month
1038
1039;Month range 1..12 so dys/mn range 0..12
1040(define      +year-dys/mn+ '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
1041(define +leap-year-dys/mn+ '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
1042
1043(define-syntax tm:leap-day?
1044        (syntax-rules ()
1045                ((_ ?dy ?mn)
1046                  (let ((dy ?dy) (mn ?mn))
1047        (fx= dy (vector-ref +leap-year-dys/mn+ mn)) ) ) ) )
1048
1049(define-syntax tm:days-in-month
1050        (syntax-rules ()
1051                ((_ ?yr ?mn)
1052                  (let ((yr ?yr) (mn ?mn))
1053        (vector-ref
1054          (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+)
1055          mn) ) ) ) )
1056
1057;;
1058
1059;#| ;dependency
1060(define-constant srfi-19-date 'srfi-19-date)
1061(define-record-type-variant srfi-19-date (unchecked #;inline unsafe)
1062  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1063  %date?
1064  (ns     %date-nanosecond  %date-nanosecond-set!)
1065  (sec    %date-second      %date-second-set!)
1066  (min    %date-minute      %date-minute-set!)
1067  (hr     %date-hour        %date-hour-set!)
1068  (dy     %date-day         %date-day-set!)
1069  (mn     %date-month       %date-month-set!)
1070  (yr     %date-year        %date-year-set!)
1071  (tzo    %date-zone-offset %date-zone-offset-set!)
1072  ;; non-srfi extn
1073  (tzn    %date-zone-name   %date-zone-name-set!)
1074  (dstf   %date-dst?        %date-dst-set!)
1075  (wdy    %date-wday        %date-wday-set!)
1076  (ydy    %date-yday        %date-yday-set!)
1077  (jdy    %date-jday        %date-jday-set!) )
1078;|#
1079#; ;no dependency
1080(define-record-type srfi-19-date
1081  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1082  %date?
1083  (ns     %date-nanosecond  %date-nanosecond-set!)
1084  (sec    %date-second      %date-second-set!)
1085  (min    %date-minute      %date-minute-set!)
1086  (hr     %date-hour        %date-hour-set!)
1087  (dy     %date-day         %date-day-set!)
1088  (mn     %date-month       %date-month-set!)
1089  (yr     %date-year        %date-year-set!)
1090  (tzo    %date-zone-offset %date-zone-offset-set!)
1091  ;; non-srfi extn
1092  (tzn    %date-zone-name   %date-zone-name-set!)
1093  (dstf   %date-dst?        %date-dst-set!)
1094  (wdy    %date-wday        %date-wday-set!)
1095  (ydy    %date-yday        %date-yday-set!)
1096  (jdy    %date-jday        %date-jday-set!) )
1097
1098(define (date? obj)
1099  (%date? obj) )
1100
1101;;
1102
1103(define-constant DATE-FORMAT-SRFI-10 "#,(srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)")
1104(define-constant DATE-FORMAT-BRACKET "#<srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A>")
1105
1106(define date-record-printer-format (make-parameter 'SRFI-10
1107  (lambda (x)
1108    (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
1109      x
1110      (begin
1111        (warning 'date-record-printer-format "invalid format" x)
1112        (date-record-printer-format) ) ) ) ) )
1113
1114(define (date-record-printer-format-string)
1115  (case (date-record-printer-format)
1116    ((srfi-10 SRFI-10)
1117      DATE-FORMAT-SRFI-10 )
1118    (else
1119      DATE-FORMAT-BRACKET ) ) )
1120
1121(define-record-printer (srfi-19-date dat out)
1122  (format out (date-record-printer-format-string)
1123   (%date-nanosecond dat)
1124   (%date-second dat) (%date-minute dat) (%date-hour dat)
1125   (%date-day dat) (%date-month dat) (%date-year dat)
1126   (%date-zone-offset dat)
1127   (%date-zone-name dat) (%date-dst? dat)
1128   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
1129
1130(define-reader-ctor 'srfi-19-date
1131  (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1132    (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))
1133
1134;;
1135
1136; Nanoseconds in [0 NS/S-1]
1137(define-syntax date-nanoseconds?
1138        (syntax-rules ()
1139                ((_ ?obj)
1140                  (let ((obj ?obj))
1141        (and
1142          (fixnum? obj)
1143          (fx<= 0 obj)
1144          (fx< obj NS/S)) ) ) ) )
1145
1146; Seconds in [0 SEC/MIN] ;SEC/MIN legal due to leap second
1147(define-syntax date-seconds?
1148        (syntax-rules ()
1149                ((_ ?obj)
1150                  (let ((obj ?obj))
1151        (and
1152          (fixnum? obj)
1153          (fx<= 0 obj)
1154          (fx<= obj SEC/MIN)) ) ) ) )
1155
1156; Minutes in [0 SEC/MIN-1]
1157(define-syntax date-minutes?
1158        (syntax-rules ()
1159                ((_ ?obj)
1160                  (let ((obj ?obj))
1161        (and
1162          (fixnum? obj)
1163          (fx<= 0 obj)
1164          (fx< obj SEC/MIN)) ) ) ) )
1165
1166; Hours in [0 HR/DY-1]
1167(define-syntax date-hours?
1168        (syntax-rules ()
1169                ((_ ?obj)
1170                  (let ((obj ?obj))
1171        (and
1172          (fixnum? obj)
1173          (fx<= 0 obj)
1174          (fx< obj HR/DY)) ) ) ) )
1175
1176; Days in [1 28/29/30/31] - depending on month & year
1177(define-syntax date-day?
1178        (syntax-rules ()
1179                ((_ ?obj ?mn ?yr)
1180                  (let ((obj ?obj) (mn ?mn) (yr ?yr))
1181        (and
1182          (fixnum? obj)
1183          (fx<= 1 obj)
1184          (fx<= obj (tm:days-in-month yr mn))) ) ) ) )
1185
1186; Months in [1 MN/YR]
1187(define-syntax date-month?
1188        (syntax-rules ()
1189                ((_ ?obj)
1190                  (let ((obj ?obj))
1191        (and
1192          (fixnum? obj)
1193          (fx<= 1 obj)
1194          (fx<= obj MN/YR)) ) ) ) )
1195
1196; No year 0!
1197(define (date-year? obj)
1198  (and
1199    (fixnum? obj)
1200    (not (fx= 0 obj))) )
1201
1202;;
1203
1204(define-check+error-type date-nanoseconds)
1205(define-check+error-type date-seconds)
1206(define-check+error-type date-minutes)
1207(define-check+error-type date-hours)
1208(define-error-type date-day)
1209(define (check-date-day loc obj mn yr) (unless (date-day? obj mn yr) (error-date-day loc obj)) )
1210(define-check+error-type date-month)
1211(define-check+error-type date-year)
1212
1213(define (check-date-elements loc ns sec min hr dy mn yr tzo tzn)
1214  (check-date-nanoseconds loc ns)
1215  (check-date-seconds loc sec)
1216  (check-date-minutes loc min)
1217  (check-date-hours loc hr)
1218  (check-date-year loc yr)
1219  (check-date-month loc mn)
1220  (check-date-day loc dy mn yr)
1221  (check-timezone-offset loc tzo "date-timezone-offset")
1222  (check-timezone-name loc tzn "date-timezone-name") )
1223
1224;;
1225
1226(define (error-date-compatible-timezone loc dat1 dat2)
1227  (signal-type-error loc "not compatible timezones" dat1 dat2) )
1228
1229(define (check-date-compatible-timezone-offsets loc dat1 dat2)
1230  (unless (fx= (%date-zone-offset dat1) (%date-zone-offset dat2))
1231    (error-date-compatible-timezone loc dat1 dat2) ) )
1232
1233;;
1234
1235(define (clock-type? obj) (memq obj '(monotonic tai utc)))
1236
1237(define-check+error-type clock-type)
1238
1239(define (error-convert loc srcnam dstnam obj)
1240  (signal-type-error loc (conc "cannot convert " srcnam " to " dstnam) obj) )
1241
1242(define-check+error-type date %date?)
1243
1244;;
1245
1246;;; Getters
1247
1248(define-syntax tm:date-nanosecond
1249        (syntax-rules ()
1250                ((_ ?dat)
1251                  (let ((dat ?dat))
1252        (%date-nanosecond dat) ) ) ) )
1253
1254(define-syntax tm:date-second
1255        (syntax-rules ()
1256                ((_ ?dat)
1257                  (let ((dat ?dat))
1258        (%date-second dat) ) ) ) )
1259
1260(define-syntax tm:date-minute
1261        (syntax-rules ()
1262                ((_ ?dat)
1263                  (let ((dat ?dat))
1264        (%date-minute dat) ) ) ) )
1265
1266(define-syntax tm:date-hour
1267        (syntax-rules ()
1268                ((_ ?dat)
1269                  (let ((dat ?dat))
1270        (%date-hour dat) ) ) ) )
1271
1272(define-syntax tm:date-day
1273        (syntax-rules ()
1274                ((_ ?dat)
1275                  (let ((dat ?dat))
1276        (%date-day dat) ) ) ) )
1277
1278(define-syntax tm:date-month
1279        (syntax-rules ()
1280                ((_ ?dat)
1281                  (let ((dat ?dat))
1282        (%date-month dat) ) ) ) )
1283
1284(define-syntax tm:date-year
1285        (syntax-rules ()
1286                ((_ ?dat)
1287                  (let ((dat ?dat))
1288        (%date-year dat) ) ) ) )
1289
1290(define-syntax tm:date-zone-offset
1291        (syntax-rules ()
1292                ((_ ?dat)
1293                  (let ((dat ?dat))
1294        (%date-zone-offset dat) ) ) ) )
1295
1296(define-syntax tm:date-zone-name
1297        (syntax-rules ()
1298                ((_ ?dat)
1299                  (let ((dat ?dat))
1300        (%date-zone-name dat) ) ) ) )
1301
1302(define-syntax tm:date-dst?
1303        (syntax-rules ()
1304                ((_ ?dat)
1305                  (let ((dat ?dat))
1306        (%date-dst? dat) ) ) ) )
1307
1308(define-syntax tm:date-wday
1309        (syntax-rules ()
1310                ((_ ?dat)
1311                  (let ((dat ?dat))
1312        (%date-wday dat) ) ) ) )
1313
1314(define-syntax tm:date-yday
1315        (syntax-rules ()
1316                ((_ ?dat)
1317                  (let ((dat ?dat))
1318        (%date-yday dat) ) ) ) )
1319
1320(define-syntax tm:date-jday
1321        (syntax-rules ()
1322                ((_ ?dat)
1323                  (let ((dat ?dat))
1324        (%date-jday dat) ) ) ) )
1325
1326;;; Setters
1327
1328(define-syntax tm:date-nanosecond-set!
1329        (syntax-rules ()
1330                ((_ ?dat ?x)
1331                  (let ((dat ?dat) (x ?x))
1332        (%date-nanosecond-set! dat (number->genint x)) ) ) ) )
1333
1334(define-syntax tm:date-second-set!
1335        (syntax-rules ()
1336                ((_ ?dat ?x)
1337                  (let ((dat ?dat) (x ?x))
1338        (%date-second-set! dat (number->genint x)) ) ) ) )
1339
1340(define-syntax tm:date-minute-set!
1341        (syntax-rules ()
1342                ((_ ?dat ?x)
1343                  (let ((dat ?dat) (x ?x))
1344        (%date-minute-set! dat (number->genint x)) ) ) ) )
1345
1346(define-syntax tm:date-hour-set!
1347        (syntax-rules ()
1348                ((_ ?dat ?x)
1349                  (let ((dat ?dat) (x ?x))
1350        (%date-hour-set! dat (number->genint x)) ) ) ) )
1351
1352(define-syntax tm:date-day-set!
1353        (syntax-rules ()
1354                ((_ ?dat ?x)
1355                  (let ((dat ?dat) (x ?x))
1356        (%date-day-set! dat (number->genint x)) ) ) ) )
1357
1358(define-syntax tm:date-month-set!
1359        (syntax-rules ()
1360                ((_ ?dat ?x)
1361                  (let ((dat ?dat) (x ?x))
1362        (%date-month-set! dat (number->genint x)) ) ) ) )
1363
1364(define-syntax tm:date-year-set!
1365        (syntax-rules ()
1366                ((_ ?dat ?x)
1367                  (let ((dat ?dat) (x ?x))
1368        (%date-year-set! dat (number->genint x)) ) ) ) )
1369
1370(define-syntax tm:date-zone-offset-set!
1371        (syntax-rules ()
1372                ((_ ?dat ?x)
1373                  (let ((dat ?dat) (x ?x))
1374        (%date-zone-offset-set! dat (number->genint x)) ) ) ) )
1375
1376;; Date TZ information extract
1377
1378;Belongs in srfi-19-timezone
1379;but won't fit since needs srfi-19-support (%date-*)
1380
1381;#\ ;dependency
1382(define-constant date-timezone-info 'date-timezone-info)
1383(define-record-type-variant date-timezone-info (unchecked #;inline unsafe)
1384  (%make-date-timezone-info n o d)
1385  %date-timezone-info?
1386  (n %date-timezone-info-name)
1387  (o %date-timezone-info-offset)
1388  (d %date-timezone-info-dst?) )
1389;|#
1390#; ;no dependency
1391(define-record-type date-timezone-info
1392  (%make-date-timezone-info n o d)
1393  %date-timezone-info?
1394  (n %date-timezone-info-name)
1395  (o %date-timezone-info-offset)
1396  (d %date-timezone-info-dst?) )
1397
1398(define (date-timezone-info? obj)
1399  (%date-timezone-info? obj) )
1400
1401(define-syntax tm:date-timezone-info
1402        (syntax-rules ()
1403                ((_ ?dat)
1404                  (let ((dat ?dat))
1405        #;(make-timezone-locale (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat))
1406        (%make-date-timezone-info
1407          (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) ) ) ) )
1408
1409;; Returns an invalid date record (for use by 'scan-date')
1410
1411(define-syntax tm:make-incomplete-date
1412        (syntax-rules ()
1413                ((_)
1414      (%make-date
1415        0
1416        0 0 0
1417        #f #f #f
1418        (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
1419        #f #f #f) ) ) )
1420
1421;; Internal Date CTOR
1422
1423(define-syntax tm:make-date
1424        (syntax-rules ()
1425                ((_ ?ns ?sec ?min ?hr ?dy ?mn ?yr ?tzo ?tzn ?dstf ?wdy ?ydy ?jdy)
1426                  (let ((ns ?ns) (sec ?sec) (min ?min) (hr ?hr) (dy ?dy) (mn ?mn) (yr ?yr) (tzo ?tzo) (tzn ?tzn) (dstf ?dstf) (wdy ?wdy) (ydy ?ydy) (jdy ?jdy))
1427        (%make-date
1428          (number->genint ns)
1429          (number->genint sec) (number->genint min) (number->genint hr)
1430          (number->genint dy) (number->genint mn) (number->genint yr)
1431          (number->genint tzo) tzn dstf
1432          wdy ydy jdy) ) ) ) )
1433
1434(define-syntax tm:copy-date
1435        (syntax-rules ()
1436                ((_ ?dat)
1437                  (let ((dat ?dat))
1438        (%make-date
1439          (%date-nanosecond dat)
1440          (%date-second dat) (%date-minute dat) (%date-hour dat)
1441          (%date-day dat) (%date-month dat) (%date-year dat)
1442          (%date-zone-offset dat)
1443          (%date-zone-name dat) (%date-dst? dat)
1444          (%date-wday dat) (%date-yday dat) (%date-jday dat)) ) ) ) )
1445
1446(define (tm:seconds->date/type sec tzc)
1447  (let* (
1448    (fsec (exact->inexact sec))
1449    (isec (number->genint fsec))
1450    (tzo (timezone-locale-offset tzc))
1451    (tv (seconds->utc-time (+ isec tzo))) )
1452    (tm:make-date
1453      (round (* (- fsec isec) NS/S))
1454      (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
1455      (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
1456      tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
1457      (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )
1458
1459(define-syntax tm:current-date
1460        (syntax-rules ()
1461                ((_ ?tzi) (let ((tzi ?tzi)) (tm:time-utc->date (tm:current-time-utc) tzi)) ) ) )
1462
1463;; Date Comparison
1464
1465(define-syntax tm:date-compare
1466        (syntax-rules ()
1467                ((_ ?dat1 ?dat2)
1468                  (let ((dat1 ?dat1) (dat2 ?dat2))
1469        (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
1470          (if (not (fxzero? dif))
1471            dif
1472            (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
1473              (if (not (fxzero? dif))
1474                dif
1475                (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
1476                  (if (not (fxzero? dif))
1477                    dif
1478                    (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
1479                      (if (not (fxzero? dif))
1480                        dif
1481                        (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
1482                          (if (not (fxzero? dif))
1483                            dif
1484                            (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
1485                              (if (not (fxzero? dif))
1486                                dif
1487                                (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
1488
1489;; Gives the seconds/day/month/year
1490
1491#; ;original
1492(define (tm:decode-julian-day-number jdn)
1493  (let* (
1494    (days (floor jdn))
1495    (a (+ days 32044))
1496    (b (quotient (+ (* 4 a) 3) 146097))
1497    (c (- a (quotient (* 146097 b) 4)))
1498    (d (quotient (+ (* 4 c) 3) 1461))
1499    (e (- c (quotient (* 1461 d) 4)))
1500    (m (quotient (+ (* 5 e) 2) 153))
1501    (y (+ (* 100 b) d -4800 (quotient m 10))))
1502    (values ;seconds date month year
1503     (* (- jdn days) tm:sid)
1504     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
1505     (+ m 3 (* -12 (quotient m 10)))
1506     (if (>= 0 y) (- y 1) y)) ) )
1507(define (tm:decode-julian-day-number jdn)
1508  (let* (
1509    (dys (number->genint jdn))
1510    (a (fx+ dys 32044))
1511    (b (fx/ (fx+ (fx* 4 a) 3) 146097))
1512    (c (fx- a (fx/ (fx* 146097 b) 4)))
1513    (d (fx/ (fx+ (fx* 4 c) 3) 1461))
1514    (e (fx- c (fx/ (fx* 1461 d) 4)))
1515    (m (fx/ (fx+ (fx* 5 e) 2) 153))
1516    (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
1517    (values ;seconds date month year
1518      (number->genint (* (- jdn dys) SEC/DY))
1519      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
1520      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
1521      (if (fx<= y 0) (fx- y 1) y)) ) )
1522
1523;; Gives the Julian day number - rounds up to the nearest day
1524
1525(define (tm:seconds->julian-day-number sec tzo)
1526  (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
1527
1528;; Is the time object one second before a leap second?
1529
1530(define (tm:tai-before-leap-second? tim)
1531  (let ((sec (%time-second tim)))
1532    (let loop ((ls tm:second-before-leap-second-table))
1533      (and
1534        (not (null? ls))
1535        (or
1536          (= sec (car ls))
1537          (loop (cdr ls)) ) ) ) ) )
1538
1539(define (tm:time-utc->date tim tzi)
1540  (let (
1541    (tzo tzi) ;assume an offset
1542    (tzn #f)
1543    (dstf #f) )
1544    (cond
1545      ((%date-timezone-info? tzi)
1546        (set! dstf (%date-timezone-info-dst? tzi))
1547        (set! tzn (%date-timezone-info-name tzi))
1548        (set! tzo (%date-timezone-info-offset tzi)) )
1549      ((timezone-components? tzi)
1550        (set! dstf (timezone-locale-dst? tzi))
1551        (set! tzn (timezone-locale-name tzi))
1552        (set! tzo (timezone-locale-offset tzi)) ) )
1553    (let-values (
1554      ((secs dy mn yr)
1555        (tm:decode-julian-day-number
1556          (tm:seconds->julian-day-number (%time-second tim) tzo))) )
1557      (let* (
1558        (hr (fx/ secs SEC/HR))
1559        (rem (fxmod secs SEC/HR))
1560        (min (fx/ rem SEC/MIN))
1561        (sec (fxmod rem SEC/MIN)) )
1562        (tm:make-date
1563          (%time-nanosecond tim)
1564          sec min hr
1565          dy mn yr
1566          tzo tzn dstf
1567          #f #f #f) ) ) ) )
1568
1569(define (tm:time-tai->date tim tzi)
1570  (let (
1571    (tm-utc (tm:time-tai->time-utc tim (tm:any-time))) )
1572    (if (not (tm:tai-before-leap-second? tim))
1573      (tm:time-utc->date tm-utc tzi)
1574      ;else time is *right* before the leap,
1575      ;we need to pretend to subtract a second ...
1576      (let (
1577        (dat
1578          (tm:time-utc->date
1579            (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)) )
1580        (%date-second-set! dat SEC/MIN) ;Note full minute!
1581        dat ) ) ) )
1582
1583(define (tm:time->date tim tzi)
1584  (case (%time-type tim)
1585    ((utc)       (tm:time-utc->date tim tzi))
1586    ((tai)       (tm:time-tai->date tim tzi))
1587    ((monotonic) (tm:time-utc->date tim tzi))
1588    (else        #f)) )
1589
1590;; Date to Time
1591
1592;; Gives the Julian day number - Gregorian proleptic calendar
1593
1594(define (tm:encode-julian-day-number dy mn yr)
1595  (let* (
1596    (a (fx/ (fx- 14 mn) MN/YR))
1597    (b (fx- (fx+ yr JDYR) a))
1598    (y (if (fx< yr 0) (fx+ b 1) b)) ;BCE?
1599    (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
1600    (+ dy
1601      (fx/ (fx+ (fx* 153 m) 2) 5)
1602      (fx* y DY/YR)
1603      (fx/ y 4)
1604      (fx/ y -100)
1605      (fx/ y 400)
1606      -32045) ) )
1607
1608(define (tm:date->time-utc dat)
1609  (let (
1610    (ns (%date-nanosecond dat))
1611    (sec (%date-second dat))
1612    (min (%date-minute dat))
1613    (hr (%date-hour dat))
1614    (dy (%date-day dat))
1615    (mn (%date-month dat))
1616    (yr (%date-year dat))
1617    (tzo (%date-zone-offset dat)) )
1618    (let (
1619      (jdys
1620        (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
1621      (secs
1622        (fx+
1623          (fx+
1624            (fx* hr SEC/HR)
1625            (fx+
1626              (fx* min SEC/MIN)
1627              sec))
1628          (fxneg tzo))) )
1629      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
1630
1631(define (tm:date->time-tai dat)
1632  (let* (
1633    (tm-utc (tm:date->time-utc dat))
1634    (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
1635    (if (not (fx= SEC/MIN (%date-second dat)))
1636      tm-tai
1637      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
1638
1639(define (tm:date->time-monotonic dat)
1640  (let ((tim-utc (tm:date->time-utc dat)))
1641    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
1642
1643(define (tm:date->time dat tt)
1644  (case tt
1645    ((utc)        (tm:date->time-utc dat))
1646    ((tai)        (tm:date->time-tai dat))
1647    ((monotonic)  (tm:date->time-monotonic dat))
1648    (else         #f) ) )
1649
1650;; Given a 'two digit' number, find the year within 50 years +/-
1651
1652(define (tm:natural-year n tzi)
1653  ;propagate the error
1654  (if (or (fx< n 0) (fx>= n 100))
1655    n
1656    (let* (
1657      (current-year     (%date-year (tm:current-date tzi)) )
1658      (current-century  (fx* (fx/ current-year 100) 100) )
1659      (X                (fx- (fx+ current-century n) current-year) ) )
1660      (if (fx<= X 50)
1661        (fx+ current-century n)
1662        (fx+ (fx- current-century 100) n) ) ) ) )
1663
1664;; Day of Year
1665
1666(define +cumulative-month-days+ '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
1667
1668(define (tm:year-day dy mn yr)
1669  (let ((yrdy (fx+ dy (vector-ref +cumulative-month-days+ mn))))
1670    (if (and (tm:leap-year? yr) (fx< 2 mn))
1671      (fx+ yrdy 1)
1672      yrdy ) ) )
1673
1674(define (tm:cache-date-year-day dat)
1675  (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
1676    (%date-yday-set! dat yrdy)
1677    yrdy ) )
1678
1679(define (tm:date-year-day dat)
1680  (or
1681    (%date-yday dat)
1682    (tm:cache-date-year-day dat) ) )
1683
1684;; Week Day
1685
1686(define (week-day? obj)
1687  (and (fixnum? obj) (fx<= 0 obj) (fx<= obj 6)) )
1688
1689(define-check+error-type week-day)
1690
1691;; Using Gregorian Calendar (from Calendar FAQ)
1692
1693(: tm:week-day (fixnum fixnum fixnum --> fixnum))
1694
1695;Tomohiko Sakamoto algorithm
1696;Determination of the day of the week
1697;
1698;Jan 1st 1 AD is a Monday in Gregorian calendar.
1699;So Jan 0th 1 AD is a Sunday [It does not exist technically].
1700;
1701;Every 4 years we have a leap year. But xy00 cannot be a leap unless xy divides 4 with remainder 0.
1702;y/4 - y/100 + y/400 : this gives the number of leap years from 1AD to the
1703;given year. As each year has 365 days (divides 7 with remainder 1), unless it
1704;is a leap year or the date is in Jan or Feb, the day of a given date changes
1705;by 1 each year. In other cases it increases by 2.
1706;y -= m<3 : If the month is not Jan or Feb, we do not count the 29th Feb (if
1707;it exists) of the given year.
1708;So y + y/4 - y/100 + y/400  gives the day of Jan 0th (Dec 31st of prev year)
1709;of the year. (This gives the remainder with 7 of  the number of days passed
1710;before the given year began.)
1711;
1712;Array t:  Number of days passed before the month 'm+1' begins.
1713;
1714;So t[m-1]+d is the number of days passed in year 'y' up to the given date.
1715;(y + y/4 - y/100 + y/400 + t[m-1] + d) % 7 is remainder of the number of days
1716;from Jan 0 1AD to the given date which will be the day (0=Sunday,6=Saturday).
1717;
1718;Description credits: Sai Teja Pratap (quora.com/How-does-Tomohiko-Sakamotos-Algorithm-work).
1719(define tm:week-day
1720  (let (
1721    (t #(0 3 2 5 0 3 5 1 4 6 2 4)) )
1722    (lambda (dy mn yr)
1723      (let (
1724        (yr (if (< mn 3) (fx- yr 1) yr)) )
1725        (modulo (+ yr (/ yr 4) (/ yr -100) (vector-ref t (- mn 1)) dy) DY/WK) ) ) ) )
1726
1727(define (tm:week-day dy mn yr)
1728  (let* ((a (fx/ (fx- 14 mn) MN/YR))
1729         (y (fx- yr a))
1730         (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
1731    (fxmod
1732      (fx+
1733        (fx+ dy y)
1734        (fx+
1735          (fx-
1736            (fx/ y 4)
1737            (fx/ y 100))
1738          (fx+
1739            (fx/ y 400)
1740            (fx/ (fx* m DY/MN) MN/YR))))
1741      DY/WK) ) )
1742
1743(define (tm:cache-date-week-day dat)
1744  (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
1745    (%date-wday-set! dat wdy)
1746    wdy ) )
1747
1748(define (tm:date-week-day dat)
1749  (or
1750    (%date-wday dat)
1751    (tm:cache-date-week-day dat) ) )
1752
1753(define (tm:days-before-first-week dat 1st-weekday)
1754  (fxmod (fx- 1st-weekday (tm:week-day 1 1 (%date-year dat))) DY/WK) )
1755
1756(define (tm:date-week-number dat 1st-weekday)
1757  (fx/
1758    (fx- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
1759    DY/WK) )
1760
1761;; Julian-day Operations
1762
1763(define (julian-day? obj)
1764  (real? obj) )
1765
1766(define-check+error-type julian-day)
1767
1768(define (tm:julian-day->modified-julian-day mjdn)
1769  (- mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1770
1771;; Date to Julian-day
1772
1773; Does the nanoseconds value contribute anything to the julian day?
1774; The range is < 1 second here (but not in the reference).
1775
1776(define (tm:julian-day ns sec min hr dy mn yr tzo)
1777  (let (
1778    (jdn
1779      (tm:encode-julian-day-number dy mn yr))
1780    (timsecs
1781      (+
1782        (fx+
1783          (fx+
1784            (fx* hr SEC/HR)
1785            (fx+ (fx* min SEC/MIN) sec))
1786          (fxneg tzo))
1787        (/ ns NS/S))) )
1788    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
1789#; ;inexact version
1790(define (tm:julian-day ns sec min hr dy mn yr tzo)
1791  (let (
1792    (time-seconds
1793      (fx+
1794        (fx+
1795          (fx* hr SEC/HR)
1796          (fx+ (fx* min SEC/MIN) sec))
1797          (fxneg tzo)) ) )
1798    (fp+
1799      (fp-
1800        (exact->inexact (tm:encode-julian-day-number dy mn yr))
1801        (exact->inexact ONE-HALF))
1802      (fp/
1803        (fp+
1804          (exact->inexact time-seconds)
1805          (fp/ (exact->inexact ns) (exact->inexact NS/S)))
1806        (exact->inexact SEC/DY))) ) )
1807
1808(define-syntax tm:date->julian-day
1809        (syntax-rules ()
1810                ((_ ?dat)
1811                  (let ((dat ?dat))
1812        (or
1813          (%date-jday dat)
1814          (let (
1815            (jdn
1816              (tm:julian-day
1817                (%date-nanosecond dat)
1818                (%date-second dat) (%date-minute dat) (%date-hour dat)
1819                (%date-day dat) (%date-month dat) (%date-year dat)
1820                (%date-zone-offset dat))))
1821            (%date-jday-set! dat jdn)
1822            jdn ) ) ) ) ) )
1823
1824;; Time to Julian-day
1825
1826(define (tm:seconds->julian-day ns sec)
1827  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
1828
1829(define (tm:time-utc->julian-day tim)
1830  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
1831
1832(define (tm:time-tai->julian-day tim)
1833  (let ((sec (%time-second tim)))
1834    (tm:seconds->julian-day
1835      (%time-nanosecond tim)
1836      (- sec (leap-second-delta sec))) ) )
1837
1838(define tm:time-monotonic->julian-day tm:time-tai->julian-day)
1839
1840(define (tm:time->julian-day tim)
1841  (case (%time-type tim)
1842    ((utc)        (tm:time-utc->julian-day tim))
1843    ((tai)        (tm:time-tai->julian-day tim))
1844    ((monotonic)  (tm:time-monotonic->julian-day tim))
1845    (else         #f)) )
1846
1847(define (tm:time-utc->modified-julian-day tim)
1848  (tm:julian-day->modified-julian-day (tm:time-utc->julian-day tim)) )
1849
1850(define (tm:time-tai->modified-julian-day tim)
1851  (tm:julian-day->modified-julian-day (tm:time-tai->julian-day tim)) )
1852
1853(define (tm:time-monotonic->modified-julian-day tim)
1854  (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )
1855
1856(define (tm:time->modified-julian-day tim)
1857  (case (%time-type tim)
1858    ((utc)        (tm:time-utc->modified-julian-day tim))
1859    ((tai)        (tm:time-tai->modified-julian-day tim))
1860    ((monotonic)  (tm:time-monotonic->modified-julian-day tim))
1861    (else         #f)) )
1862
1863;; Julian-day to Time
1864
1865(define (tm:julian-day->nanoseconds jdn)
1866  (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S) )
1867
1868(define (tm:julian-day->time-values jdn)
1869  (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)) )
1870
1871(define (tm:modified-julian-day->julian-day mjdn)
1872  (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1873
1874(define-syntax tm:julian-day->time-utc
1875        (syntax-rules ()
1876                ((_ ?jdn)
1877                  (let ((jdn ?jdn))
1878        (let-values (((ns sec) (tm:julian-day->time-values jdn)))
1879          (tm:make-time 'time-utc ns sec) ) ) ) ) )
1880
1881(define (tm:modified-julian-day->time-utc mjdn)
1882  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
1883
1884(define (tm:default-date-adjust-integer amt)
1885  (round amt) )
1886
1887) ;module srfi-19-support
Note: See TracBrowser for help on using the repository browser.