source: project/release/4/srfi-19/trunk/srfi-19-date.scm @ 15788

Last change on this file since 15788 was 15788, checked in by Kon Lovett, 11 years ago

Save.

File size: 14.5 KB
Line 
1;;;; srfi-19-date.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-date (;export
31  ; SRFI-19
32  current-date
33  current-julian-day
34  current-modified-julian-day
35  make-date
36  date-nanosecond
37  date-second
38  date-minute
39  date-hour
40  date-day
41  date-month
42  date-year
43  date-zone-offset
44  leap-year? ; Actually part of SRFI 19 but not in original document
45  date-year-day
46  days-in-month/year
47  natural-year
48  date-week-day
49  date-week-number
50  date->julian-day
51  date->modified-julian-day
52  date->time-monotonic
53  date->time-tai
54  date->time-utc
55  julian-day->date
56  julian-day->time-monotonic
57  julian-day->time-tai
58  julian-day->time-utc
59  modified-julian-day->date
60  modified-julian-day->time-monotonic
61  modified-julian-day->time-tai
62  modified-julian-day->time-utc
63  time-monotonic->date
64  time-monotonic->julian-day
65  time-monotonic->modified-julian-day
66  time-tai->date
67  time-tai->julian-day
68  time-tai->modified-julian-day
69  time-utc->date
70  time-utc->julian-day
71  time-utc->modified-julian-day
72  ; Extensions
73  seconds->date seconds->date/type
74  read-leap-second-table
75  time->date
76  default-date-clock-type
77  date-zone-name
78  date-dst?
79  copy-date
80  date->time
81  date-difference
82  date-add-duration
83  date-subtract-duration
84  date=?
85  date>?
86  date<?
87  date>=?
88  date<=?
89  date-max
90  date-min
91  time->julian-day
92  time->modified-julian-day
93  date-compare)
94
95  (import (except scheme zero? negative? positive? real?)
96          chicken
97          #;srfi-8
98          (only numbers zero? negative? positive? real?)
99          miscmacros
100          (only locale-components check-timezone-components timezone-components?)
101          type-checks
102          type-errors
103          srfi-19-timezone
104          srfi-19-support)
105
106  (require-library #;srfi-8 numbers miscmacros locale-components
107                   type-checks type-errors
108                   srfi-19-timezone srfi-19-support)
109
110;;;
111
112;;
113
114(define (read-leap-second-table flnm)
115  (check-string 'read-leap-second-table flnm) ;FIXME should be check-pathname
116  (tm:read-leap-second-table flnm) )
117
118
119;;; Date Object (Public Immutable)
120
121;;
122
123(define-parameter default-date-clock-type 'utc
124  (lambda (obj)
125    (cond ((clock-type? obj) obj)
126          (else
127           (warning-argument-type 'default-date-clock-type obj 'clock-type)
128           (default-date-clock-type) ) ) ) )
129
130;; Date CTOR
131
132(define (make-date ns sec min hr dy mn yr tzo . args)
133  (let-optionals args ((tzn #f) (dstf (void)))
134    (let ((no-dstf (eq? (void) dstf)))
135      (cond ((timezone-components? tzo)
136             ; Supplied parameters override
137             (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
138             (set! tzn (or tzn (timezone-locale-name tzo)))
139             (set! tzo (timezone-locale-offset tzo)) )
140            (else
141             (when no-dstf (set! dstf #f)) ) ) )
142    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
143    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
144
145(define (copy-date dat)
146  (check-date 'copy-date dat)
147  (tm:copy-date dat) )
148
149;; Converts a seconds value, may be fractional, into a date type.
150;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
151;; A local (#t), utc (#f), or other (timezone-components) date depending on
152;; the optional 2nd argument. The default is #f.
153
154(define (seconds->date sec . tzi)
155  (check-raw-seconds 'seconds->date/type sec)
156  (let ((tzc (checked-optional-timezone-info 'seconds->date/type (optional tzi #t))))
157    (check-timezone-components 'seconds->date/type tzc)
158    (tm:seconds->date/type sec tzc) ) )
159
160(define seconds->date/type seconds->date)
161
162(define (current-date . tzi)
163  (tm:current-date (checked-optional-timezone-info 'current-date (optional tzi #t))) )
164
165;;
166
167(define (date-nanosecond dat)
168        (check-date 'date-nanosecond dat)
169        (tm:date-nanosecond dat) )
170
171(define (date-second dat)
172        (check-date 'date-second dat)
173        (tm:date-second dat) )
174
175(define (date-minute dat)
176        (check-date 'date-minute dat)
177        (tm:date-minute dat) )
178
179(define (date-hour dat)
180        (check-date 'date-hour dat)
181        (tm:date-hour dat) )
182
183(define (date-day dat)
184        (check-date 'date-day dat)
185        (tm:date-day dat) )
186
187(define (date-month dat)
188        (check-date 'date-month dat)
189        (tm:date-month dat) )
190
191(define (date-year dat)
192        (check-date 'date-year dat)
193        (tm:date-year dat) )
194
195(define (date-dst? dat)
196        (check-date 'date-dst? dat)
197        (tm:date-dst? dat) )
198
199(define (date-zone-offset dat)
200        (check-date 'date-zone-offset dat)
201        (tm:date-zone-offset dat) )
202
203(define (date-zone-name dat)
204        (check-date 'date-zone-name dat)
205        (tm:date-zone-name dat) )
206
207;; Date Comparison
208
209(define (checked-date-compare loc dat1 dat2)
210  (check-date loc dat1)
211  (check-date loc dat2)
212  (check-date-compatible-timezone-offsets loc dat1 dat2)
213  (tm:date-compare dat1 dat2) )
214
215;;
216
217(define (date-compare dat1 dat2)
218  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
219    (cond ((fx> 0 dif)  -1)
220          ((fx< 0 dif)  1)
221          (else         0) ) ) )
222
223(define (date=? dat1 dat2)
224  (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
225
226(define (date<? dat1 dat2)
227  (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
228
229(define (date<=? dat1 dat2)
230  (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
231
232(define (date>? dat1 dat2)
233  (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
234
235(define (date>=? dat1 dat2)
236  (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
237
238(define (date-max dat1 . rest)
239  (check-date 'date-max dat1)
240  (let loop ((acc dat1) (ls rest))
241    (if (null? ls) acc
242        (let ((dat (car ls)))
243          (check-date 'date-max dat)
244          (check-date-compatible-timezone-offsets 'date-max acc dat)
245          (loop (if (fx> 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
246
247(define (date-min dat1 . rest)
248  (check-date 'date-min dat1)
249  (let loop ((acc dat1) (ls rest))
250    (if (null? ls) acc
251        (let ((dat (car ls)))
252          (check-date 'date-min dat)
253          (check-date-compatible-timezone-offsets 'date-min acc dat)
254          (loop (if (fx< 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
255
256;; Date Arithmetic
257
258(define (date-difference dat1 dat2 . args)
259  (check-date 'date-difference dat1)
260  (check-date 'date-difference dat2)
261  (let-optionals args ((tt (default-date-clock-type)))
262    (let ((tim1 (tm:date->time dat1 tt))
263          (tim2 (tm:date->time dat2 tt)) )
264      (unless tim1 (error-convert 'date-difference 'date 'time dat1))
265      (unless tim2 (error-convert 'date-difference 'date 'time dat2))
266      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
267
268(define (tm:time->date/tzi loc tim tzi)
269  (let ((dat (tm:time->date tim)))
270    (cond (dat
271            (tm:date-timezone-info-set! dat tzi)
272            dat )
273          (else
274            (error-convert loc 'time 'date tim) ) ) ) )
275
276(define (date-add-duration dat dur . args)
277  (check-date 'date-add-duration dat)
278  (check-duration 'date-add-duration dur)
279  (let-optionals args ((tt (default-date-clock-type)))
280    (let ((tim (tm:date->time dat tt)) )
281      (unless tim (error-convert 'date-add-duration 'date 'time dat))
282      (tm:time->date/tzi 'date-add-duration
283                         (tm:add-duration tim dur (tm:as-some-time tim))
284                         (tm:date-timezone-info dat)) ) ) )
285
286(define (date-subtract-duration dat dur . args)
287  (check-date 'date-subtract-duration dat)
288  (check-duration 'date-subtract-duration dur)
289  (let-optionals args ((tt (default-date-clock-type)))
290    (let ((tim (tm:date->time dat tt)) )
291      (unless tim (error-convert 'date-subtract-duration 'date 'time dat))
292      (tm:time->date/tzi 'date-subtract-duration
293                         (tm:subtract-duration tim dur (tm:as-some-time tim))
294                         (tm:date-timezone-info dat)) ) ) )
295
296;; Time to Date
297
298(define (time-tai->date tim . tzi)
299  (check-time-and-type 'time-tai->date tim 'tai)
300  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )
301
302(define (time-utc->date tim . tzi)
303  (check-time-and-type 'time-utc->date tim 'utc)
304  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #t))) )
305
306(define (time-monotonic->date tim . tzi)
307  (check-time-and-type 'time-monotonic->date tim 'monotonic)
308  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )
309
310(define (time->date tim . tzi)
311  (check-time 'time->date tim)
312  (or (tm:time->date tim (checked-optional-timezone-info 'time->date (optional tzi #t)))
313      ; This shouldn't happen
314      (error-convert 'time->date 'time 'date tim)) )
315
316;; Date to Time
317
318(define (date->time-utc dat)
319  (check-date 'date->time-utc dat)
320  (tm:date->time-utc dat) )
321
322(define (date->time-tai dat)
323  (check-date 'date->time-tai dat)
324  (tm:date->time-tai dat) )
325
326(define (date->time-monotonic dat)
327  (check-date 'date->time-monotonic dat)
328  (tm:date->time-monotonic dat) )
329
330(define (date->time dat . args)
331  (check-date 'date->time dat)
332  (let-optionals args ((tt (default-date-clock-type)))
333    (or (tm:date->time dat tt)
334        (error-clock-type 'date->time tt) ) ) )
335
336;; Given a 'two digit' number, find the year within 50 years +/-
337
338(define (natural-year n . tzi)
339  (check-date-year 'natural-year n)
340  (tm:natural-year n (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
341
342;; Leap Year
343
344(define (leap-year? dat)
345  (check-date 'date-leap-year? dat)
346  (tm:leap-year? (tm:date-year dat)) )
347
348;; Day of Year
349
350(define (date-year-day dat)
351  (check-date 'date-year-day dat)
352  (tm:date-year-day dat) )
353
354(define (days-in-month/year mn yr)
355  (check-date-year 'days-in-month/year yr)
356  (check-date-month 'days-in-month/year mn)
357  (tm:days-in-month yr mn) )
358
359;; Week Day
360
361(define (date-week-day dat)
362  (check-date 'date-week-day dat)
363  (tm:date-week-day dat) )
364
365;;
366
367(define (date-week-number dat . args)
368  (check-date 'date-week-number dat)
369  (let-optionals args ((1st-weekday 0))
370    (check-week-day 'date-week-number 1st-weekday)
371    (tm:date-week-number dat 1st-weekday) ) )
372
373;; Julian-day Operations
374
375(define (date->julian-day dat)
376  (check-date 'date->julian-day dat)
377  (tm:date->julian-day dat) )
378
379(define (date->modified-julian-day dat)
380  (check-date 'date->modified-julian-day dat)
381  (tm:julian-day->modified-julian-day (tm:date->julian-day dat)) )
382
383;; Time to Julian-day
384
385(define (time-utc->julian-day tim)
386  (check-time-and-type 'time-utc->julian-day tim 'utc)
387  (tm:time-utc->julian-day tim) )
388
389(define (time-tai->julian-day tim)
390  (check-time-and-type 'time-tai->julian-day tim 'tai)
391  (tm:time-tai->julian-day tim) )
392
393(define (time-monotonic->julian-day tim)
394  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
395  (tm:time-monotonic->julian-day tim) )
396
397(define (time->julian-day tim)
398  (check-time 'time->julian-day tim)
399  (or (tm:time->julian-day tim)
400      (error-convert 'time->julian-day 'time 'julian-day tim) ) )
401
402(define (time-utc->modified-julian-day tim)
403  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
404  (tm:time-utc->modified-julian-day tim) )
405
406(define (time-tai->modified-julian-day tim)
407  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
408  (tm:time-tai->modified-julian-day tim) )
409
410(define (time-monotonic->modified-julian-day tim)
411  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
412  (tm:time-monotonic->modified-julian-day tim) )
413
414(define (time->modified-julian-day tim)
415  (check-time 'time->modified-julian-day tim)
416  (or (tm:time->modified-julian-day tim)
417      (error-convert 'time->modified-julian-day 'time 'modified-julian-day  tim) ) )
418
419;; Julian-day to Time
420
421(define (julian-day->time-utc jdn)
422  (check-julian-day 'julian-day->time-utc jdn)
423  (tm:julian-day->time-utc jdn) )
424
425(define (julian-day->time-tai jdn)
426  (check-julian-day 'julian-day->time-tai jdn)
427  (let ((tim (tm:julian-day->time-utc jdn)))
428    (tm:time-utc->time-tai tim tim) ) )
429
430(define (julian-day->time-monotonic jdn)
431  (check-julian-day 'julian-day->time-monotonic jdn)
432  (let ((tim (julian-day->time-utc jdn)))
433    (tm:time-utc->time-monotonic tim tim) ) )
434
435(define (julian-day->date jdn . tzi)
436  (check-julian-day 'julian-day->date jdn)
437  (tm:time-utc->date (tm:julian-day->time-utc jdn)
438                     (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )
439
440(define (modified-julian-day->time-utc mjdn)
441  (check-julian-day 'modified-julian-day->time-utc mjdn)
442  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
443
444(define (modified-julian-day->time-tai mjdn)
445  (check-julian-day 'modified-julian-day->time-tai mjdn)
446  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
447    (tm:time-utc->time-tai tim tim) ) )
448
449(define (modified-julian-day->time-monotonic mjdn)
450  (check-julian-day 'modified-julian-day->time-monotonic mjdn)
451  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
452    (tm:time-utc->time-monotonic tim tim) ) )
453
454(define (modified-julian-day->date mjdn . tzi)
455  (check-julian-day 'modified-julian-day->date mjdn)
456  (tm:time-utc->date (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))
457                     (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )
458
459;; The Julian-day
460
461(define (current-julian-day)
462  (tm:time-utc->julian-day (tm:current-time-utc)) )
463
464(define (current-modified-julian-day)
465  (tm:time-utc->modified-julian-day (tm:current-time-utc)) )
466
467) ;module srfi-19-date
Note: See TracBrowser for help on using the repository browser.