source: project/release/4/srfi-19/tags/3.4.1/srfi-19-support.scm @ 33883

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

fix nano sqrd issue when making time

File size: 53.0 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) (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 (tm:current-sub-milliseconds)
769        (inexact->exact (remainder (current-milliseconds) MS/S)) )
770
771(define (tm:current-nanoseconds)
772  (fx* (tm:current-sub-milliseconds) NS/MS) )
773
774;Use the 'official' seconds & nanoseconds values
775;
776(define-syntax tm:current-time-values
777        (syntax-rules ()
778                ((_)
779      (values (tm:current-nanoseconds) (current-seconds)) ) ) )
780
781(define-syntax tm:current-time-utc
782        (syntax-rules ()
783                ((_)
784                  (let-values (((ns sec) (tm:current-time-values)))
785        (tm:make-time 'utc ns sec) ) ) ) )
786
787(define-syntax tm:current-time-tai
788        (syntax-rules ()
789                ((_)
790      (let-values (((ns sec) (tm:current-time-values)))
791        (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) ) ) )
792
793(define-syntax tm:current-time-monotonic
794        (syntax-rules ()
795                ((_)
796      (let ((tim (tm:current-time-tai)))
797        ;time-monotonic is time-tai
798        (%time-type-set! tim 'monotonic)
799        tim ) ) ) )
800
801(define-syntax tm:current-time-thread
802        (syntax-rules ()
803                ((_)
804      (tm:milliseconds->time (current-thread-milliseconds) 'thread) ) ) )
805
806(define-syntax tm:current-time-process
807        (syntax-rules ()
808                ((_)
809      (tm:milliseconds->time (current-process-milliseconds) 'process) ) ) )
810
811(define-syntax tm:current-time-gc
812        (syntax-rules ()
813                ((_)
814      (tm:milliseconds->time (total-gc-milliseconds) 'gc) ) ) )
815
816;; -- Time Resolution
817;; This is the resolution of the clock in nanoseconds.
818;; This will be implementation specific.
819
820(define (tm:time-resolution tt)
821  NS/MS )
822
823;; Specialized Time Parameter Checking
824
825(define (error-incompatible-time-types loc tt1 tt2)
826  (signal-type-error loc "incompatible time-types"  tt1 tt2) )
827
828(define (check-time-has-type loc tim tt)
829  (unless (tm:time-has-type? tim tt)
830    (error-incompatible-time-types loc (%time-type tim) tt) ) )
831
832(define (check-time-and-type loc tim tt)
833  (check-time loc tim)
834  (check-time-has-type loc tim tt) )
835
836(define (check-duration loc obj) (check-time-and-type loc obj 'duration))
837
838(define (check-time-elements loc obj1 obj2 obj3)
839  (check-time-type loc obj1)
840  (check-time-nanoseconds loc obj2)
841  (check-time-seconds loc obj3) )
842
843#; ;UNUSED
844(define (check-times loc objs) (for-each (cut check-time loc <>) objs))
845
846(define (check-time-binop loc obj1 obj2)
847  (check-time loc obj1)
848  (check-time loc obj2) )
849
850(define (check-time-compare loc obj1 obj2)
851  (check-time-binop loc obj1 obj2)
852  (check-time-has-type loc obj1 (%time-type obj2)) )
853
854(define (check-time-aritmetic loc tim dur)
855  (check-time loc tim)
856  (check-duration loc dur) )
857
858;; Time Comparison
859
860(define (tm:time-compare tim1 tim2)
861  (let ((dif (- (%time-second tim1) (%time-second tim2))))
862    (if (not (zero? dif))
863      dif
864      (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
865
866(define (tm:time=? tim1 tim2)
867  (and
868    (= (%time-second tim1) (%time-second tim2))
869    (fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
870
871(define (tm:time<? tim1 tim2)
872  (or
873    (< (%time-second tim1) (%time-second tim2))
874    (and
875      (= (%time-second tim1) (%time-second tim2))
876      (fx< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
877
878(define (tm:time<=? tim1 tim2)
879  (or
880    (< (%time-second tim1) (%time-second tim2))
881    (and
882      (= (%time-second tim1) (%time-second tim2))
883      (fx<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
884
885(define (tm:time>? tim1 tim2)
886  (or
887    (> (%time-second tim1) (%time-second tim2))
888    (and
889      (= (%time-second tim1) (%time-second tim2))
890      (fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
891
892(define (tm:time>=? tim1 tim2)
893  (or
894    (> (%time-second tim1) (%time-second tim2))
895    (and
896      (= (%time-second tim1) (%time-second tim2))
897      (fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
898
899(define-syntax tm:time-max
900        (syntax-rules ()
901                ((_ ?tim1 ?tim2)
902                  (let ((tim1 ?tim1) (tim2 ?tim2))
903        (if (tm:time>? tim1 tim2) tim1 tim2) ) ) ) )
904
905(define-syntax tm:time-min
906        (syntax-rules ()
907                ((_ ?tim1 ?tim2)
908                  (let ((tim1 ?tim1) (tim2 ?tim2))
909        (if (tm:time<? tim1 tim2) tim1 tim2) ) ) ) )
910
911;; Time Arithmetic
912
913(define (tm:add-duration tim1 dur timout)
914        (let-values (((ns sec)
915                  (tm:nanoseconds->time-values
916                    (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
917    (let ((secs (+ (%time-second tim1) (%time-second dur) sec)))
918      (cond
919        ((negative? ns) ;Borrow
920          ;Should never happen
921          (tm:time-second-set! timout (+ secs -1))
922          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
923        (else
924          (tm:time-second-set! timout secs)
925          (tm:time-nanosecond-set! timout ns) ) )
926      timout ) ) )
927
928(define (tm:subtract-duration tim1 dur timout)
929  (let-values (((ns sec)
930                    (tm:nanoseconds->time-values
931                      (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
932    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
933    (let ((secs (- (%time-second tim1) (%time-second dur) sec)))
934      (cond
935        ((negative? ns) ;Borrow
936          (tm:time-second-set! timout (- secs 1))
937          (tm:time-nanosecond-set! timout (+ ns NS/S)) )
938        (else
939          (tm:time-second-set! timout secs)
940          (tm:time-nanosecond-set! timout ns) ) )
941      timout ) ) )
942
943(define (tm:divide-duration dur1 num durout)
944  (let-values (((ns sec)
945                (tm:nanoseconds->time-values
946                  (/ (tm:time->nanoseconds dur1) num))) )
947    (tm:time-nanosecond-set! durout ns)
948    (tm:time-second-set! durout sec)
949    durout ) )
950
951(define (tm:multiply-duration dur1 num durout)
952        (let-values (((ns sec)
953                (tm:nanoseconds->time-values
954                  (* (tm:time->nanoseconds dur1) num))) )
955    (tm:time-nanosecond-set! durout ns)
956    (tm:time-second-set! durout sec)
957    durout ) )
958
959(define (tm:time-difference tim1 tim2 timout)
960  (let-values (((ns sec)
961                (tm:nanoseconds->time-values
962                  (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
963    (tm:time-second-set! timout sec)
964    (tm:time-nanosecond-set! timout ns)
965    timout ) )
966
967(define-syntax tm:time-abs
968        (syntax-rules ()
969                ((_ ?tim1 ?timout)
970                  (let ((tim1 ?tim1)
971                        (timout ?timout))
972        (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
973        (tm:time-second-set! timout (abs (%time-second tim1)))
974        timout ) ) ) )
975
976(define (tm:time-negate tim1 timout )
977  (tm:time-nanosecond-set! timout (- (%time-nanosecond tim1)))
978  (tm:time-second-set! timout (- (%time-second tim1)))
979  timout )
980
981(define (tm:time-negative? tim)
982  ;nanoseconds irrelevant
983  (negative? (tm:time-second tim)) )
984
985(define (tm:time-positive? tim)
986  ;nanoseconds irrelevant
987  (positive? (tm:time-second tim)) )
988
989(define (tm:time-zero? tim)
990  (and
991    (zero? (tm:time-nanosecond tim))
992    (zero? (tm:time-second tim))) )
993
994;; Time Type Converters
995
996(define (tm:time-tai->time-utc timin timout)
997  (%time-type-set! timout 'utc)
998  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
999  (tm:time-second-set!
1000    timout
1001    (-
1002      (%time-second timin)
1003      (leap-second-neg-delta (%time-second timin))))
1004  timout )
1005
1006(define-syntax tm:time-tai->time-monotonic
1007        (syntax-rules ()
1008                ((_ ?timin ?timout)
1009                  (let ((timin ?timin)
1010                        (timout ?timout))
1011        (%time-type-set! timout 'monotonic)
1012        (unless (eq? timin timout)
1013          (tm:time-nanosecond-set! timout (%time-nanosecond timin))
1014          (tm:time-second-set! timout (%time-second timin)))
1015        timout ) ) ) )
1016
1017(define (tm:time-utc->time-tai timin timout)
1018  (%time-type-set! timout 'tai)
1019  (tm:time-nanosecond-set! timout (%time-nanosecond timin))
1020  (tm:time-second-set!
1021    timout
1022    (+
1023      (%time-second timin)
1024      (leap-second-delta (%time-second timin))))
1025  timout )
1026
1027(define-syntax tm:time-utc->time-monotonic
1028        (syntax-rules ()
1029                ((_ ?timin ?timout)
1030                  (let ((timin ?timin)
1031                        (timout ?timout))
1032        (let ((ntim (tm:time-utc->time-tai timin timout)))
1033          (%time-type-set! ntim 'monotonic)
1034          ntim ) ) ) ) )
1035
1036(define-syntax tm:time-monotonic->time-tai
1037        (syntax-rules ()
1038                ((_ ?timin ?timout)
1039                  (let ((timin ?timin)
1040                        (timout ?timout))
1041        (%time-type-set! timout 'tai)
1042        (unless (eq? timin timout)
1043          (tm:time-nanosecond-set! timout (%time-nanosecond timin))
1044          (tm:time-second-set! timout (%time-second timin)))
1045        timout ) ) ) )
1046
1047(define-syntax tm:time-monotonic->time-utc
1048        (syntax-rules ()
1049                ((_ ?timin ?timout)
1050                  (let ((timin ?timin)
1051                        (timout ?timout))
1052        #;(%time-type-set! timin 'tai) ; fool converter (unnecessary)
1053        (tm:time-tai->time-utc timin timout) ) ) ) )
1054
1055;;; Date Object (Public Immutable)
1056
1057;; Leap Year Test
1058
1059;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
1060;; The Journal of the Royal Astronomical Society of Canada.
1061;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
1062;; Part II, volume 58, number 2, pages 79-87 (April 1964).
1063
1064(define-syntax tm:leap-year?
1065        (syntax-rules ()
1066                ((_ ?yr)
1067                  (let ((yr ?yr))
1068        (and
1069          (not (fx= (fxmod yr 4000) 0)) ;Not officially adopted!
1070          (or
1071            (fx= (fxmod yr 400) 0)
1072            (and
1073              (fx= (fxmod yr 4) 0)
1074              (not (fx= (fxmod yr 100) 0))))) ) ) ) )
1075
1076;; Days per Month
1077
1078;Month range 1..12 so dys/mn range 0..12
1079(define      +year-dys/mn+ '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
1080(define +leap-year-dys/mn+ '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
1081
1082(define-syntax tm:leap-day?
1083        (syntax-rules ()
1084                ((_ ?dy ?mn)
1085                  (let ((dy ?dy) (mn ?mn))
1086        (fx= dy (vector-ref +leap-year-dys/mn+ mn)) ) ) ) )
1087
1088(define-syntax tm:days-in-month
1089        (syntax-rules ()
1090                ((_ ?yr ?mn)
1091                  (let ((yr ?yr) (mn ?mn))
1092        (vector-ref
1093          (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+)
1094          mn) ) ) ) )
1095
1096;;
1097
1098#;
1099(define-record-type-variant date (unchecked inline unsafe)
1100  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1101  %date?
1102  (ns     %date-nanosecond  %date-nanosecond-set!)
1103  (sec    %date-second      %date-second-set!)
1104  (min    %date-minute      %date-minute-set!)
1105  (hr     %date-hour        %date-hour-set!)
1106  (dy     %date-day         %date-day-set!)
1107  (mn     %date-month       %date-month-set!)
1108  (yr     %date-year        %date-year-set!)
1109  (tzo    %date-zone-offset %date-zone-offset-set!)
1110  ;; non-srfi extn
1111  (tzn    %date-zone-name   %date-zone-name-set!)
1112  (dstf   %date-dst?        %date-dst-set!)
1113  (wdy    %date-wday        %date-wday-set!)
1114  (ydy    %date-yday        %date-yday-set!)
1115  (jdy    %date-jday        %date-jday-set!) )
1116
1117(define-record-type date
1118  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1119  %date?
1120  (ns     %date-nanosecond  %date-nanosecond-set!)
1121  (sec    %date-second      %date-second-set!)
1122  (min    %date-minute      %date-minute-set!)
1123  (hr     %date-hour        %date-hour-set!)
1124  (dy     %date-day         %date-day-set!)
1125  (mn     %date-month       %date-month-set!)
1126  (yr     %date-year        %date-year-set!)
1127  (tzo    %date-zone-offset %date-zone-offset-set!)
1128  ;; non-srfi extn
1129  (tzn    %date-zone-name   %date-zone-name-set!)
1130  (dstf   %date-dst?        %date-dst-set!)
1131  (wdy    %date-wday        %date-wday-set!)
1132  (ydy    %date-yday        %date-yday-set!)
1133  (jdy    %date-jday        %date-jday-set!) )
1134
1135(define date? %date?)
1136
1137;;
1138
1139(define-constant DATE-FORMAT-SRFI-10 "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)")
1140
1141(define-constant DATE-FORMAT-BRACKET "<date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A>")
1142
1143(define date-record-printer-format (make-parameter DATE-FORMAT-SRFI-10
1144  (lambda (x)
1145    (if (string? x)
1146      x
1147      (begin
1148        (warning 'date-record-printer-format "invalid format" x)
1149        (date-record-printer-format) ) ) ) ) )
1150
1151(define-record-printer (date dat out)
1152  (format out (date-record-printer-format)
1153   (%date-nanosecond dat)
1154   (%date-second dat) (%date-minute dat) (%date-hour dat)
1155   (%date-day dat) (%date-month dat) (%date-year dat)
1156   (%date-zone-offset dat)
1157   (%date-zone-name dat) (%date-dst? dat)
1158   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
1159
1160(define-reader-ctor 'date
1161  (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
1162    (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))
1163
1164;;
1165
1166; Nanoseconds in [0 NS/S-1]
1167(define-syntax date-nanoseconds?
1168        (syntax-rules ()
1169                ((_ ?obj)
1170                  (let ((obj ?obj))
1171        (and
1172          (fixnum? obj)
1173          (fx<= 0 obj)
1174          (fx< obj NS/S)) ) ) ) )
1175
1176; Seconds in [0 SEC/MIN] ; SEC/MIN legal due to leap second
1177(define-syntax date-seconds?
1178        (syntax-rules ()
1179                ((_ ?obj)
1180                  (let ((obj ?obj))
1181        (and
1182          (fixnum? obj)
1183          (fx<= 0 obj)
1184          (fx<= obj SEC/MIN)) ) ) ) )
1185
1186; Minutes in [0 SEC/MIN-1]
1187(define-syntax date-minutes?
1188        (syntax-rules ()
1189                ((_ ?obj)
1190                  (let ((obj ?obj))
1191        (and
1192          (fixnum? obj)
1193          (fx<= 0 obj)
1194          (fx< obj SEC/MIN)) ) ) ) )
1195
1196; Hours in [0 HR/DY-1]
1197(define-syntax date-hours?
1198        (syntax-rules ()
1199                ((_ ?obj)
1200                  (let ((obj ?obj))
1201        (and
1202          (fixnum? obj)
1203          (fx<= 0 obj)
1204          (fx< obj HR/DY)) ) ) ) )
1205
1206; Days in [1 28/29/30/31] - depending on month & year
1207(define-syntax date-day?
1208        (syntax-rules ()
1209                ((_ ?obj ?mn ?yr)
1210                  (let ((obj ?obj) (mn ?mn) (yr ?yr))
1211        (and
1212          (fixnum? obj)
1213          (fx<= 1 obj)
1214          (fx<= obj (tm:days-in-month yr mn))) ) ) ) )
1215
1216; Months in [1 MN/YR]
1217(define-syntax date-month?
1218        (syntax-rules ()
1219                ((_ ?obj)
1220                  (let ((obj ?obj))
1221        (and
1222          (fixnum? obj)
1223          (fx<= 1 obj)
1224          (fx<= obj MN/YR)) ) ) ) )
1225
1226; No year 0!
1227(define (date-year? obj)
1228  (and
1229    (fixnum? obj)
1230    (not (fx= 0 obj))) )
1231
1232;;
1233
1234(define-check+error-type date-nanoseconds)
1235(define-check+error-type date-seconds)
1236(define-check+error-type date-minutes)
1237(define-check+error-type date-hours)
1238(define-error-type date-day)
1239(define (check-date-day loc obj mn yr) (unless (date-day? obj mn yr) (error-date-day loc obj)) )
1240(define-check+error-type date-month)
1241(define-check+error-type date-year)
1242
1243(define (check-date-elements loc ns sec min hr dy mn yr tzo tzn)
1244  (check-date-nanoseconds loc ns)
1245  (check-date-seconds loc sec)
1246  (check-date-minutes loc min)
1247  (check-date-hours loc hr)
1248  (check-date-year loc yr)
1249  (check-date-month loc mn)
1250  (check-date-day loc dy mn yr)
1251  (check-timezone-offset loc tzo "date-timezone-offset")
1252  (check-timezone-name loc tzn "date-timezone-name") )
1253
1254;;
1255
1256(define (error-date-compatible-timezone loc dat1 dat2)
1257  (signal-type-error loc "not compatible timezones" dat1 dat2) )
1258
1259(define (check-date-compatible-timezone-offsets loc dat1 dat2)
1260  (unless (fx= (%date-zone-offset dat1) (%date-zone-offset dat2))
1261    (error-date-compatible-timezone loc dat1 dat2) ) )
1262
1263;;
1264
1265(define (clock-type? obj) (memq obj '(monotonic tai utc)))
1266
1267(define-check+error-type clock-type)
1268
1269(define (error-convert loc srcnam dstnam obj)
1270  (signal-type-error loc (conc "cannot convert " srcnam " to " dstnam) obj) )
1271
1272(define-check+error-type date %date?)
1273
1274;;
1275
1276;;; Getters
1277
1278(define-syntax tm:date-nanosecond
1279        (syntax-rules ()
1280                ((_ ?dat)
1281                  (let ((dat ?dat))
1282        (%date-nanosecond dat) ) ) ) )
1283
1284(define-syntax tm:date-second
1285        (syntax-rules ()
1286                ((_ ?dat)
1287                  (let ((dat ?dat))
1288        (%date-second dat) ) ) ) )
1289
1290(define-syntax tm:date-minute
1291        (syntax-rules ()
1292                ((_ ?dat)
1293                  (let ((dat ?dat))
1294        (%date-minute dat) ) ) ) )
1295
1296(define-syntax tm:date-hour
1297        (syntax-rules ()
1298                ((_ ?dat)
1299                  (let ((dat ?dat))
1300        (%date-hour dat) ) ) ) )
1301
1302(define-syntax tm:date-day
1303        (syntax-rules ()
1304                ((_ ?dat)
1305                  (let ((dat ?dat))
1306        (%date-day dat) ) ) ) )
1307
1308(define-syntax tm:date-month
1309        (syntax-rules ()
1310                ((_ ?dat)
1311                  (let ((dat ?dat))
1312        (%date-month dat) ) ) ) )
1313
1314(define-syntax tm:date-year
1315        (syntax-rules ()
1316                ((_ ?dat)
1317                  (let ((dat ?dat))
1318        (%date-year dat) ) ) ) )
1319
1320(define-syntax tm:date-zone-offset
1321        (syntax-rules ()
1322                ((_ ?dat)
1323                  (let ((dat ?dat))
1324        (%date-zone-offset dat) ) ) ) )
1325
1326(define-syntax tm:date-zone-name
1327        (syntax-rules ()
1328                ((_ ?dat)
1329                  (let ((dat ?dat))
1330        (%date-zone-name dat) ) ) ) )
1331
1332(define-syntax tm:date-dst?
1333        (syntax-rules ()
1334                ((_ ?dat)
1335                  (let ((dat ?dat))
1336        (%date-dst? dat) ) ) ) )
1337
1338(define-syntax tm:date-wday
1339        (syntax-rules ()
1340                ((_ ?dat)
1341                  (let ((dat ?dat))
1342        (%date-wday dat) ) ) ) )
1343
1344(define-syntax tm:date-yday
1345        (syntax-rules ()
1346                ((_ ?dat)
1347                  (let ((dat ?dat))
1348        (%date-yday dat) ) ) ) )
1349
1350(define-syntax tm:date-jday
1351        (syntax-rules ()
1352                ((_ ?dat)
1353                  (let ((dat ?dat))
1354        (%date-jday dat) ) ) ) )
1355
1356;;; Setters
1357
1358(define-syntax tm:date-nanosecond-set!
1359        (syntax-rules ()
1360                ((_ ?dat ?x)
1361                  (let ((dat ?dat) (x ?x))
1362        (%date-nanosecond-set! dat (number->genint x)) ) ) ) )
1363
1364(define-syntax tm:date-second-set!
1365        (syntax-rules ()
1366                ((_ ?dat ?x)
1367                  (let ((dat ?dat) (x ?x))
1368        (%date-second-set! dat (number->genint x)) ) ) ) )
1369
1370(define-syntax tm:date-minute-set!
1371        (syntax-rules ()
1372                ((_ ?dat ?x)
1373                  (let ((dat ?dat) (x ?x))
1374        (%date-minute-set! dat (number->genint x)) ) ) ) )
1375
1376(define-syntax tm:date-hour-set!
1377        (syntax-rules ()
1378                ((_ ?dat ?x)
1379                  (let ((dat ?dat) (x ?x))
1380        (%date-hour-set! dat (number->genint x)) ) ) ) )
1381
1382(define-syntax tm:date-day-set!
1383        (syntax-rules ()
1384                ((_ ?dat ?x)
1385                  (let ((dat ?dat) (x ?x))
1386        (%date-day-set! dat (number->genint x)) ) ) ) )
1387
1388(define-syntax tm:date-month-set!
1389        (syntax-rules ()
1390                ((_ ?dat ?x)
1391                  (let ((dat ?dat) (x ?x))
1392        (%date-month-set! dat (number->genint x)) ) ) ) )
1393
1394(define-syntax tm:date-year-set!
1395        (syntax-rules ()
1396                ((_ ?dat ?x)
1397                  (let ((dat ?dat) (x ?x))
1398        (%date-year-set! dat (number->genint x)) ) ) ) )
1399
1400(define-syntax tm:date-zone-offset-set!
1401        (syntax-rules ()
1402                ((_ ?dat ?x)
1403                  (let ((dat ?dat) (x ?x))
1404        (%date-zone-offset-set! dat (number->genint x)) ) ) ) )
1405
1406;; Date TZ information extract
1407
1408;Belongs in srfi-19-timezone
1409
1410#;
1411(define-record-type-variant date-timezone-info (unchecked inline unsafe)
1412  (%make-date-timezone-info n o d)
1413  %date-timezone-info?
1414  (n %date-timezone-info-name)
1415  (o %date-timezone-info-offset)
1416  (d %date-timezone-info-dst?) )
1417
1418(define-record-type date-timezone-info
1419  (%make-date-timezone-info n o d)
1420  %date-timezone-info?
1421  (n %date-timezone-info-name)
1422  (o %date-timezone-info-offset)
1423  (d %date-timezone-info-dst?) )
1424
1425(define-syntax tm:date-timezone-info
1426        (syntax-rules ()
1427                ((_ ?dat)
1428                  (let ((dat ?dat))
1429        #;(make-timezone-locale (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat))
1430        (%make-date-timezone-info
1431          (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) ) ) ) )
1432
1433;; Returns an invalid date record (for use by 'scan-date')
1434
1435(define-syntax tm:make-incomplete-date
1436        (syntax-rules ()
1437                ((_)
1438      (%make-date
1439        0
1440        0 0 0
1441        #f #f #f
1442        (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
1443        #f #f #f) ) ) )
1444
1445;; Internal Date CTOR
1446
1447(define-syntax tm:make-date
1448        (syntax-rules ()
1449                ((_ ?ns ?sec ?min ?hr ?dy ?mn ?yr ?tzo ?tzn ?dstf ?wdy ?ydy ?jdy)
1450                  (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))
1451        (%make-date
1452          (number->genint ns)
1453          (number->genint sec) (number->genint min) (number->genint hr)
1454          (number->genint dy) (number->genint mn) (number->genint yr)
1455          (number->genint tzo) tzn dstf
1456          wdy ydy jdy) ) ) ) )
1457
1458(define-syntax tm:copy-date
1459        (syntax-rules ()
1460                ((_ ?dat)
1461                  (let ((dat ?dat))
1462        (%make-date
1463          (%date-nanosecond dat)
1464          (%date-second dat) (%date-minute dat) (%date-hour dat)
1465          (%date-day dat) (%date-month dat) (%date-year dat)
1466          (%date-zone-offset dat)
1467          (%date-zone-name dat) (%date-dst? dat)
1468          (%date-wday dat) (%date-yday dat) (%date-jday dat)) ) ) ) )
1469
1470(define (tm:seconds->date/type sec tzc)
1471  (let* ((fsec (exact->inexact sec))
1472           (isec (floor fsec))
1473           (tzo (timezone-locale-offset tzc))
1474           (tv (seconds->utc-time (+ isec tzo))))
1475      (tm:make-date
1476        (round (* (- fsec isec) NS/S))
1477        (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
1478        (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
1479        tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
1480        (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )
1481
1482(define-syntax tm:current-date
1483        (syntax-rules ()
1484                ((_ ?tzi) (let ((tzi ?tzi)) (tm:time-utc->date (tm:current-time-utc) tzi)) ) ) )
1485
1486;; Date Comparison
1487
1488(define-syntax tm:date-compare
1489        (syntax-rules ()
1490                ((_ ?dat1 ?dat2)
1491                  (let ((dat1 ?dat1) (dat2 ?dat2))
1492        (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
1493          (if (not (fxzero? dif))
1494            dif
1495            (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
1496              (if (not (fxzero? dif))
1497                dif
1498                (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
1499                  (if (not (fxzero? dif))
1500                    dif
1501                    (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
1502                      (if (not (fxzero? dif))
1503                        dif
1504                        (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
1505                          (if (not (fxzero? dif))
1506                            dif
1507                            (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
1508                              (if (not (fxzero? dif))
1509                                dif
1510                                (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
1511
1512;; Gives the seconds/day/month/year
1513
1514#; ;Original
1515(define (tm:decode-julian-day-number jdn)
1516  (let* ((days (floor jdn))
1517         (a (+ days 32044))
1518         (b (quotient (+ (* 4 a) 3) 146097))
1519         (c (- a (quotient (* 146097 b) 4)))
1520         (d (quotient (+ (* 4 c) 3) 1461))
1521         (e (- c (quotient (* 1461 d) 4)))
1522         (m (quotient (+ (* 5 e) 2) 153))
1523         (y (+ (* 100 b) d -4800 (quotient m 10))))
1524    (values ; seconds date month year
1525     (* (- jdn days) tm:sid)
1526     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
1527     (+ m 3 (* -12 (quotient m 10)))
1528     (if (>= 0 y) (- y 1) y)) ) )
1529
1530(define (tm:decode-julian-day-number jdn)
1531  (let* ((dys (number->genint (floor jdn)))
1532         (a (fx+ dys 32044))
1533         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
1534         (c (fx- a (fx/ (fx* 146097 b) 4)))
1535         (d (fx/ (fx+ (fx* 4 c) 3) 1461))
1536         (e (fx- c (fx/ (fx* 1461 d) 4)))
1537         (m (fx/ (fx+ (fx* 5 e) 2) 153))
1538         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
1539    (values ; seconds date month year
1540      (number->genint (floor (* (- jdn dys) SEC/DY)))
1541      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
1542      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
1543      (if (fx<= y 0) (fx- y 1) y)) ) )
1544
1545;; Gives the Julian day number - rounds up to the nearest day
1546
1547(define (tm:seconds->julian-day-number sec tzo)
1548  (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
1549
1550;; Is the time object one second before a leap second?
1551
1552(define (tm:tai-before-leap-second? tim)
1553  (let ((sec (%time-second tim)))
1554    (let loop ((ls tm:second-before-leap-second-table))
1555      (and
1556        (not (null? ls))
1557        (or
1558          (= sec (car ls))
1559          (loop (cdr ls)) ) ) ) ) )
1560
1561(define (tm:time-utc->date tim tzi)
1562  (let ((tzo tzi) ;assume an offset
1563        (tzn #f)
1564        (dstf #f))
1565      (cond
1566        ((%date-timezone-info? tzi)
1567          (set! dstf (%date-timezone-info-dst? tzi))
1568          (set! tzn (%date-timezone-info-name tzi))
1569          (set! tzo (%date-timezone-info-offset tzi)) )
1570        ((timezone-components? tzi)
1571          (set! dstf (timezone-locale-dst? tzi))
1572          (set! tzn (timezone-locale-name tzi))
1573          (set! tzo (timezone-locale-offset tzi)) ) )
1574    (let-values (((secs dy mn yr)
1575                    (tm:decode-julian-day-number
1576                      (tm:seconds->julian-day-number (%time-second tim) tzo))) )
1577      (let ((hr (fx/ secs SEC/HR))
1578            (rem (fxmod secs SEC/HR)))
1579        (let ((min (fx/ rem SEC/MIN))
1580              (sec (fxmod rem SEC/MIN)))
1581          (tm:make-date
1582            (%time-nanosecond tim)
1583            sec min hr
1584            dy mn yr
1585            tzo tzn dstf
1586            #f #f #f) ) ) ) ) )
1587
1588(define (tm:time-tai->date tim tzi)
1589  (let ((tm-utc (tm:time-tai->time-utc tim (tm:any-time))))
1590    (if (not (tm:tai-before-leap-second? tim))
1591      (tm:time-utc->date tm-utc tzi)
1592      ; else time is *right* before the leap, we need to pretend to subtract a second ...
1593      (let ((dat (tm:time-utc->date (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
1594        (%date-second-set! dat SEC/MIN) ; Note full minute!
1595        dat ) ) ) )
1596
1597(define (tm:time->date tim tzi)
1598  (case (%time-type tim)
1599    ((utc)       (tm:time-utc->date tim tzi))
1600    ((tai)       (tm:time-tai->date tim tzi))
1601    ((monotonic) (tm:time-utc->date tim tzi))
1602    (else        #f)) )
1603
1604;; Date to Time
1605
1606;; Gives the Julian day number - Gregorian proleptic calendar
1607
1608(define (tm:encode-julian-day-number dy mn yr)
1609  (let* ((a (fx/ (fx- 14 mn) MN/YR))
1610         (b (fx- (fx+ yr JDYR) a))
1611         (y (if (fx< yr 0) (fx+ b 1) b)) ; BCE?
1612         (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
1613    (+
1614      dy
1615     (fx/ (fx+ (fx* 153 m) 2) 5)
1616     (fx* y DY/YR)
1617     (fx/ y 4)
1618     (fx/ y -100)
1619     (fx/ y 400)
1620     -32045) ) )
1621
1622(define (tm:date->time-utc dat)
1623  (let ((ns (%date-nanosecond dat))
1624        (sec (%date-second dat))
1625        (min (%date-minute dat))
1626        (hr (%date-hour dat))
1627        (dy (%date-day dat))
1628        (mn (%date-month dat))
1629        (yr (%date-year dat))
1630        (tzo (%date-zone-offset dat)) )
1631    (let ((jdys
1632            (-
1633              (tm:encode-julian-day-number dy mn yr)
1634              TAI-EPOCH-IN-JD))
1635          (secs
1636            (fx+
1637              (fx+
1638                (fx* hr SEC/HR)
1639                (fx+
1640                  (fx* min SEC/MIN)
1641                  sec))
1642              (fxneg tzo))) )
1643      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
1644
1645(define (tm:date->time-tai dat)
1646  (let* ((tm-utc (tm:date->time-utc dat))
1647         (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
1648    (if (not (fx= SEC/MIN (%date-second dat)))
1649      tm-tai
1650      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
1651
1652(define (tm:date->time-monotonic dat)
1653  (let ((tim-utc (tm:date->time-utc dat)))
1654    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
1655
1656(define (tm:date->time dat tt)
1657  (case tt
1658    ((utc)        (tm:date->time-utc dat))
1659    ((tai)        (tm:date->time-tai dat))
1660    ((monotonic)  (tm:date->time-monotonic dat))
1661    (else         #f) ) )
1662
1663;; Given a 'two digit' number, find the year within 50 years +/-
1664
1665(define (tm:natural-year n tzi)
1666  (if (or (fx< n 0) (fx>= n 100))
1667    n
1668    (let* ((current-year (%date-year (tm:current-date tzi)))
1669           (current-century (fx* (fx/ current-year 100) 100)))
1670      (if (fx<= (fx- (fx+ current-century n) current-year) 50)
1671        (fx+ current-century n)
1672        (fx+ (fx- current-century 100) n) ) ) ) )
1673
1674;; Day of Year
1675
1676(define +cumulative-month-days+ '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
1677
1678(define (tm:year-day dy mn yr)
1679  (let ((yrdy (fx+ dy (vector-ref +cumulative-month-days+ mn))))
1680    (if (and (tm:leap-year? yr) (fx< 2 mn))
1681      (fx+ yrdy 1)
1682      yrdy ) ) )
1683
1684(define (tm:cache-date-year-day dat)
1685  (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
1686    (%date-yday-set! dat yrdy)
1687    yrdy ) )
1688
1689(define (tm:date-year-day dat)
1690  (or
1691    (%date-yday dat)
1692    (tm:cache-date-year-day dat) ) )
1693
1694;; Week Day
1695
1696(define (week-day? obj)
1697  (and (fixnum? obj) (fx<= 0 obj) (fx<= obj 6)) )
1698
1699(define-check+error-type week-day)
1700
1701;; Using Gregorian Calendar (from Calendar FAQ)
1702
1703(define (tm:week-day dy mn yr)
1704  (let* ((a (fx/ (fx- 14 mn) MN/YR))
1705         (y (fx- yr a))
1706         (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
1707    (fxmod
1708      (fx+
1709        (fx+ dy y)
1710        (fx+
1711          (fx-
1712            (fx/ y 4)
1713            (fx/ y 100))
1714          (fx+
1715            (fx/ y 400)
1716            (fx/ (fx* m DY/MN) MN/YR))))
1717      DY/WK) ) )
1718
1719(define (tm:cache-date-week-day dat)
1720  (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
1721    (%date-wday-set! dat wdy)
1722    wdy ) )
1723
1724(define (tm:date-week-day dat)
1725  (or
1726    (%date-wday dat)
1727    (tm:cache-date-week-day dat) ) )
1728
1729(define (tm:days-before-first-week dat 1st-weekday)
1730  (fxmod (fx- 1st-weekday (tm:week-day 1 1 (%date-year dat))) DY/WK) )
1731
1732(define (tm:date-week-number dat 1st-weekday)
1733  (fx/
1734    (fx- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
1735    DY/WK) )
1736
1737;; Julian-day Operations
1738
1739(define (julian-day? obj) (real? obj))
1740
1741(define-check+error-type julian-day)
1742
1743(define (tm:julian-day->modified-julian-day mjdn)
1744  (- mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1745
1746;; Date to Julian-day
1747
1748; Does the nanoseconds value contribute anything to the julian day?
1749; The range is < 1 second here (but not in the reference).
1750
1751(define (tm:julian-day ns sec min hr dy mn yr tzo)
1752  (let ((jdn
1753          (tm:encode-julian-day-number dy mn yr))
1754        (time-seconds
1755          (+
1756            (fx+
1757              (fx+
1758                (fx* hr SEC/HR)
1759                (fx+ (fx* min SEC/MIN) sec))
1760              (fxneg tzo))
1761              (/ ns NS/S))) )
1762    (+ (- jdn ONE-HALF) (/ time-seconds SEC/DY)) ) )
1763
1764#; ; inexact version
1765(define (tm:julian-day ns sec min hr dy mn yr tzo)
1766  (let ((time-seconds
1767          (fx+
1768            (fx+
1769              (fx* hr SEC/HR)
1770              (fx+ (fx* min SEC/MIN) sec))
1771              (fxneg tzo)) ) )
1772    (fp+
1773      (fp-
1774        (exact->inexact (tm:encode-julian-day-number dy mn yr))
1775        (exact->inexact ONE-HALF))
1776      (fp/
1777        (fp+
1778          (exact->inexact time-seconds)
1779          (fp/ (exact->inexact ns) (exact->inexact NS/S)))
1780        (exact->inexact SEC/DY))) ) )
1781
1782(define-syntax tm:date->julian-day
1783        (syntax-rules ()
1784                ((_ ?dat)
1785                  (let ((dat ?dat))
1786        (or
1787          (%date-jday dat)
1788          (let ((jdn
1789                 (tm:julian-day
1790                  (%date-nanosecond dat)
1791                  (%date-second dat) (%date-minute dat) (%date-hour dat)
1792                  (%date-day dat) (%date-month dat) (%date-year dat)
1793                  (%date-zone-offset dat))))
1794            (%date-jday-set! dat jdn)
1795            jdn ) ) ) ) ) )
1796
1797;; Time to Julian-day
1798
1799(define (tm:seconds->julian-day ns sec)
1800  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
1801
1802(define (tm:time-utc->julian-day tim)
1803  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
1804
1805(define (tm:time-tai->julian-day tim)
1806  (let ((sec (%time-second tim)))
1807    (tm:seconds->julian-day
1808      (%time-nanosecond tim)
1809      (- sec (leap-second-delta sec))) ) )
1810
1811(define tm:time-monotonic->julian-day tm:time-tai->julian-day)
1812
1813(define (tm:time->julian-day tim)
1814  (case (%time-type tim)
1815    ((utc)       (tm:time-utc->julian-day tim))
1816    ((tai)       (tm:time-tai->julian-day tim))
1817    ((monotonic) (tm:time-monotonic->julian-day tim))
1818    (else        #f)) )
1819
1820(define (tm:time-utc->modified-julian-day tim)
1821  (tm:julian-day->modified-julian-day (tm:time-utc->julian-day tim)) )
1822
1823(define (tm:time-tai->modified-julian-day tim)
1824  (tm:julian-day->modified-julian-day (tm:time-tai->julian-day tim)) )
1825
1826(define (tm:time-monotonic->modified-julian-day tim)
1827  (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )
1828
1829(define (tm:time->modified-julian-day tim)
1830  (case (%time-type tim)
1831    ((utc)       (tm:time-utc->modified-julian-day tim))
1832    ((tai)       (tm:time-tai->modified-julian-day tim))
1833    ((monotonic) (tm:time-monotonic->modified-julian-day tim))
1834    (else        #f)) )
1835
1836;; Julian-day to Time
1837
1838(define (tm:julian-day->nanoseconds jdn)
1839  (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S) )
1840
1841(define (tm:julian-day->time-values jdn)
1842  (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)) )
1843
1844(define (tm:modified-julian-day->julian-day mjdn)
1845  (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) )
1846
1847(define-syntax tm:julian-day->time-utc
1848        (syntax-rules ()
1849                ((_ ?jdn)
1850                  (let ((jdn ?jdn))
1851        (let-values (((ns sec) (tm:julian-day->time-values jdn)))
1852          (tm:make-time 'time-utc ns sec) ) ) ) ) )
1853
1854(define (tm:default-date-adjust-integer amt)
1855  (round amt) )
1856
1857) ;module srfi-19-support
Note: See TracBrowser for help on using the repository browser.