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

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

Save.

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