source: project/release/3/srfi-19/trunk/srfi-19-core.scm @ 12029

Last change on this file since 12029 was 12029, checked in by Kon Lovett, 13 years ago

Save.

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