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

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

Use of BUILTIN-SOURCE constant. Since irregex does not work w/ the utf-8 extension rmvd use.

File size: 54.8 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)
1028
1029(define tm:make-timezone-locale cons)
1030
1031(define %timezone-locale-dst? car)
1032(define %timezone-locale-component cdr)
1033
1034(define (make-timezone-locale dstf tzc)
1035  (unless (boolean? dstf)
1036    (error 'make-timezone-locale "invalid daylight saving time flag" dstf) )
1037  (unless (timezone-components? tzc)
1038    (error 'make-timezone-locale "invalid timezone components" tzc) )
1039  (tm:make-timezone-locale dstf tzc) )
1040
1041(define (timezone-locale? obj)
1042  (and (pair? obj)
1043       (boolean? (%timezone-locale-dst? obj))
1044       (timezone-components? (%timezone-locale-component obj)) ) )
1045
1046(define (check-timezone-locale loc obj)
1047  (unless (timezone-locale? obj)
1048    (error loc "invalid timezone locale" obj) ) )
1049
1050(define (current-dstflag)
1051  (vector-ref (seconds->local-time (current-seconds)) 8) )
1052
1053(define local-timezone-locale
1054  (make-parameter (make-timezone-locale (current-dstflag) (current-timezone-components))
1055    (lambda (obj)
1056      (cond ((timezone-locale? obj) obj)
1057            (else
1058             (warning 'local-timezone-locale "bad argument type - expected a timezone-locale" obj)
1059             (local-timezone-locale) ) ) ) ) )
1060
1061(define (make-utc-timezone)
1062  (let ((tz (make-timezone-components "UTC0" BUILTIN-SOURCE)))
1063    (update-timezone-components! tz 'std-name "UTC" 'std-offset 0) ) )
1064
1065(define utc-timezone-locale
1066  (make-parameter (make-timezone-locale #f (make-utc-timezone))
1067    (lambda (obj)
1068      (cond ((timezone-locale? obj) obj)
1069            (else
1070             (warning 'utc-timezone-locale "bad argument type - expected a timezone-locale" obj)
1071             (utc-timezone-locale) ) ) ) ) )
1072
1073;; Returns #f or a valid tz-name
1074
1075(define (timezone-locale-name . args)
1076  (let-optionals args ((tzi (local-timezone-locale)))
1077    (check-timezone-locale 'timezone-locale-name tzi)
1078    (let* ((tzc (%timezone-locale-component tzi))
1079           (tzn (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))))
1080      ; TZ may not be set
1081      (and (not (eq? UNKNOWN-LOCAL-TZ-NAME tzn))
1082           tzn ) ) ) )
1083
1084;;
1085
1086(define (timezone-locale-offset . args)
1087  (let-optionals args ((tzi (local-timezone-locale)))
1088    (check-timezone-locale 'timezone-locale-offset tzi)
1089    (let* ((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? . args)
1097  (let-optionals args ((tzi (local-timezone-locale)))
1098    (check-timezone-locale 'timezone-locale-offset tzi)
1099    (%timezone-locale-dst? tzi) ) )
1100
1101;;; Date Object (Public Immutable)
1102
1103(define-record-type/unsafe-inline-unchecked date
1104  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1105  %date?
1106  (ns     %date-nanosecond  %date-nanosecond-set!)
1107  (sec    %date-second      %date-second-set!)
1108  (min    %date-minute      %date-minute-set!)
1109  (hr     %date-hour        %date-hour-set!)
1110  (dy     %date-day         %date-day-set!)
1111  (mn     %date-month       %date-month-set!)
1112  (yr     %date-year        %date-year-set!)
1113  (tzo    %date-zone-offset %date-zone-offset-set!)
1114  ;; non-srfi extn
1115  (tzn    %date-zone-name)
1116  (dstf   %date-dst?)
1117  (wdy    %date-wday        %date-wday-set!)
1118  (ydy    %date-yday        %date-yday-set!)
1119  (jdy    %date-jday        %date-jday-set!) )
1120
1121;;
1122
1123(define-inline (%check-date loc obj) (##sys#check-structure obj 'date loc))
1124
1125;;
1126
1127(define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (%->fixnum x)))
1128
1129(define (tm:date-second-set! dat x) (%date-second-set! dat (%->fixnum x)))
1130
1131(define (tm:date-minute-set! dat x) (%date-minute-set! dat (%->fixnum x)))
1132
1133(define (tm:date-hour-set! dat x) (%date-hour-set! dat (%->fixnum x)))
1134
1135(define (tm:date-day-set! dat x) (%date-day-set! dat (%->fixnum x)))
1136
1137(define (tm:date-month-set! dat x) (%date-month-set! dat (%->fixnum x)))
1138
1139(define (tm:date-year-set! dat x) (%date-year-set! dat (%->fixnum x)))
1140
1141(define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (%->fixnum x)))
1142
1143;; Leap Year Test
1144
1145;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
1146;; The Journal of the Royal Astronomical Society of Canada.
1147;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
1148;; Part II, volume 58, number 2, pages 79-87 (April 1964).
1149
1150(define (tm:leap-year? year)
1151  (and (not (fx= (fxmod year 4000) 0)) ;Not officially adopted!
1152       (or (fx= (fxmod year 400) 0)
1153                (and (fx= (fxmod year 4) 0)
1154                     (not (fx= (fxmod year 100) 0))))) )
1155
1156;; Days per Month
1157
1158(define tm:dys/mn '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
1159
1160(define tm:leap-year-dys/mn '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
1161
1162(define (tm:days-in-month mn yr)
1163  (vector-ref (if (tm:leap-year? yr) tm:leap-year-dys/mn tm:dys/mn) mn) )
1164
1165(define tm:cumulative-month-days '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
1166
1167;; Returns an invalid date record (for use by 'scan-date')
1168
1169(define (tm:make-incomplete-date)
1170  (%make-date
1171   0
1172   0 0 0
1173   #f #f #f
1174   (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
1175   #f #f #f) )
1176
1177;; Internal Date CTOR
1178
1179(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1180  (%make-date
1181   (%->fixnum ns)
1182   (%->fixnum sec) (%->fixnum min) (%->fixnum hr)
1183   (%->fixnum dy) (%->fixnum mn) (%->fixnum yr)
1184   (%->fixnum tzo) tzn dstf
1185   wdy ydy jdy) )
1186
1187;; Parameter Checking
1188
1189(define tm:check-date %check-date)
1190
1191; No year 0!
1192(define (tm:check-year loc yr)
1193  (unless (and (fixnum? yr) (not (fx= 0 yr)))
1194    (error loc "invalid year" yr) ) )
1195
1196; Months in [1 12]
1197(define (tm:check-month loc mn)
1198  (unless (and (fixnum? mn) (fx<= 1 mn) (fx<= mn 12))
1199    (error loc "invalid month" mn) ) )
1200
1201; Days in [1 28/29/30/31] - depending on month & year
1202(define (tm:check-day loc dy mn yr)
1203  (unless (and (fixnum? dy) (fx<= 1 dy) (fx<= dy (tm:days-in-month mn yr)))
1204    (error loc "invalid day" dy) ) )
1205
1206(define (tm:check-exploded-date loc ns sec min hr dy mn yr tzo tzn)
1207
1208  ; Same as time object
1209  (tm:check-time-nanoseconds loc ns)
1210
1211  ; Seconds in [0 60] ; 60 legal due to leap second
1212  (unless (and (fixnum? sec) (fx<= 0 sec) (fx<= sec 60))
1213    (error loc "invalid seconds" sec))
1214
1215  ; Minutes in [0 59]
1216  (unless (and (fixnum? min) (and (fx<= 0 min) (fx< min 60)))
1217    (error loc "invalid minutes" min))
1218
1219  ; Hours in [0 23]
1220  (unless (and (fixnum? hr) (and (<= 0 hr) (< hr 24)))
1221    (error loc "invalid hours" hr))
1222
1223  ; Year, Month & Day within limits
1224  (tm:check-year loc yr)
1225  (tm:check-month loc mn)
1226  (tm:check-day loc dy mn yr)
1227
1228  ; Timezone offset in (-SEC/DY +SEC/DY)
1229  (unless (and (fixnum? tzo) (let ((atzo (%fxabs tzo))) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
1230    (error loc "invalid timezone offset" tzo))
1231
1232  ; Timezone not specified or a string
1233  (unless (or (not tzn) (string? tzn))
1234    (error loc "invalid timezone name" tzn)) )
1235
1236;; Date Syntax
1237
1238(define-record-printer (date dat out)
1239  (format out
1240   "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
1241   (%date-nanosecond dat)
1242   (%date-second dat) (%date-minute dat) (%date-hour dat)
1243   (%date-day dat) (%date-month dat) (%date-year dat)
1244   (%date-zone-offset dat)
1245   (%date-zone-name dat) (%date-dst? dat)
1246   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
1247
1248(define-reader-ctor 'date
1249  (lambda (ns sec min hr dy mn yr tzo . rest)
1250    (let-optionals rest ((tzn #f) (dstf #f) (wdy #f) (ydy #f) (jdy #f))
1251      (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy))))
1252
1253;; Date CTOR
1254
1255(define (make-date ns sec min hr dy mn yr tzo . rest)
1256  (let-optionals rest ((tzn #f) (dstf (void)))
1257    (if (not (timezone-locale? tzo))
1258        (when (eq? (void) dstf) (set! dstf #f))
1259        (begin
1260          ; Supplied parameters override
1261          (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
1262          (set! tzn (or tzn (timezone-locale-name tzo)))
1263          (set! tzo (timezone-locale-offset tzo)) ) )
1264    (tm:check-exploded-date 'make-date ns sec min hr dy mn yr tzo tzn)
1265    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
1266
1267(define (copy-date dat)
1268  (%make-date
1269   (%date-nanosecond dat)
1270   (%date-second dat) (%date-minute dat) (%date-hour dat)
1271   (%date-day dat) (%date-month dat) (%date-year dat)
1272   (%date-zone-offset dat)
1273   (%date-zone-name dat) (%date-dst? dat)
1274   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
1275
1276;; Converts a seconds value, may be fractional, into a date type.
1277;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
1278;; A local (#t), utc (#f), or other (timezone-locale) date depending on
1279;; the optional 2nd argument. The default is #f.
1280
1281(define (seconds->date/type sec . r)
1282  (unless (number? sec)
1283    (error 'seconds->date/type "invalid seconds" sec))
1284  (let ((tzi (optional r #f)))
1285    (when (boolean? tzi)
1286      (set! tzi ((if tzi local-timezone-locale utc-timezone-locale))) )
1287    (unless (timezone-locale? tzi)
1288      (error 'seconds->date/type "invalid timezone-locale" tzi) )
1289    (let* ((fsec (exact->inexact sec))
1290           (isec (truncate fsec))
1291           (tzo (timezone-locale-offset tzi))
1292           (tv (seconds->utc-time (+ isec tzo))))
1293      (tm:make-date
1294       (round (* (- fsec isec) NS/S))
1295       (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
1296       (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
1297       tzo (timezone-locale-name tzi) (timezone-locale-dst? tzi)
1298       (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
1299
1300(define (current-date . tzi) (apply time-utc->date (tm:current-time-utc) tzi))
1301
1302;;
1303
1304(define date? %date?)
1305
1306;;
1307
1308(define (date-nanosecond dat)
1309        (%check-date 'date-nanosecond dat)
1310        (%date-nanosecond dat) )
1311
1312(define (date-second dat)
1313        (%check-date 'date-second dat)
1314        (%date-second dat) )
1315
1316(define (date-minute dat)
1317        (%check-date 'date-minute dat)
1318        (%date-minute dat) )
1319
1320(define (date-hour dat)
1321        (%check-date 'date-hour dat)
1322        (%date-hour dat) )
1323
1324(define (date-day dat)
1325        (%check-date 'date-day dat)
1326        (%date-day dat) )
1327
1328(define (date-month dat)
1329        (%check-date 'date-month dat)
1330        (%date-month dat) )
1331
1332(define (date-year dat)
1333        (%check-date 'date-year dat)
1334        (%date-year dat) )
1335
1336(define (date-dst? dat)
1337        (%check-date 'date-dst? dat)
1338        (%date-dst? dat) )
1339
1340(define (date-zone-offset dat)
1341        (%check-date 'date-zone-offset dat)
1342        (%date-zone-offset dat) )
1343
1344(define (date-zone-name dat)
1345        (%check-date 'date-zone-name dat)
1346        (%date-zone-name dat) )
1347
1348;; Date Comparison
1349
1350(define (tm:date-compare loc dat1 dat2)
1351  (%check-date loc dat1)
1352  (%check-date loc dat2)
1353  (if (not (fx= (%date-zone-offset dat1) (%date-zone-offset dat2)))
1354      (error loc "cannot compare dates from different time-zones" dat1 dat2)
1355      (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
1356        (if (not (fx= 0 dif)) dif
1357            (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
1358              (if (not (fx= 0 dif)) dif
1359                  (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
1360                    (if (not (fx= 0 dif)) dif
1361                        (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
1362                          (if (not (fx= 0 dif)) dif
1363                              (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
1364                                (if (not (fx= 0 dif)) dif
1365                                    (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
1366                                      (if (not (fx= 0 dif)) dif
1367                                          (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
1368
1369(define (date-compare dat1 dat2)
1370  (let ((dif (tm:date-compare 'date-compare dat1 dat2)))
1371    (cond ((fx> 0 dif)  -1)
1372          ((fx< 0 dif)  1)
1373          (else         0) ) ) )
1374
1375(define (date=? dat1 dat2)
1376  (fx= 0 (tm:date-compare 'date=? dat1 dat2)) )
1377
1378(define (date<? dat1 dat2)
1379  (fx> 0 (tm:date-compare 'date<? dat1 dat2)) )
1380
1381(define (date<=? dat1 dat2)
1382  (fx>= 0 (tm:date-compare 'date<=? dat1 dat2)) )
1383
1384(define (date>? dat1 dat2)
1385  (fx< 0 (tm:date-compare 'date>? dat1 dat2)) )
1386
1387(define (date>=? dat1 dat2)
1388  (fx<= 0 (tm:date-compare 'date>=? dat1 dat2)) )
1389
1390;; Date Arithmetic
1391
1392(define (date-difference dat1 dat2 . timtyp)
1393  (%check-date 'date-difference dat1)
1394  (%check-date 'date-difference dat2)
1395  (let ((tim1 (apply date->time dat1 timtyp))
1396        (tim2 (apply date->time dat2 timtyp)))
1397    (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
1398
1399(define (date-add-duration dat dur . timtyp)
1400  (%check-date 'date-add-duration dat)
1401  (tm:check-duration 'date-add-duration dur)
1402  (let ((tim (apply date->time dat timtyp)))
1403    (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
1404
1405(define (date-subtract-duration dat dur . timtyp)
1406  (%check-date 'date-subtract-duration dat)
1407  (tm:check-duration 'date-subtract-duration dur)
1408  (let ((tim (apply date->time dat timtyp)))
1409    (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
1410
1411;; Time to Date
1412
1413;; Gives the seconds/day/month/year
1414
1415(define (tm:decode-julian-day-number jdn)
1416  (let* ((dys (%->fixnum (truncate jdn)))
1417         (a (fx+ dys 32044))
1418         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
1419         (c (fx- a (fx/ (fx* 146097 b) 4)))
1420         (d (fx/ (fx+ (fx* 4 c) 3) 1461))
1421         (e (fx- c (fx/ (fx* 1461 d) 4)))
1422         (m (fx/ (fx+ (fx* 5 e) 2) 153))
1423         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))))
1424    (values ; seconds day month year
1425      (%->fixnum (floor (* (- jdn dys) SEC/DY)))
1426      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
1427      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
1428      (if (fx<= y 0) (fx- y 1) y)) ) )
1429
1430;; Gives the Julian day number - rounds up to the nearest day
1431
1432(define (tm:seconds->julian-day-number sec tzo)
1433  (+ TAI-EPOCH-IN-JD
1434     ; Round to day boundary
1435     (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
1436
1437;; Is the time object one second before a leap second?
1438
1439(define (tm:tai-before-leap-second? tim)
1440  (let ((sec (%time-second tim)))
1441    (let loop ((lst tm:second-before-leap-second-table))
1442      (and (not (null? lst))
1443           (or (= sec (car lst))
1444               (loop (cdr lst)) ) ) ) ) )
1445
1446(define (tm:time->date loc tim tzi)
1447  ; The tz-info is caller's rest parameter
1448  (let ((tzo (optional tzi (local-timezone-locale)))
1449        (tzn #f)
1450        (dstf #f))
1451      (when (timezone-locale? tzo)
1452        (set! dstf (timezone-locale-dst? tzo))
1453        (set! tzn (timezone-locale-name tzo))
1454        (set! tzo (timezone-locale-offset tzo)))
1455      (unless (fixnum? tzo)
1456        (error loc "invalid timezone offset" tzo) )
1457      (receive (secs dy mn yr)
1458          (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
1459        (let ((hr (fx/ secs SEC/HR))
1460              (rsecs (fxmod secs SEC/HR)))
1461          (let ((min (fx/ rsecs SEC/MIN))
1462                (sec (fxmod rsecs SEC/MIN)))
1463            (tm:make-date (%time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) )
1464
1465(define (tm:time-tai->date loc tim tzi)
1466  (let ((tm-utc (tm:time-tai->time-utc tim (tm:as-empty-time tim))))
1467    (if (tm:tai-before-leap-second? tim)
1468        ; then time is *right* before the leap, we need to pretend to subtract a second ...
1469        (let ((dat (tm:time->date loc (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
1470          (%date-second-set! dat SEC/MIN) ; Note full minute!
1471          dat )
1472        (tm:time->date loc tm-utc tzi) ) ) )
1473
1474(define (time-tai->date tim . tzi)
1475  (tm:check-time-and-type 'time-tai->date tim 'time-tai)
1476  (tm:time-tai->date 'time-tai->date tim tzi) )
1477
1478(define (time-utc->date tim . tzi)
1479  (tm:check-time-and-type 'time-utc->date tim 'time-utc)
1480  (tm:time->date 'time-utc->date tim tzi) )
1481
1482(define (time-monotonic->date tim . tzi)
1483  (tm:check-time-and-type 'time-monotonic->date tim 'time-monotonic)
1484  (tm:time->date 'time-monotonic->date tim tzi) )
1485
1486(define (time->date tim . tzi)
1487  (%check-time 'time->date tim)
1488  (case (%time-type tim)
1489    ((time-monotonic) (tm:time->date 'time->date tim tzi))
1490    ((time-utc)       (tm:time->date 'time->date tim tzi))
1491    ((time-tai)       (tm:time-tai->date 'time->date tim tzi))
1492    (else ; This shouldn't happen
1493     (error 'time->date "invalid clock type" tim))) )
1494
1495;; Date to Time
1496
1497;; Gives the Julian day number - Gregorian proleptic calendar
1498
1499(define (tm:encode-julian-day-number dy mn yr)
1500  (let* ((a (fx/ (fx- 14 mn) MN/YR))
1501         (b (fx- (fx+ yr 4800) a))
1502         (y (if (negative? yr) (fx+ b 1) b)) ; BCE?
1503         (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
1504    (+ dy
1505      (fx/ (fx+ (fx* 153 m) 2) 5)
1506      (fx* y DY/YR)
1507      (fx/ y 4)
1508      (fx/ y -100)
1509      (fx/ y 400)
1510      -32045) ) )
1511
1512(define (tm:date->time-utc loc dat)
1513  (let ((ns (%date-nanosecond dat))
1514        (sec (%date-second dat))
1515        (min (%date-minute dat))
1516        (hr (%date-hour dat))
1517        (dy (%date-day dat))
1518        (mn (%date-month dat))
1519        (yr (%date-year dat))
1520        (tzo (%date-zone-offset dat)))
1521    (let ((jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
1522          (secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))))
1523      (tm:make-time 'time-utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
1524
1525(define (tm:date->time-tai loc dat)
1526  (let* ((tm-utc (tm:date->time-utc loc dat))
1527         (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
1528    (if (fx= 60 (%date-second dat))
1529        (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai)
1530        tm-tai ) ) )
1531
1532(define (tm:date->time-monotonic loc dat)
1533  (let ((tim-utc (tm:date->time-utc loc dat)))
1534    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
1535
1536(define (date->time-utc dat)
1537  (%check-date 'date->time-utc dat)
1538  (tm:date->time-utc 'date->time-utc dat) )
1539
1540(define (date->time-tai dat)
1541  (%check-date 'date->time-tai dat)
1542  (tm:date->time-tai 'date->time-tai dat) )
1543
1544(define (date->time-monotonic dat)
1545  (%check-date 'date->time-monotonic dat)
1546  (tm:date->time-monotonic 'date->time-monotonic dat) )
1547
1548(define (date->time dat . timtyp)
1549  (%check-date 'date->time dat)
1550  (case (optional timtyp (default-date-clock-type))
1551    ((time-monotonic) (tm:date->time-monotonic  'date->time dat))
1552    ((time-utc)       (tm:date->time-utc 'date->time dat))
1553    ((time-tai)       (tm:date->time-tai 'date->time dat))
1554    (else
1555     (error 'date->time "invalid clock type" timtyp))) )
1556
1557;; Leap Year
1558
1559(define (leap-year? dat)
1560  (%check-date 'date-leap-year? dat)
1561  (tm:leap-year? (%date-year dat)) )
1562
1563;; Day of Year
1564
1565(define (tm:year-day dy mn yr)
1566  (let ((yrdy (fx+ dy (vector-ref tm:cumulative-month-days mn))))
1567    (if (and (tm:leap-year? yr) (fx< 2 mn)) (fx+ yrdy 1)
1568        yrdy ) ) )
1569
1570(define (date-year-day dat)
1571  (%check-date 'date-year-day dat)
1572  (or (%date-yday dat)
1573      (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
1574        (%date-yday-set! dat yrdy)
1575        yrdy ) ) )
1576
1577;; Week Day
1578
1579;; Using Gregorian Calendar (from Calendar FAQ)
1580
1581(define (tm:week-day dy mn yr)
1582  (let* ((a (fx/ (fx- 14 mn) MN/YR))
1583         (y (fx- yr a))
1584         (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
1585    (fxmod
1586     (fx+ (fx+ dy y)
1587          (fx+ (fx- (fx/ y 4) (fx/ y 100))
1588               (fx+ (fx/ y 400)
1589                    (fx/ (fx* m DY/MN) MN/YR))))
1590     DY/WK) ) )
1591
1592(define (tm:days-before-first-week dat day-of-week-starting-week)
1593  (fxmod
1594   (fx- day-of-week-starting-week (tm:week-day 1 1 (%date-year dat)))
1595   DY/WK) )
1596
1597(define (date-week-day dat)
1598  (%check-date 'date-week-day dat)
1599  (or (%date-wday dat)
1600      (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
1601        (%date-wday-set! dat wdy)
1602        wdy ) ) )
1603
1604(define (date-week-number dat . args)
1605  (%check-date 'date-week-number dat)
1606  (let ((day-of-week-starting-week (optional args 0)))
1607    (fx/
1608     (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
1609     DY/WK) ) )
1610
1611;; Julian-day Operations
1612
1613;; Date to Julian-day
1614
1615; Does the nanoseconds value contribute anything to the julian day?
1616; The range is < 1 second here (but not in the reference).
1617
1618(define (tm:julian-day ns sec min hr dy mn yr tzo)
1619  (+ (- (tm:encode-julian-day-number dy mn yr) ONE-HALF)
1620     (/ (+ (fx+ (fx+ (fx* hr SEC/HR)
1621                     (fx+ (fx* min SEC/MIN) sec))
1622                (fxneg tzo))
1623           (/ ns NS/S))
1624        SEC/DY)) )
1625
1626#; ; inexact version
1627(define (tm:julian-day ns sec min hr dy mn yr tzo)
1628  (fp+ (fp- (exact->inexact (tm:encode-julian-day-number dy mn yr)) iONE-HALF)
1629       (fp/ (fp+ (exact->inexact (fx+ (fx+ (fx* hr SEC/HR)
1630                                           (fx+ (fx* min SEC/MIN) sec))
1631                                      (fxneg tzo)))
1632                 (fp/ (exact->inexact ns) iNS/S))
1633            iSEC/DY)) )
1634
1635(define (tm:date->julian-day loc dat)
1636  (%check-date loc dat)
1637  (or (%date-jday dat)
1638      (let ((jdn
1639             (tm:julian-day
1640              (%date-nanosecond dat)
1641              (%date-second dat) (%date-minute dat) (%date-hour dat)
1642              (%date-day dat) (%date-month dat) (%date-year dat)
1643              (%date-zone-offset dat))))
1644        (%date-jday-set! dat jdn)
1645        jdn ) ) )
1646
1647(define (date->julian-day dat) (tm:date->julian-day 'date->julian-day dat))
1648
1649(define (date->modified-julian-day dat)
1650  (- (tm:date->julian-day 'date->modified-julian-day dat) TAI-EPOCH-IN-MODIFIED-JD) )
1651
1652;; Time to Julian-day
1653
1654(define (tm:seconds->julian-day ns sec) (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)))
1655
1656(define-inline (%time-tai->julian-day tim)
1657  (let ((sec (%time-second tim)))
1658    (tm:seconds->julian-day (%time-nanosecond tim) (- sec (tm:leap-second-delta sec))) ) )
1659
1660(define (tm:time-utc->julian-day tim)
1661  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
1662
1663(define (tm:time-tai->julian-day tim) (%time-tai->julian-day tim))
1664
1665(define (tm:time-monotonic->julian-day tim) (%time-tai->julian-day tim))
1666
1667(define (time-utc->julian-day tim)
1668  (tm:check-time-and-type 'time-utc->julian-day tim 'time-utc)
1669  (tm:time-utc->julian-day tim) )
1670
1671(define (time-tai->julian-day tim)
1672  (tm:check-time-and-type 'time-tai->julian-day tim 'time-tai)
1673  (tm:time-tai->julian-day tim) )
1674
1675(define (time-monotonic->julian-day tim)
1676  (tm:check-time-and-type 'time-monotonic->julian-day tim 'time-monotonic)
1677  (tm:time-monotonic->julian-day tim) )
1678
1679(define (time->julian-day tim)
1680  (%check-time 'time->julian-day tim)
1681  (case (%time-type tim)
1682    ((time-monotonic) (tm:time-monotonic->julian-day tim))
1683    ((time-utc)       (tm:time-utc->julian-day tim))
1684    ((time-tai)       (tm:time-tai->julian-day tim))
1685    (else
1686     (error 'time->julian-day "invalid clock type" tim))) )
1687
1688(define (tm:time-utc->modified-julian-day tim)
1689  (- (tm:time-utc->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
1690
1691(define (tm:time-tai->modified-julian-day tim)
1692  (- (tm:time-tai->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
1693
1694(define (tm:time-monotonic->modified-julian-day tim)
1695  (- (tm:time-monotonic->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
1696
1697(define (time-utc->modified-julian-day tim)
1698  (tm:check-time-and-type 'time-utc->modified-julian-day tim 'time-utc)
1699  (tm:time-utc->modified-julian-day tim) )
1700
1701(define (time-tai->modified-julian-day tim)
1702  (tm:check-time-and-type 'time-tai->modified-julian-day tim 'time-tai)
1703  (tm:time-tai->modified-julian-day tim) )
1704
1705(define (time-monotonic->modified-julian-day tim)
1706  (tm:check-time-and-type 'time-monotonic->modified-julian-day tim 'time-monotonic)
1707  (tm:time-monotonic->modified-julian-day tim) )
1708
1709(define (time->modified-julian-day tim)
1710  (%check-time 'time->modified-julian-day tim)
1711  (case (%time-type tim)
1712    ((time-monotonic) (tm:time-monotonic->modified-julian-day tim))
1713    ((time-utc)       (tm:time-utc->modified-julian-day tim))
1714    ((time-tai)       (tm:time-tai->modified-julian-day tim))
1715    (else
1716     (error 'time->modified-julian-day "invalid clock type" tim))) )
1717
1718;; Julian-day to Time
1719
1720(define (julian-day->time-utc jdn)
1721  (receive (ns sec) (tm:split-nanoseconds (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S))
1722    (tm:make-time 'time-utc ns sec) ) )
1723
1724(define (julian-day->time-tai jdn)
1725  (time-utc->time-tai! (julian-day->time-utc jdn)) )
1726
1727(define (julian-day->time-monotonic jdn)
1728  (time-utc->time-monotonic! (julian-day->time-utc jdn)) )
1729
1730(define (julian-day->date jdn . tzi)
1731  (apply time-utc->date (julian-day->time-utc jdn) tzi) )
1732
1733(define (modified-julian-day->time-utc mjdn)
1734  (julian-day->time-utc (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
1735
1736(define (modified-julian-day->time-tai mjdn)
1737  (julian-day->time-tai (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
1738
1739(define (modified-julian-day->time-monotonic mjdn)
1740  (julian-day->time-monotonic (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
1741
1742(define (modified-julian-day->date mjdn . tzi)
1743  (apply julian-day->date (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) tzi) )
1744
1745;; The Julian-day
1746
1747(define (current-julian-day)
1748  (time-utc->julian-day (tm:current-time-utc)) )
1749
1750(define (current-modified-julian-day)
1751  (time-utc->modified-julian-day (tm:current-time-utc)) )
Note: See TracBrowser for help on using the repository browser.