source: project/release/4/srfi-19/trunk/srfi-19-support.scm @ 15788

Last change on this file since 15788 was 15788, checked in by Kon Lovett, 11 years ago

Save.

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