source: project/release/4/srfi-19/trunk/srfi-19-core.scm @ 15751

Last change on this file since 15751 was 15751, checked in by Kon Lovett, 10 years ago

Save

File size: 25.2 KB
Line 
1;;;; srfi-19-core.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(module srfi-19-core (;export
31  ; SRFI-19
32  time-tai
33  time-utc
34  time-monotonic
35  time-thread
36  time-process
37  time-duration
38  time-gc
39  current-date
40  current-julian-day
41  current-modified-julian-day
42  current-time
43  time-resolution
44  make-time
45  time-type
46  time-nanosecond
47  time-second
48  set-time-type!
49  set-time-nanosecond!
50  set-time-second!
51  copy-time
52  time<=?
53  time<?
54  time=?
55  time>=?
56  time>?
57  time-difference
58  time-difference!
59  add-duration
60  add-duration!
61  subtract-duration
62  subtract-duration!
63  make-date
64  date?
65  date-nanosecond
66  date-second
67  date-minute
68  date-hour
69  date-day
70  date-month
71  date-year
72  date-zone-offset
73  leap-year? ; Actually part of SRFI 19 but not in original document
74  date-year-day
75  days-in-month/year
76  natural-year
77  date-week-day
78  date-week-number
79  date->julian-day
80  date->modified-julian-day
81  date->time-monotonic
82  date->time-tai
83  date->time-utc
84  julian-day->date
85  julian-day->time-monotonic
86  julian-day->time-tai
87  julian-day->time-utc
88  modified-julian-day->date
89  modified-julian-day->time-monotonic
90  modified-julian-day->time-tai
91  modified-julian-day->time-utc
92  time-monotonic->date
93  time-monotonic->julian-day
94  time-monotonic->modified-julian-day
95  time-monotonic->time-tai
96  time-monotonic->time-tai!
97  time-monotonic->time-utc
98  time-monotonic->time-utc!
99  time-tai->date
100  time-tai->julian-day
101  time-tai->modified-julian-day
102  time-tai->time-monotonic
103  time-tai->time-monotonic!
104  time-tai->time-utc
105  time-tai->time-utc!
106  time-utc->date
107  time-utc->julian-day
108  time-utc->modified-julian-day
109  time-utc->time-monotonic
110  time-utc->time-monotonic!
111  time-utc->time-tai
112  time-utc->time-tai!
113  ; Extensions
114  one-second-duration
115  one-nanosecond-duration
116  zero-time
117  time-type?
118  make-duration
119  divide-duration
120  divide-duration!
121  multiply-duration
122  multiply-duration!
123  time->srfi-18-time
124  srfi-18-time->time
125  time-max
126  time-min
127  time-negative?
128  time-positive?
129  time-zero?
130  time-abs
131  time-abs!
132  time-negate
133  time-negate!
134  seconds->time/type
135  seconds->date/type
136  time->nanoseconds
137  nanoseconds->time
138  nanoseconds->seconds
139  read-leap-second-table
140  time->milliseconds
141  milliseconds->time
142  milliseconds->seconds
143  time->date
144  timezone-locale-name
145  timezone-locale-offset
146  timezone-locale-dst?
147  local-timezone-locale
148  utc-timezone-locale
149  default-date-clock-type
150  date-zone-name
151  date-dst?
152  copy-date
153  date->time
154  date-difference
155  date-add-duration
156  date-subtract-duration
157  date=?
158  date>?
159  date<?
160  date>=?
161  date<=?
162  date-max
163  date-min
164  time->julian-day
165  time->modified-julian-day
166  date-compare
167  time-compare)
168
169  (import (except scheme zero? negative? positive? real?)
170          chicken
171          #;srfi-8
172          (only srfi-18 seconds->time time->seconds)
173          (rename srfi-18 (seconds->time srfi-18:seconds->time) (time->seconds srfi-18:time->seconds))
174          (only numbers zero? negative? positive? real?)
175          miscmacros
176          (only locale-components check-timezone-components timezone-components?)
177          type-checks
178          type-errors
179          srfi-19-timezone
180          srfi-19-support)
181
182  (require-library #;srfi-8 srfi-18 numbers miscmacros locale-components
183                   type-checks type-errors
184                   srfi-19-timezone srfi-19-support)
185
186;;;
187
188(define (check-real loc obj #!optional argnam)
189  (unless (real? obj)
190    (error-argument-type loc "real number" argnam) ) )
191
192(define (check-raw-seconds loc obj) (check-real loc obj 'seconds))
193
194(define (check-raw-milliseconds loc obj) (check-real loc obj 'milliseconds))
195
196;;
197
198;;
199
200(define (read-leap-second-table flnm)
201  (check-string 'read-leap-second-table flnm) ;FIXME should be check-pathname
202  (tm:read-leap-second-table flnm) )
203
204;; Time Type Constants (not used internally)
205
206(define time-duration   'duration)
207(define time-gc         'gc)
208(define time-monotonic  'monotonic)
209(define time-process    'process)
210(define time-tai        'tai)
211(define time-thread     'thread)
212(define time-utc        'utc)
213
214;; Time CTORs
215
216(define (one-second-duration) (tm:make-time 'duration 0 1))
217(define (one-nanosecond-duration) (tm:make-time 'duration 1 0))
218(define (zero-time tt) (check-time-type 'zero-time tt) (tm:make-time tt 0 0))
219
220(define (make-time tt ns sec)
221  (check-time-elements 'make-time tt ns sec)
222  (tm:make-time tt ns sec) )
223
224(define (make-duration
225          #!key (days 0)
226                (hours 0) (minutes 0) (seconds 0)
227                (milliseconds 0) (microseconds 0) (nanoseconds 0))
228  (check-real 'make-duration days "days")
229  (check-real 'make-duration hours "hours")
230  (check-real 'make-duration minutes "minutes")
231  (check-real 'make-duration seconds "seconds")
232  (check-real 'make-duration milliseconds "milliseconds")
233  (check-real 'make-duration microseconds "microseconds")
234  (check-real 'make-duration nanoseconds "nanoseconds")
235  (receive (ns sec)
236      (tm:duration-elements->time-values days hours minutes seconds
237                                         milliseconds microseconds nanoseconds)
238    (check-time-elements 'make-duration 'duration ns sec)
239    (tm:make-time 'duration ns sec) ) )
240
241(define (copy-time tim)
242  (check-time 'copy-time tim)
243  (tm:copy-time tim) )
244
245;; Converts a seconds value, may be fractional, into a time type.
246;; The type of time default is time-duration.
247
248(define (seconds->time/type sec . args)
249  (check-raw-seconds 'seconds->time/type sec)
250  (let-optionals args ((tt 'duration))
251    (check-time-type 'seconds->time/type tt)
252    (tm:seconds->time sec tt) ) )
253
254;; Time record-type operations
255
256(define (time-type tim)
257  (check-time 'time-type tim)
258  (tm:time-type tim) )
259
260(define (time-nanosecond tim)
261  (check-time 'time-nanosecond tim)
262  (tm:time-nanosecond tim) )
263
264(define (time-second tim)
265  (check-time 'time-second tim)
266  (tm:time-second tim) )
267
268(define (set-time-type! tim tt)
269  (check-time 'set-time-type! tim)
270  (check-time-type 'set-time-type! tt)
271  (tm:time-type-set! tim tt) )
272
273(define (set-time-nanosecond! tim ns)
274  (check-time 'set-time-nanosecond! tim)
275  (check-time-nanoseconds 'set-time-nanosecond! ns)
276  (tm:time-nanosecond-set! tim ns) )
277
278(define (set-time-second! tim sec)
279  (check-time 'set-time-second! tim)
280  (check-time-seconds 'set-time-second! sec)
281  (tm:time-second-set! tim sec) )
282
283;; Seconds Conversion
284
285(define (nanoseconds->time ns . args)
286  (let-optionals args ((tt 'duration))
287    (receive (ns sec)
288        (tm:nanoseconds->time-values ns)
289      (check-time-elements 'nanoseconds->time tt ns sec)
290      (tm:make-time tt ns sec) ) ) )
291
292(define (nanoseconds->seconds ns)
293  #;(check-real 'nanoseconds->seconds ns)
294  (tm:nanoseconds->seconds ns) )
295
296(define (milliseconds->time ms . args)
297  (check-raw-milliseconds 'milliseconds->time ms)
298  (let-optionals args ((tt 'duration))
299    (receive (ns sec)
300        (tm:milliseconds->time-values ms)
301      (check-time-elements 'milliseconds->time tt ns sec)
302      (tm:make-time tt ns sec) ) ) )
303
304(define (milliseconds->seconds ms)
305  (check-raw-milliseconds 'milliseconds->seconds ms)
306  (tm:milliseconds->seconds ms) )
307
308(define (time->nanoseconds tim)
309  (check-time 'time->nanoseconds tim)
310  (tm:time->nanoseconds tim) )
311
312(define (time->milliseconds tim)
313  (check-time 'time->milliseconds tim)
314  (tm:time->milliseconds tim) )
315
316(define (time->seconds tim)
317  (check-time 'time->seconds tim)
318  (tm:time->seconds tim) )
319
320;; Current time routines
321
322(define (current-time . args)
323  (let-optionals args ((tt 'utc))
324    (case tt
325      ((monotonic) (tm:current-time-monotonic))
326      ((utc)       (tm:current-time-utc))
327      ((tai)       (tm:current-time-tai))
328      ((gc)        (tm:current-time-gc))
329      ((process)   (tm:current-time-process))
330      ((thread)    (tm:current-time-thread))
331      (else
332        (error-time-type 'current-time tt)) ) ) )
333
334;; -- Time Resolution
335;; This is the resolution of the clock in nanoseconds.
336;; This will be implementation specific.
337
338(define (time-resolution . args)
339  (let-optionals args ((tt 'utc))
340    (check-time-type 'time-resolution tt)
341    (tm:time-resolution tt) ) )
342
343;; SRFI-18 Routines
344
345(define (srfi-18-time->time srfi-18-tim)
346  (seconds->time/type (srfi-18:time->seconds srfi-18-tim) 'duration) )
347
348(define (time->srfi-18-time tim)
349  (check-time 'time->srfi-18-time tim)
350  (srfi-18:seconds->time (tm:time->seconds tim)) )
351
352;; Time Comparison
353
354(define (time-compare tim1 tim2)
355  (check-time-compare 'time-compare tim1 tim2)
356  (let ((dif (tm:time-compare tim1 tim2)))
357    (cond ((negative? dif)  -1)
358          ((positive? dif)  1)
359          (else             0) ) ) )
360
361(define (time=? tim1 tim2)
362  (check-time-compare 'time=? tim1 tim2)
363  (tm:time=? tim1 tim2) )
364
365(define (time>? tim1 tim2)
366  (check-time-compare 'time>? tim1 tim2)
367  (tm:time>? tim1 tim2) )
368
369(define (time<? tim1 tim2)
370  (check-time-compare 'time<? tim1 tim2)
371  (tm:time<? tim1 tim2) )
372
373(define (time>=? tim1 tim2)
374  (check-time-compare 'time>=? tim1 tim2)
375  (tm:time>=? tim1 tim2) )
376
377(define (time<=? tim1 tim2)
378  (check-time-compare 'time<=? tim1 tim2)
379  (tm:time<=? tim1 tim2) )
380
381(define (time-max tim1 . rest)
382  (check-time 'time-max tim1)
383  (let ((tt (tm:time-type tim1)))
384    (let loop ((acc tim1) (ls rest))
385      (if (null? ls) acc
386          (let ((tim (car ls)))
387            (check-time-and-type 'time-max tim tt)
388            (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
389
390(define (time-min tim1 . rest)
391  (check-time 'time-min tim1)
392  (let ((tt (tm:time-type tim1)))
393    (let loop ((acc tim1) (ls rest))
394      (if (null? ls) acc
395          (let ((tim (car ls)))
396            (check-time-and-type 'time-min tim tt)
397            (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
398
399;; Time Arithmetic
400
401(define (time-difference tim1 tim2)
402  (check-time-compare 'time-difference tim1 tim2)
403  (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )
404
405(define (add-duration tim dur)
406  (check-time-aritmetic 'add-duration tim dur)
407  (tm:add-duration tim dur (tm:as-some-time tim)) )
408
409(define (subtract-duration tim dur)
410  (check-time-aritmetic 'subtract-duration tim dur)
411  (tm:subtract-duration tim dur (tm:as-some-time tim)) )
412
413(define (divide-duration dur num)
414  (check-duration 'divide-duration dur)
415  (tm:divide-duration dur num (tm:some-time 'duration)) )
416
417(define (multiply-duration dur num)
418  (check-duration 'multiply-duration dur)
419  (tm:multiply-duration dur num (tm:some-time 'duration)) )
420
421(define (time-abs tim)
422  (check-time 'time-abs tim)
423  (tm:time-abs tim (tm:as-some-time tim)) )
424
425(define (time-negate tim)
426  (check-time 'time-negate tim)
427  (tm:time-negate tim (tm:as-some-time tim)) )
428
429;;
430
431(define (time-difference! tim1 tim2)
432  (check-time-compare 'time-difference! tim1 tim2)
433  (tm:time-difference tim1 tim2 tim1) )
434
435(define (add-duration! tim dur)
436  (check-time-aritmetic 'add-duration! tim dur)
437  (tm:add-duration tim dur tim) )
438
439(define (subtract-duration! tim dur)
440  (check-time-aritmetic 'subtract-duration! tim dur)
441  (tm:subtract-duration tim dur tim) )
442
443(define (divide-duration! dur num)
444  (check-duration 'divide-duration! dur)
445  (tm:divide-duration dur num dur) )
446
447(define (multiply-duration! dur num)
448  (check-duration 'multiply-duration! dur)
449  (tm:multiply-duration dur num dur) )
450
451(define (time-abs! tim)
452  (check-time 'time-abs! tim)
453  (tm:time-abs tim tim) )
454
455(define (time-negate! tim)
456  (check-time 'time-negate! tim)
457  (tm:time-negate tim tim) )
458
459;;
460
461(define (time-negative? tim)
462  (check-time 'time-negative? tim)
463  ;nanoseconds irrelevant
464  (negative? (tm:time-second tim)) )
465
466(define (time-positive? tim)
467  (check-time 'time-positive? tim)
468  ;nanoseconds irrelevant
469  (positive? (tm:time-second tim)) )
470
471(define (time-zero? tim)
472  (check-time 'time-zero? tim)
473  (and (zero? (tm:time-nanosecond tim))
474       (zero? (tm:time-second tim))) )
475
476;; Time Type Conversion
477
478;;
479
480(define (time-tai->time-utc tim)
481  (check-time-and-type 'time-tai->time-utc tim 'tai)
482  (tm:time-tai->time-utc tim (tm:any-time)) )
483
484(define (time-tai->time-monotonic tim)
485  (check-time-and-type 'time-tai->time-monotonic tim 'tai)
486  (tm:time-tai->time-monotonic tim (tm:any-time)) )
487
488(define (time-utc->time-tai tim)
489  (check-time-and-type 'time-utc->time-tai tim 'utc)
490  (tm:time-utc->time-tai tim (tm:any-time)) )
491
492(define (time-utc->time-monotonic tim)
493  (check-time-and-type 'time-utc->time-monotonic tim 'utc)
494  (tm:time-utc->time-monotonic tim (tm:any-time)) )
495
496(define (time-monotonic->time-utc tim)
497  (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
498  (let ((ntim (tm:copy-time tim)))
499    (tm:time-monotonic->time-utc ntim ntim) ) )
500
501(define (time-monotonic->time-tai tim)
502  (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
503  (tm:time-monotonic->time-tai tim (tm:any-time)) )
504
505;;
506
507(define (time-tai->time-utc! tim)
508  (check-time-and-type 'time-tai->time-utc! tim 'tai)
509  (tm:time-tai->time-utc tim tim) )
510
511(define (time-tai->time-monotonic! tim)
512  (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
513  (tm:time-tai->time-monotonic tim tim) )
514
515(define (time-utc->time-tai! tim)
516  (check-time-and-type 'time-utc->time-tai! tim 'utc)
517  (tm:time-utc->time-tai tim tim) )
518
519(define (time-utc->time-monotonic! tim)
520  (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
521  (tm:time-utc->time-monotonic tim tim) )
522
523(define (time-monotonic->time-utc! tim)
524  (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
525  (tm:time-monotonic->time-utc tim tim) )
526
527(define (time-monotonic->time-tai! tim)
528  (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
529  (tm:time-monotonic->time-tai tim tim) )
530
531
532;;; Date Object (Public Immutable)
533
534;;
535
536(define-parameter default-date-clock-type 'utc
537  (lambda (obj)
538    (cond ((clock-type? obj) obj)
539          (else
540           (warning-argument-type 'default-date-clock-type obj 'clock-type)
541           (default-date-clock-type) ) ) ) )
542
543;; Date CTOR
544
545(define (make-date ns sec min hr dy mn yr tzo . args)
546  (let-optionals args ((tzn #f) (dstf (void)))
547    (cond ((timezone-components? tzo)
548           ; Supplied parameters override
549           (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
550           (set! tzn (or tzn (timezone-locale-name tzo)))
551           (set! tzo (timezone-locale-offset tzo)) )
552          (else
553           (when (eq? (void) dstf) (set! dstf #f)) ) )
554    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
555    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
556
557(define (copy-date dat)
558  (check-date 'copy-date dat)
559  (tm:copy-date dat) )
560
561;; Converts a seconds value, may be fractional, into a date type.
562;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
563;; A local (#t), utc (#f), or other (timezone-components) date depending on
564;; the optional 2nd argument. The default is #f.
565
566(define (seconds->date/type sec . tzi)
567  (check-raw-seconds 'seconds->date/type sec)
568  (let ((tzc (checked-optional-timezone-info 'seconds->date/type (optional tzi #t))))
569    (check-timezone-components 'seconds->date/type tzc)
570    (tm:seconds->date/type sec tzc) ) )
571
572(define (current-date . tzi)
573  (tm:current-date (checked-optional-timezone-info 'current-date (optional tzi #t))) )
574
575;;
576
577(define (date-nanosecond dat)
578        (check-date 'date-nanosecond dat)
579        (tm:date-nanosecond dat) )
580
581(define (date-second dat)
582        (check-date 'date-second dat)
583        (tm:date-second dat) )
584
585(define (date-minute dat)
586        (check-date 'date-minute dat)
587        (tm:date-minute dat) )
588
589(define (date-hour dat)
590        (check-date 'date-hour dat)
591        (tm:date-hour dat) )
592
593(define (date-day dat)
594        (check-date 'date-day dat)
595        (tm:date-day dat) )
596
597(define (date-month dat)
598        (check-date 'date-month dat)
599        (tm:date-month dat) )
600
601(define (date-year dat)
602        (check-date 'date-year dat)
603        (tm:date-year dat) )
604
605(define (date-dst? dat)
606        (check-date 'date-dst? dat)
607        (tm:date-dst? dat) )
608
609(define (date-zone-offset dat)
610        (check-date 'date-zone-offset dat)
611        (tm:date-zone-offset dat) )
612
613(define (date-zone-name dat)
614        (check-date 'date-zone-name dat)
615        (tm:date-zone-name dat) )
616
617;; Date Comparison
618
619(define (checked-date-compare loc dat1 dat2)
620  (check-date loc dat1)
621  (check-date loc dat2)
622  (check-date-compatible-timezone-offsets loc dat1 dat2)
623  (tm:date-compare dat1 dat2) )
624
625;;
626
627(define (date-compare dat1 dat2)
628  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
629    (cond ((fx> 0 dif)  -1)
630          ((fx< 0 dif)  1)
631          (else         0) ) ) )
632
633(define (date=? dat1 dat2)
634  (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
635
636(define (date<? dat1 dat2)
637  (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
638
639(define (date<=? dat1 dat2)
640  (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
641
642(define (date>? dat1 dat2)
643  (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
644
645(define (date>=? dat1 dat2)
646  (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
647
648(define (date-max dat1 . rest)
649  (check-date 'date-max dat1)
650  (let loop ((acc dat1) (ls rest))
651    (if (null? ls) acc
652        (let ((dat (car ls)))
653          (check-date 'date-max dat)
654          (check-date-compatible-timezone-offsets 'date-max acc dat)
655          (loop (if (fx> 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
656
657(define (date-min dat1 . rest)
658  (check-date 'date-min dat1)
659  (let loop ((acc dat1) (ls rest))
660    (if (null? ls) acc
661        (let ((dat (car ls)))
662          (check-date 'date-min dat)
663          (check-date-compatible-timezone-offsets 'date-min acc dat)
664          (loop (if (fx< 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
665
666;; Date Arithmetic
667
668(define (date-difference dat1 dat2 . args)
669  (check-date 'date-difference dat1)
670  (check-date 'date-difference dat2)
671  (let-optionals args ((tt (default-date-clock-type)))
672    (let ((tim1 (tm:date->time dat1 tt))
673          (tim2 (tm:date->time dat2 tt)) )
674      (unless tim1 (error-clock-type 'date-difference dat1))
675      (unless tim2 (error-clock-type 'date-difference dat2))
676      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
677
678(define (date-add-duration dat dur . args)
679  (check-date 'date-add-duration dat)
680  (check-duration 'date-add-duration dur)
681  (let-optionals args ((tt (default-date-clock-type)))
682    (let ((tim (tm:date->time dat tt)))
683      (unless tim (error-clock-type 'date-add-duration dat))
684      (time->date (tm:add-duration tim dur (tm:as-some-time tim))) ) ) )
685
686(define (date-subtract-duration dat dur . args)
687  (check-date 'date-subtract-duration dat)
688  (check-duration 'date-subtract-duration dur)
689  (let-optionals args ((tt (default-date-clock-type)))
690    (let ((tim (tm:date->time dat tt)))
691      (unless tim (error-clock-type 'date-subtract-duration dat))
692      (time->date (tm:subtract-duration tim dur (tm:as-some-time tim))) ) ) )
693
694;; Time to Date
695
696(define (time-tai->date tim . tzi)
697  (check-time-and-type 'time-tai->date tim 'tai)
698  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )
699
700(define (time-utc->date tim . tzi)
701  (check-time-and-type 'time-utc->date tim 'utc)
702  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #t))) )
703
704(define (time-monotonic->date tim . tzi)
705  (check-time-and-type 'time-monotonic->date tim 'monotonic)
706  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )
707
708(define (time->date tim . tzi)
709  (check-time 'time->date tim)
710  (or (tm:time->date tim (checked-optional-timezone-info 'time->date (optional tzi #t)))
711      ; This shouldn't happen
712      (error-clock-type 'time->date tim)) )
713
714;; Date to Time
715
716(define (date->time-utc dat)
717  (check-date 'date->time-utc dat)
718  (tm:date->time-utc dat) )
719
720(define (date->time-tai dat)
721  (check-date 'date->time-tai dat)
722  (tm:date->time-tai dat) )
723
724(define (date->time-monotonic dat)
725  (check-date 'date->time-monotonic dat)
726  (tm:date->time-monotonic dat) )
727
728(define (date->time dat . args)
729  (check-date 'date->time dat)
730  (let-optionals args ((tt (default-date-clock-type)))
731    (or (tm:date->time dat tt)
732        (error-clock-type 'date->time tt) ) ) )
733
734;; Given a 'two digit' number, find the year within 50 years +/-
735
736(define (natural-year n . tzi)
737  (check-date-year 'natural-year n)
738  (tm:natural-year n (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
739
740;; Leap Year
741
742(define (leap-year? dat)
743  (check-date 'date-leap-year? dat)
744  (tm:leap-year? (tm:date-year dat)) )
745
746;; Day of Year
747
748(define (date-year-day dat)
749  (check-date 'date-year-day dat)
750  (tm:date-year-day dat) )
751
752(define (days-in-month/year mn yr)
753  (check-date-year 'days-in-month/year yr)
754  (check-date-month 'days-in-month/year mn)
755  (tm:days-in-month yr mn) )
756
757;; Week Day
758
759(define (date-week-day dat)
760  (check-date 'date-week-day dat)
761  (tm:date-week-day dat) )
762
763;;
764
765(define (date-week-number dat . args)
766  (check-date 'date-week-number dat)
767  (let ((day-of-week-starting-week (optional args 0)))
768    (check-week-day 'date-week-number day-of-week-starting-week)
769    (tm:date-week-number dat day-of-week-starting-week) ) )
770
771;; Julian-day Operations
772
773(define (date->julian-day dat)
774  (check-date 'date->julian-day dat)
775  (tm:date->julian-day dat) )
776
777(define (date->modified-julian-day dat)
778  (check-date 'date->modified-julian-day dat)
779  (tm:julian-day->modified-julian-day (tm:date->julian-day dat)) )
780
781;; Time to Julian-day
782
783(define (time-utc->julian-day tim)
784  (check-time-and-type 'time-utc->julian-day tim 'utc)
785  (tm:time-utc->julian-day tim) )
786
787(define (time-tai->julian-day tim)
788  (check-time-and-type 'time-tai->julian-day tim 'tai)
789  (tm:time-tai->julian-day tim) )
790
791(define (time-monotonic->julian-day tim)
792  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
793  (tm:time-monotonic->julian-day tim) )
794
795(define (time->julian-day tim)
796  (check-time 'time->julian-day tim)
797  (or (tm:time->julian-day tim)
798      (error-clock-type 'time->julian-day tim) ) )
799
800(define (time-utc->modified-julian-day tim)
801  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
802  (tm:time-utc->modified-julian-day tim) )
803
804(define (time-tai->modified-julian-day tim)
805  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
806  (tm:time-tai->modified-julian-day tim) )
807
808(define (time-monotonic->modified-julian-day tim)
809  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
810  (tm:time-monotonic->modified-julian-day tim) )
811
812(define (time->modified-julian-day tim)
813  (check-time 'time->modified-julian-day tim)
814  (or (tm:time->modified-julian-day tim)
815      (error-clock-type 'time->modified-julian-day tim) ) )
816
817;; Julian-day to Time
818
819(define (julian-day->time-utc jdn)
820  (check-julian-day 'julian-day->time-utc jdn)
821  (tm:julian-day->time-utc jdn) )
822
823(define (julian-day->time-tai jdn)
824  (check-julian-day 'julian-day->time-tai jdn)
825  (let ((tim (tm:julian-day->time-utc jdn)))
826    (tm:time-utc->time-tai tim tim) ) )
827
828(define (julian-day->time-monotonic jdn)
829  (check-julian-day 'julian-day->time-monotonic jdn)
830  (let ((tim (julian-day->time-utc jdn)))
831    (tm:time-utc->time-monotonic tim tim) ) )
832
833(define (julian-day->date jdn . tzi)
834  (check-julian-day 'julian-day->date jdn)
835  (tm:time-utc->date (tm:julian-day->time-utc jdn)
836                     (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )
837
838(define (modified-julian-day->time-utc mjdn)
839  (check-julian-day 'modified-julian-day->time-utc mjdn)
840  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
841
842(define (modified-julian-day->time-tai mjdn)
843  (check-julian-day 'modified-julian-day->time-tai mjdn)
844  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
845    (tm:time-utc->time-tai tim tim) ) )
846
847(define (modified-julian-day->time-monotonic mjdn)
848  (check-julian-day 'modified-julian-day->time-monotonic mjdn)
849  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
850    (tm:time-utc->time-monotonic tim tim) ) )
851
852(define (modified-julian-day->date mjdn . tzi)
853  (check-julian-day 'modified-julian-day->date mjdn)
854  (tm:time-utc->date (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))
855                     (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )
856
857;; The Julian-day
858
859(define (current-julian-day)
860  (tm:time-utc->julian-day (tm:current-time-utc)) )
861
862(define (current-modified-julian-day)
863  (tm:time-utc->modified-julian-day (tm:current-time-utc)) )
864
865) ;module srfi-19-core
Note: See TracBrowser for help on using the repository browser.