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

Last change on this file since 13905 was 13905, checked in by Kon Lovett, 12 years ago

Rmvd timezone locale since dst? now part of timezone-components.

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