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

Last change on this file since 33841 was 33841, checked in by kon, 10 months ago

add {{TIME-FINE-GRAIN}}, generalize {{make-time}}, add {{date-adjust}}.

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