source: project/release/4/srfi-19/tags/3.6.0/srfi-19-date.scm @ 35411

Last change on this file since 35411 was 35411, checked in by Kon Lovett, 3 years ago

rel 3.6.0

File size: 19.8 KB
Line 
1;;;; srfi-19-date.scm
2;;;; Chicken port, Kon Lovett, Dec '05
3
4;;Issues
5;;
6;; - use of check-* im or/and forms is problematic
7
8;; SRFI-19: Time Data Types and Procedures.
9;;
10;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
11;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
12;;
13;; This document and translations of it may be copied and furnished to others,
14;; and derivative works that comment on or otherwise explain it or assist in its
15;; implementation may be prepared, copied, published and distributed, in whole or
16;; in part, without restriction of any kind, provided that the above copyright
17;; notice and this paragraph are included on all such copies and derivative works.
18;; However, this document itself may not be modified in any way, such as by
19;; removing the copyright notice or references to the Scheme Request For
20;; Implementation process or editors, except as needed for the purpose of
21;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
22;; process must be followed, or as required to translate it into languages other
23;; than English.
24;;
25;; The limited permissions granted above are perpetual and will not be revoked
26;; by the authors or their successors or assigns.
27;;
28;; This document and the information contained herein is provided on an "AS IS"
29;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
30;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
31;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
32;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
33
34(module srfi-19-date
35
36(;export
37  ;SRFI-19
38  current-date
39  current-julian-day
40  current-modified-julian-day
41  make-date
42  date-nanosecond
43  date-second
44  date-minute
45  date-hour
46  date-day
47  date-month
48  date-year
49  date-zone-offset
50  leap-year?          ;not in original document
51  date-year-day
52  days-in-month/year
53  natural-year
54  date-week-day
55  date-week-number
56  date->julian-day
57  date->modified-julian-day
58  date->time-monotonic
59  date->time-tai
60  date->time-utc
61  julian-day->date
62  julian-day->time-monotonic
63  julian-day->time-tai
64  julian-day->time-utc
65  modified-julian-day->date
66  modified-julian-day->time-monotonic
67  modified-julian-day->time-tai
68  modified-julian-day->time-utc
69  time-monotonic->date
70  time-monotonic->julian-day
71  time-monotonic->modified-julian-day
72  time-tai->date
73  time-tai->julian-day
74  time-tai->modified-julian-day
75  time-utc->date
76  time-utc->julian-day
77  time-utc->modified-julian-day
78  ;Extensions
79  date-record-printer-format
80  seconds->date
81  read-leap-second-table
82  time->date
83  default-date-clock-type
84  default-date-adjust-integer
85  date-zone-name
86  date-dst?
87  copy-date
88  date->time
89  date-adjust
90  date-difference
91  date-add-duration
92  date-subtract-duration
93  date=?
94  date>?
95  date<?
96  date>=?
97  date<=?
98  date-max
99  date-min
100  time->julian-day
101  time->modified-julian-day
102  date-compare
103  ;DEPRECATED
104  seconds->date/type)
105
106(import
107  (except scheme
108    zero? negative? positive? real?))
109
110(import chicken)
111
112(use
113  (only numbers
114    zero? negative? positive? real?))
115
116(use
117  (only srfi-1
118    fold list-index)
119  (only srfi-69
120    make-hash-table symbol-hash
121    hash-table-exists? hash-table-ref/default hash-table-set!)
122  #;srfi-8
123  (only locale-components
124    check-timezone-components timezone-components?)
125  miscmacros
126  type-checks type-errors
127  srfi-19-timezone srfi-19-support)
128
129;;;
130
131(include "srfi-19-common")
132
133;;
134
135(define (checked-tm:time->date loc tim tzi)
136  (or
137    (tm:time->date tim tzi)
138    (error-convert loc 'time 'date tim)) )
139
140;;
141
142(define (checked-tm:date->time loc dat tt)
143  (or
144    (tm:date->time dat (check-clock-type loc tt))
145    (error-convert loc 'date 'time dat)) )
146
147;;
148
149(define (read-leap-second-table flnm)
150  ;FIXME should be check-pathname
151  (tm:read-leap-second-table (check-string 'read-leap-second-table flnm)) )
152
153;;; Date Object (Public Immutable)
154
155;;
156
157(define-syntax date-adjuster-create
158  (er-macro-transformer
159    (lambda (frm r cmp)
160      (let ((_date-adjuster-set! (r 'date-adjuster-set!))
161            (_begin (r 'begin)) )
162        `(,_begin
163          ,@(let loop ((args (cdr frm)) (ls '()))
164              (if (null? args)
165                ls
166                (let ((?key (car args))
167                      (?syns (cadr args))
168                      (?hdlr (caddr args)) )
169                  (loop
170                    (cdddr args)
171                    (cons
172                      `(,_date-adjuster-set! ',?key ',?syns ,?hdlr)
173                      ls) ) ) ) ) ) ) ) ) )
174
175;;
176
177;FIXME should this be thread-specific?
178(define-parameter default-date-clock-type 'utc
179  (lambda (obj)
180    (if (clock-type? obj)
181      obj
182      (begin
183        (warning-argument-type 'default-date-clock-type obj 'clock-type)
184        (default-date-clock-type) ) ) ) )
185
186(define-parameter default-date-adjust-integer tm:default-date-adjust-integer
187  (lambda (obj)
188    (if (procedure? obj)
189      obj
190      (begin
191        (warning-argument-type 'default-date-adjust-integer obj 'procedure)
192        (default-date-adjust-integer) ) ) ) )
193
194;; Date CTOR
195
196(define make-date-unique (cons #t #f))
197
198(define (make-date ns sec min hr dy mn yr . args)
199  (let-optionals args ((tzo (timezone-locale-offset)) (tzn #f) (dstf make-date-unique))
200    (let ((no-dstf (eq? make-date-unique dstf)))
201      (cond
202        ((timezone-components? tzo)
203          ;Supplied parameters override
204          (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
205          (set! tzn (or tzn (timezone-locale-name tzo)))
206          (set! tzo (timezone-locale-offset tzo)) )
207        (else
208          (when no-dstf (set! dstf #f)) ) ) )
209    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
210    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
211
212(define (copy-date dat)
213  (check-date 'copy-date dat)
214  (tm:copy-date dat) )
215
216;; Converts a seconds value, may be fractional, into a date type.
217;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
218;; A local (#t), utc (#f), or other (timezone-components) date depending on
219;; the optional 2nd argument. The default is #t.
220
221(define (seconds->date sec . tzi)
222  (let ((tzc (checked-optional-timezone-info 'seconds->date (optional tzi #t))))
223    (check-timezone-components 'seconds->date tzc)
224    (tm:seconds->date/type (check-raw-seconds 'seconds->date sec) tzc) ) )
225
226(define seconds->date/type seconds->date) ;DEPRECATED
227
228(define (current-date . tzi)
229  (tm:current-date (checked-optional-timezone-info 'current-date (optional tzi #t))) )
230
231;;
232
233(define (date-nanosecond dat)
234        (tm:date-nanosecond (check-date 'date-nanosecond dat)) )
235
236(define (date-second dat)
237        (tm:date-second (check-date 'date-second dat)) )
238
239(define (date-minute dat)
240        (tm:date-minute (check-date 'date-minute dat)) )
241
242(define (date-hour dat)
243        (tm:date-hour (check-date 'date-hour dat)) )
244
245(define (date-day dat)
246        (tm:date-day (check-date 'date-day dat)) )
247
248(define (date-month dat)
249        (tm:date-month (check-date 'date-month dat)) )
250
251(define (date-year dat)
252        (tm:date-year (check-date 'date-year dat)) )
253
254(define (date-dst? dat)
255        (tm:date-dst? (check-date 'date-dst? dat)) )
256
257(define (date-zone-offset dat)
258        (tm:date-zone-offset (check-date 'date-zone-offset dat)) )
259
260(define (date-zone-name dat)
261        (tm:date-zone-name (check-date 'date-zone-name dat)) )
262
263;; Date Comparison
264
265(define (checked-date-compare loc dat1 dat2)
266  (check-date-compatible-timezone-offsets loc (check-date loc dat1) (check-date loc dat2))
267  (tm:date-compare dat1 dat2) )
268
269;;
270
271(define (date-compare dat1 dat2)
272  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
273    (cond
274      ((fx> 0 dif)  -1)
275      ((fx< 0 dif)  1)
276      (else         0) ) ) )
277
278(define (date=? dat1 dat2)
279  (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
280
281(define (date<? dat1 dat2)
282  (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
283
284(define (date<=? dat1 dat2)
285  (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
286
287(define (date>? dat1 dat2)
288  (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
289
290(define (date>=? dat1 dat2)
291  (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
292
293(define (date-max dat1 . rest)
294  (fold
295    (lambda (dat acc)
296      (check-date-compatible-timezone-offsets 'date-max acc (check-date 'date-max dat))
297      (if (fx> 0 (tm:date-compare acc dat)) dat acc) )
298    (check-date 'date-max dat1)
299    rest) )
300
301(define (date-min dat1 . rest)
302  (fold
303    (lambda (dat acc)
304      (check-date-compatible-timezone-offsets 'date-min acc (check-date 'date-max dat))
305      (if (fx< 0 (tm:date-compare acc dat)) dat acc) )
306    (check-date 'date-min dat1)
307    rest) )
308
309;; Date Arithmetic
310
311(define (date-adjust dat amt key . args)
312  (let-optionals args ((tt (default-date-clock-type)))
313    (let-values (((key adjuster) (date-adjuster-ref 'date-adjust key)))
314      (adjuster
315        (check-date 'date-adjust dat)
316        ((default-date-adjust-integer) (check-integer 'date-adjust amt))
317        key
318        ;only used for duration conversion
319        tt) ) ) )
320
321(define (date-difference dat1 dat2 . args)
322  (let-optionals args ((tt (default-date-clock-type)))
323    (let ((tim1 (checked-tm:date->time 'date-difference (check-date 'date-difference dat1) tt))
324          (tim2 (checked-tm:date->time 'date-difference (check-date 'date-difference dat2) tt)) )
325      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
326
327(define (date-add-duration dat dur . args)
328  (check-duration 'date-add-duration dur)
329  (let-optionals args ((tt (default-date-clock-type)))
330    (let ((tim (checked-tm:date->time 'date-add-duration (check-date 'date-add-duration dat) tt)) )
331      (checked-tm:time->date 'date-add-duration
332        (tm:add-duration tim dur (tm:as-some-time tim))
333        (tm:date-timezone-info dat)) ) ) )
334
335(define (date-subtract-duration dat dur . args)
336  (check-duration 'date-subtract-duration dur)
337  (let-optionals args ((tt (default-date-clock-type)))
338    (let ((tim (checked-tm:date->time 'date-subtract-duration (check-date 'date-subtract-duration dat) tt)) )
339      (checked-tm:time->date 'date-subtract-duration
340        (tm:subtract-duration tim dur (tm:as-some-time tim))
341        (tm:date-timezone-info dat)) ) ) )
342
343;; Date Adjust Handlers
344
345(define (date-adjuster-years dat amt key tt)
346  (let ((yr (fx+ (tm:date-year dat) amt))
347        (ndat (tm:copy-date dat)) )
348    (tm:date-year-set! ndat yr)
349    (when
350        (and
351          (tm:leap-day? (tm:date-day dat) (tm:date-month dat))
352          (not (tm:leap-year? yr)))
353      (tm:date-day-set! ndat (tm:days-in-month (tm:date-month dat) yr)))
354    ndat ) )
355
356(define (date-adjuster-quarters dat amt key tt)
357  (date-adjuster-months dat (fx* 3 amt) 'months tt) )
358
359(define (date-adjuster-months dat amt key tt)
360  (if (zero? amt)
361    (tm:copy-date dat)
362    (let ((ndat (copy-date dat))
363          (yrs (quotient amt 12))
364          (mns (remainder amt 12)) )
365      (cond
366        ((positive? mns)
367          (when (fx< 12 (fx+ (tm:date-month dat) mns))
368            (tm:date-month-set! ndat 1)
369            (set! mns (fx- mns (fx- 12 (tm:date-month dat))))
370            (set! yrs (fx+ 1 yrs)) ) )
371        (else ;(negative? amt)
372          (when (fx> 1 (fx+ (tm:date-month dat) mns))
373            (tm:date-month-set! ndat 12)
374            (set! mns (fx+ mns (tm:date-month dat)))
375            (set! yrs (fx- yrs 1)) ) ) )
376      (tm:date-month-set! ndat (fx+ mns (tm:date-month ndat)))
377      (tm:date-year-set! ndat (fx+ yrs (tm:date-year ndat)))
378      (when (fx< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
379        (tm:date-day-set! ndat (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat))) )
380      ndat  ) ) )
381
382(define (date-adjuster-weeks dat amt key tt)
383  (date-adjuster-duration dat (fx* amt 7) 'days tt) )
384
385(define (date-adjuster-duration dat amt key tt)
386  (let ((tim (checked-tm:date->time 'date-adjust-duration dat tt))
387        (dur (make-duration (string->keyword (symbol->string key)) amt)) )
388    (checked-tm:time->date 'date-adjust-duration
389      (tm:add-duration tim dur (tm:as-some-time tim))
390      (tm:date-timezone-info dat)) ) )
391
392;FIXME dup code
393;From srfi-19-time
394(define (make-duration
395          #!key (days 0)
396                (hours 0) (minutes 0) (seconds 0)
397                (milliseconds 0) (microseconds 0) (nanoseconds 0))
398  (receive (ns sec)
399      (tm:duration-elements->time-values
400        days hours minutes seconds
401        milliseconds microseconds nanoseconds)
402    (tm:make-time 'duration ns sec) ) )
403
404;; Date Adjust Support
405
406(define +date-adjust-synonym-map+ (make-hash-table eq? symbol-hash))
407(define +date-adjuster-map+ (make-hash-table eq? symbol-hash))
408
409(define (date-adjust-key? obj)
410  (hash-table-exists? +date-adjust-synonym-map+ obj) )
411
412(define (date-adjuster-ref loc key)
413  (let (
414    (key (hash-table-ref/default +date-adjust-synonym-map+ key 'UNKNOWN)))
415    (values
416      key
417      (hash-table-ref/default +date-adjuster-map+ key (unknown-date-key-handler loc))) ) )
418
419(define (date-adjuster-set! key syns hdlr)
420  ;all are key
421  (hash-table-set! +date-adjust-synonym-map+ key key)
422  (for-each (cut hash-table-set! +date-adjust-synonym-map+ <> key) syns)
423  ;adjuster for key
424  (hash-table-set! +date-adjuster-map+ key hdlr) )
425
426(define date-key? date-adjust-key?)
427
428(define ((unknown-date-key-handler loc) dat amt key tt)
429  (error loc "unknown date-key" key) )
430
431;; Time to Date
432
433(define (time-tai->date tim . tzi)
434  (check-time-and-type 'time-tai->date tim 'tai)
435  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )
436
437(define (time-utc->date tim . tzi)
438  (check-time-and-type 'time-utc->date tim 'utc)
439  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #t))) )
440
441(define (time-monotonic->date tim . tzi)
442  (check-time-and-type 'time-monotonic->date tim 'monotonic)
443  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )
444
445(define (time->date tim . tzi)
446  (checked-tm:time->date 'time->date
447    (check-time 'time->date tim)
448    (checked-optional-timezone-info 'time->date (optional tzi #t))) )
449
450;; Date to Time
451
452(define (date->time-utc dat)
453  (tm:date->time-utc (check-date 'date->time-utc dat)) )
454
455(define (date->time-tai dat)
456  (tm:date->time-tai (check-date 'date->time-tai dat)) )
457
458(define (date->time-monotonic dat)
459  (tm:date->time-monotonic (check-date 'date->time-monotonic dat)) )
460
461(define (date->time dat . args)
462  (let-optionals args ((tt (default-date-clock-type)))
463    (checked-tm:date->time 'date->time (check-date 'date->time dat) tt) ) )
464
465;; Given a 'two digit' number, find the year within 50 years +/-
466
467(define (natural-year n . tzi)
468  (tm:natural-year (check-date-year 'natural-year n) (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
469
470;; Leap Year
471
472(define (leap-year? dat)
473  (tm:leap-year?
474    ;assume a number is a year, otherwise extract
475    (if (fixnum? dat)
476      dat
477      (tm:date-year (check-date 'date-leap-year? dat)))) )
478
479;; Day of Year
480
481(define (date-year-day dat)
482  (tm:date-year-day (check-date 'date-year-day dat)) )
483
484(define (days-in-month/year mn yr)
485  (tm:days-in-month (check-date-year 'days-in-month/year yr) (check-date-month 'days-in-month/year mn)) )
486
487;; Week Day
488
489(define (date-week-day dat)
490  (tm:date-week-day (check-date 'date-week-day dat)) )
491
492;;
493
494(define (date-week-number dat . args)
495  (let-optionals args ((1st-weekday 0))
496    (tm:date-week-number
497      (check-date 'date-week-number dat)
498      (check-week-day 'date-week-number 1st-weekday)) ) )
499
500;; Julian-day Operations
501
502(define (date->julian-day dat)
503  (tm:date->julian-day (check-date 'date->julian-day dat)) )
504
505(define (date->modified-julian-day dat)
506  (tm:julian-day->modified-julian-day
507    (tm:date->julian-day
508      (check-date 'date->modified-julian-day dat))) )
509
510;; Time to Julian-day
511
512(define (time-utc->julian-day tim)
513  (check-time-and-type 'time-utc->julian-day tim 'utc)
514  (tm:time-utc->julian-day tim) )
515
516(define (time-tai->julian-day tim)
517  (check-time-and-type 'time-tai->julian-day tim 'tai)
518  (tm:time-tai->julian-day tim) )
519
520(define (time-monotonic->julian-day tim)
521  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
522  (tm:time-monotonic->julian-day tim) )
523
524(define (time->julian-day tim)
525  (or
526    (tm:time->julian-day (check-time 'time->julian-day tim))
527    (error-convert 'time->julian-day 'time 'julian-day tim) ) )
528
529(define (time-utc->modified-julian-day tim)
530  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
531  (tm:time-utc->modified-julian-day tim) )
532
533(define (time-tai->modified-julian-day tim)
534  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
535  (tm:time-tai->modified-julian-day tim) )
536
537(define (time-monotonic->modified-julian-day tim)
538  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
539  (tm:time-monotonic->modified-julian-day tim) )
540
541(define (time->modified-julian-day tim)
542  (or
543    (tm:time->modified-julian-day (check-time 'time->modified-julian-day tim))
544    (error-convert 'time->modified-julian-day 'time 'modified-julian-day tim) ) )
545
546;; Julian-day to Time
547
548(define (julian-day->time-utc jdn)
549  (tm:julian-day->time-utc (check-julian-day 'julian-day->time-utc jdn)) )
550
551(define (julian-day->time-tai jdn)
552  (let ((tim (tm:julian-day->time-utc (check-julian-day 'julian-day->time-tai jdn))))
553    (tm:time-utc->time-tai tim tim) ) )
554
555(define (julian-day->time-monotonic jdn)
556  (let ((tim (julian-day->time-utc (check-julian-day 'julian-day->time-monotonic jdn))))
557    (tm:time-utc->time-monotonic tim tim) ) )
558
559(define (julian-day->date jdn . tzi)
560  (tm:time-utc->date
561    (tm:julian-day->time-utc (check-julian-day 'julian-day->date jdn))
562    (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )
563
564(define (modified-julian-day->time-utc mjdn)
565  (tm:julian-day->time-utc
566    (tm:modified-julian-day->julian-day
567      (check-julian-day 'modified-julian-day->time-utc mjdn))) )
568
569(define (modified-julian-day->time-tai mjdn)
570  (let ((tim
571          (tm:julian-day->time-utc
572            (tm:modified-julian-day->julian-day
573              (check-julian-day 'modified-julian-day->time-tai mjdn)))))
574    (tm:time-utc->time-tai tim tim) ) )
575
576(define (modified-julian-day->time-monotonic mjdn)
577  (let ((tim
578          (tm:julian-day->time-utc
579            (tm:modified-julian-day->julian-day
580              (check-julian-day 'modified-julian-day->time-monotonic mjdn)))))
581    (tm:time-utc->time-monotonic tim tim) ) )
582
583(define (modified-julian-day->date mjdn . tzi)
584  (tm:time-utc->date
585    (tm:julian-day->time-utc
586      (tm:modified-julian-day->julian-day
587        (check-julian-day 'modified-julian-day->date mjdn)))
588    (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )
589
590;; The Julian-day
591
592(define (current-julian-day)
593  (tm:time-utc->julian-day (tm:current-time-utc)) )
594
595(define (current-modified-julian-day)
596  (tm:time-utc->modified-julian-day (tm:current-time-utc)) )
597
598;;; Module Begin
599
600(date-adjuster-create
601  years           (year yrs yr y)                  date-adjuster-years
602  quarters        (quarter qtrs qtr Q)             date-adjuster-quarters
603  months          (month mons mon mns mn M)        date-adjuster-months
604  weeks           (week wks wk w)                  date-adjuster-weeks
605  days            (day dys dy d)                   date-adjuster-duration
606  hours           (hour hrs hr h)                  date-adjuster-duration
607  minutes         (minute mins min m)              date-adjuster-duration
608  seconds         (second secs sec s)              date-adjuster-duration
609  milliseconds    (millisecond millis milli ms)    date-adjuster-duration
610  microseconds    (microsecond micros micro us)    date-adjuster-duration
611  nanoseconds     (nanosecond nanos nano ns)       date-adjuster-duration
612)
613
614(define +date-key-lexographic-order+ '(
615  years
616  quarters
617  months
618  weeks
619  days
620  hours
621  minutes
622  seconds
623  milliseconds
624  microseconds
625  nanoseconds
626))
627
628(define (date-key= a b)
629  (eq? a b) )
630
631(define (date-key< a b)
632  (fx< 0 (date-key-compare a b)) )
633
634(define (date-key-compare a b)
635  (-
636    (list-index (cut eq? a <>) +date-key-lexographic-order+)
637    (list-index (cut eq? b <>) +date-key-lexographic-order+)) )
638
639) ;module srfi-19-date
Note: See TracBrowser for help on using the repository browser.