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

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

Save.

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