source: project/release/5/srfi-19/trunk/srfi-19-date.scm @ 38112

Last change on this file since 38112 was 38112, checked in by Kon Lovett, 6 weeks ago

use reexport, simplify genint, use variants (already in deps ;-)

File size: 20.2 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->seconds
89  date->time
90  date-adjust
91  date-difference
92  date-add-duration
93  date-subtract-duration
94  date=?
95  date>?
96  date<?
97  date>=?
98  date<=?
99  date-max
100  date-min
101  time->julian-day
102  time->modified-julian-day
103  date-compare)
104
105(import scheme)
106(import (chicken base))
107(import (chicken type))
108(import (chicken fixnum))
109(import (only (chicken keyword) string->keyword))
110(import (only srfi-1 fold list-index))
111(import (only srfi-69
112  make-hash-table symbol-hash
113  hash-table-exists? hash-table-ref/default hash-table-set!))
114#;(import srfi-8)
115(import (only locale-components check-timezone-components timezone-components?))
116(import miscmacros)
117(import type-checks)
118(import type-errors)
119(import srfi-19-timezone)
120(import srfi-19-support)
121
122;;;
123
124(include "srfi-19-common")
125
126;;
127
128(define (checked-tm:time->date loc tim tzi)
129  (or
130    (tm:time->date tim tzi)
131    (error-convert loc 'time 'date tim)) )
132
133;;
134
135(define (checked-tm:date->time loc dat tt)
136  (or
137    (tm:date->time dat (check-clock-type loc tt))
138    (error-convert loc 'date 'time dat)) )
139
140;;
141
142(define (read-leap-second-table flnm)
143  ;FIXME should be check-pathname
144  (tm:read-leap-second-table (check-string 'read-leap-second-table flnm)) )
145
146;;; Date Object (Public Immutable)
147
148;;
149
150(define-syntax date-adjuster-create
151  (er-macro-transformer
152    (lambda (frm r cmp)
153      (let (
154        (_date-adjuster-set! (r 'date-adjuster-set!))
155        (_begin (r 'begin)) )
156        `(,_begin
157          ,@(let loop ((args (cdr frm)) (ls '()))
158              (if (null? args)
159                ls
160                (let (
161                  (?key (car args))
162                  (?syns (cadr args))
163                  (?hdlr (caddr args))
164                  (?rest (cdddr args)) )
165                  (loop ?rest (cons `(,_date-adjuster-set! ',?key ',?syns ,?hdlr) ls) ) ) ) ) ) ) ) ) )
166
167#;
168(define-syntax date-adjuster-create
169  (syntax-rules ()
170    ((date-adjuster-create "aux" (?key ?syns ?hdlr) ...)
171      (begin
172        (date-adjuster-set! ?key ?syns ?hdlr)
173        (date-adjuster-create ...) ) )
174    ((date-adjuster-create ?key ?syns ?hdlr ...)
175      (date-adjuster-create "aux" (?key ?syns ?hdlr) ...) ) ) )
176
177;;
178
179;FIXME should this be thread-specific?
180(define-parameter default-date-clock-type 'utc
181  (lambda (obj)
182    (if (clock-type? obj)
183      obj
184      (begin
185        (warning-argument-type 'default-date-clock-type obj 'clock-type)
186        (default-date-clock-type) ) ) ) )
187
188(define-parameter default-date-adjust-integer tm:default-date-adjust-integer
189  (lambda (obj)
190    (if (procedure? obj)
191      obj
192      (begin
193        (warning-argument-type 'default-date-adjust-integer obj 'procedure)
194        (default-date-adjust-integer) ) ) ) )
195
196;; Date CTOR
197
198(define make-date-unique (cons #t #f))
199
200(define (make-date ns sec min hr dy mn yr . args)
201  (let-optionals args ((tzo (timezone-locale-offset)) (tzn #f) (dstf make-date-unique))
202    (let ((no-dstf (eq? make-date-unique dstf)))
203      (cond
204        ((timezone-components? tzo)
205          ;Supplied parameters override
206          (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
207          (set! tzn (or tzn (timezone-locale-name tzo)))
208          (set! tzo (timezone-locale-offset tzo)) )
209        (else
210          (when no-dstf (set! dstf #f)) ) ) )
211    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
212    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
213
214(define (copy-date dat)
215  (check-date 'copy-date dat)
216  (tm:copy-date dat) )
217
218;; Converts a seconds value, may be fractional, into a date type.
219;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
220;; A local (#t), utc (#f), or other (timezone-components) date depending on
221;; the optional 2nd argument. The default is #t.
222
223(define (seconds->date sec . tzi)
224  (let ((tzc (checked-optional-timezone-info 'seconds->date (optional tzi #t))))
225    (check-timezone-components 'seconds->date tzc)
226    (tm:seconds->date/type (check-raw-seconds 'seconds->date sec) tzc) ) )
227
228(define (date->seconds dat #!optional (tt (default-date-clock-type)))
229  (let* (
230    (dat (check-date 'date->seconds dat))
231    (tim
232      (case (check-clock-type 'date->seconds tt)
233        ((utc)        (tm:date->time-utc dat))
234        ((tai)        (tm:date->time-tai dat))
235        ((monotonic)  (tm:date->time-monotonic dat)) ) ) )
236    (tm:time-second tim) ) )
237
238(define (current-date . tzi)
239  (tm:current-date (checked-optional-timezone-info 'current-date (optional tzi #t))) )
240
241;;
242
243(define (date-nanosecond dat)
244        (tm:date-nanosecond (check-date 'date-nanosecond dat)) )
245
246(define (date-second dat)
247        (tm:date-second (check-date 'date-second dat)) )
248
249(define (date-minute dat)
250        (tm:date-minute (check-date 'date-minute dat)) )
251
252(define (date-hour dat)
253        (tm:date-hour (check-date 'date-hour dat)) )
254
255(define (date-day dat)
256        (tm:date-day (check-date 'date-day dat)) )
257
258(define (date-month dat)
259        (tm:date-month (check-date 'date-month dat)) )
260
261(define (date-year dat)
262        (tm:date-year (check-date 'date-year dat)) )
263
264(define (date-dst? dat)
265        (tm:date-dst? (check-date 'date-dst? dat)) )
266
267(define (date-zone-offset dat)
268        (tm:date-zone-offset (check-date 'date-zone-offset dat)) )
269
270(define (date-zone-name dat)
271        (tm:date-zone-name (check-date 'date-zone-name dat)) )
272
273;; Date Comparison
274
275(define (checked-date-compare loc dat1 dat2)
276  (check-date-compatible-timezone-offsets loc (check-date loc dat1) (check-date loc dat2))
277  (tm:date-compare dat1 dat2) )
278
279;;
280
281(define (date-compare dat1 dat2)
282  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
283    (cond
284      ((fx> 0 dif)  -1)
285      ((fx< 0 dif)  1)
286      (else         0) ) ) )
287
288(define (date=? dat1 dat2)
289  (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
290
291(define (date<? dat1 dat2)
292  (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
293
294(define (date<=? dat1 dat2)
295  (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
296
297(define (date>? dat1 dat2)
298  (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
299
300(define (date>=? dat1 dat2)
301  (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
302
303(define (date-max dat1 . rest)
304  (fold
305    (lambda (dat acc)
306      (check-date-compatible-timezone-offsets 'date-max acc (check-date 'date-max dat))
307      (if (fx> 0 (tm:date-compare acc dat)) dat acc) )
308    (check-date 'date-max dat1)
309    rest) )
310
311(define (date-min dat1 . rest)
312  (fold
313    (lambda (dat acc)
314      (check-date-compatible-timezone-offsets 'date-min acc (check-date 'date-max dat))
315      (if (fx< 0 (tm:date-compare acc dat)) dat acc) )
316    (check-date 'date-min dat1)
317    rest) )
318
319;; Date Arithmetic
320
321(define (date-adjust dat amt key . args)
322  (let-optionals args ((tt (default-date-clock-type)))
323    (let-values (((key adjuster) (date-adjuster-ref 'date-adjust key)))
324      (adjuster
325        (check-date 'date-adjust dat)
326        ((default-date-adjust-integer) (check-integer 'date-adjust amt))
327        key
328        ;only used for duration conversion
329        tt) ) ) )
330
331(define (date-difference dat1 dat2 . args)
332  (let-optionals args ((tt (default-date-clock-type)))
333    (let ((tim1 (checked-tm:date->time 'date-difference (check-date 'date-difference dat1) tt))
334          (tim2 (checked-tm:date->time 'date-difference (check-date 'date-difference dat2) tt)) )
335      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
336
337(define (date-add-duration dat dur . args)
338  (check-duration 'date-add-duration dur)
339  (let-optionals args ((tt (default-date-clock-type)))
340    (let ((tim (checked-tm:date->time 'date-add-duration (check-date 'date-add-duration dat) tt)) )
341      (checked-tm:time->date 'date-add-duration
342        (tm:add-duration tim dur (tm:as-some-time tim))
343        (tm:date-timezone-info dat)) ) ) )
344
345(define (date-subtract-duration dat dur . args)
346  (check-duration 'date-subtract-duration dur)
347  (let-optionals args ((tt (default-date-clock-type)))
348    (let ((tim (checked-tm:date->time 'date-subtract-duration (check-date 'date-subtract-duration dat) tt)) )
349      (checked-tm:time->date 'date-subtract-duration
350        (tm:subtract-duration tim dur (tm:as-some-time tim))
351        (tm:date-timezone-info dat)) ) ) )
352
353;; Date Adjust Handlers
354
355(define (date-adjuster-years dat amt key tt)
356  (let ((yr (fx+ (tm:date-year dat) amt))
357        (ndat (tm:copy-date dat)) )
358    (tm:date-year-set! ndat yr)
359    (when
360        (and
361          (tm:leap-day? (tm:date-day dat) (tm:date-month dat))
362          (not (tm:leap-year? yr)))
363      (tm:date-day-set! ndat (tm:days-in-month (tm:date-month dat) yr)))
364    ndat ) )
365
366(define (date-adjuster-quarters dat amt key tt)
367  (date-adjuster-months dat (fx* 3 amt) 'months tt) )
368
369(define (date-adjuster-months dat amt key tt)
370  (if (zero? amt)
371    (tm:copy-date dat)
372    (let ((ndat (copy-date dat))
373          (yrs (quotient amt 12))
374          (mns (remainder amt 12)) )
375      (cond
376        ((positive? mns)
377          (when (fx< 12 (fx+ (tm:date-month dat) mns))
378            (tm:date-month-set! ndat 1)
379            (set! mns (fx- mns (fx- 12 (tm:date-month dat))))
380            (set! yrs (fx+ 1 yrs)) ) )
381        (else ;(negative? amt)
382          (when (fx> 1 (fx+ (tm:date-month dat) mns))
383            (tm:date-month-set! ndat 12)
384            (set! mns (fx+ mns (tm:date-month dat)))
385            (set! yrs (fx- yrs 1)) ) ) )
386      (tm:date-month-set! ndat (fx+ mns (tm:date-month ndat)))
387      (tm:date-year-set! ndat (fx+ yrs (tm:date-year ndat)))
388      (when (fx< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
389        (tm:date-day-set! ndat (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat))) )
390      ndat  ) ) )
391
392(define (date-adjuster-weeks dat amt key tt)
393  (date-adjuster-duration dat (fx* amt 7) 'days tt) )
394
395(define (date-adjuster-duration dat amt key tt)
396  (let ((tim (checked-tm:date->time 'date-adjust-duration dat tt))
397        (dur (make-duration (string->keyword (symbol->string key)) amt)) )
398    (checked-tm:time->date 'date-adjust-duration
399      (tm:add-duration tim dur (tm:as-some-time tim))
400      (tm:date-timezone-info dat)) ) )
401
402;FIXME dup code
403;From srfi-19-time
404(define (make-duration
405          #!key (days 0)
406                (hours 0) (minutes 0) (seconds 0)
407                (milliseconds 0) (microseconds 0) (nanoseconds 0))
408  (receive (ns sec)
409      (tm:duration-elements->time-values
410        days hours minutes seconds
411        milliseconds microseconds nanoseconds)
412    (tm:make-time 'duration ns sec) ) )
413
414;; Date Adjust Support
415
416(define +date-adjust-synonym-map+ (make-hash-table eq? symbol-hash))
417(define +date-adjuster-map+ (make-hash-table eq? symbol-hash))
418
419(define (date-adjust-key? obj)
420  (hash-table-exists? +date-adjust-synonym-map+ obj) )
421
422(define (date-adjuster-ref loc key)
423  (let (
424    (key (hash-table-ref/default +date-adjust-synonym-map+ key 'UNKNOWN)))
425    (values
426      key
427      (hash-table-ref/default +date-adjuster-map+ key (unknown-date-key-handler loc))) ) )
428
429(define (date-adjuster-set! key syns hdlr)
430  ;all are key
431  (hash-table-set! +date-adjust-synonym-map+ key key)
432  (for-each (cut hash-table-set! +date-adjust-synonym-map+ <> key) syns)
433  ;adjuster for key
434  (hash-table-set! +date-adjuster-map+ key hdlr) )
435
436(define date-key? date-adjust-key?)
437
438(define ((unknown-date-key-handler loc) dat amt key tt)
439  (error loc "unknown date-key" key) )
440
441;; Time to Date
442
443(define (time-tai->date tim . tzi)
444  (check-time-and-type 'time-tai->date tim 'tai)
445  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )
446
447(define (time-utc->date tim . tzi)
448  (check-time-and-type 'time-utc->date tim 'utc)
449  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #t))) )
450
451(define (time-monotonic->date tim . tzi)
452  (check-time-and-type 'time-monotonic->date tim 'monotonic)
453  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )
454
455(define (time->date tim . tzi)
456  (checked-tm:time->date 'time->date
457    (check-time 'time->date tim)
458    (checked-optional-timezone-info 'time->date (optional tzi #t))) )
459
460;; Date to Time
461
462(define (date->time-utc dat)
463  (tm:date->time-utc (check-date 'date->time-utc dat)) )
464
465(define (date->time-tai dat)
466  (tm:date->time-tai (check-date 'date->time-tai dat)) )
467
468(define (date->time-monotonic dat)
469  (tm:date->time-monotonic (check-date 'date->time-monotonic dat)) )
470
471(define (date->time dat . args)
472  (let-optionals args ((tt (default-date-clock-type)))
473    (checked-tm:date->time 'date->time (check-date 'date->time dat) tt) ) )
474
475;; Given a 'two digit' number, find the year within 50 years +/-
476
477(define (natural-year n . tzi)
478  (tm:natural-year
479    (check-date-year 'natural-year n)
480    (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
481
482;; Leap Year
483
484(define (leap-year? dat)
485  (tm:leap-year?
486    ;assume a number is a year, otherwise extract
487    (if (fixnum? dat)
488      dat
489      (tm:date-year (check-date 'date-leap-year? dat)))) )
490
491;; Day of Year
492
493(define (date-year-day dat)
494  (tm:date-year-day (check-date 'date-year-day dat)) )
495
496(define (days-in-month/year mn yr)
497  (tm:days-in-month (check-date-year 'days-in-month/year yr) (check-date-month 'days-in-month/year mn)) )
498
499;; Week Day
500
501(define (date-week-day dat)
502  (tm:date-week-day (check-date 'date-week-day dat)) )
503
504;;
505
506(define (date-week-number dat . args)
507  (let-optionals args ((1st-weekday 0))
508    (tm:date-week-number
509      (check-date 'date-week-number dat)
510      (check-week-day 'date-week-number 1st-weekday)) ) )
511
512;; Julian-day Operations
513
514(define (date->julian-day dat)
515  (tm:date->julian-day (check-date 'date->julian-day dat)) )
516
517(define (date->modified-julian-day dat)
518  (tm:julian-day->modified-julian-day
519    (tm:date->julian-day
520      (check-date 'date->modified-julian-day dat))) )
521
522;; Time to Julian-day
523
524(define (time-utc->julian-day tim)
525  (check-time-and-type 'time-utc->julian-day tim 'utc)
526  (tm:time-utc->julian-day tim) )
527
528(define (time-tai->julian-day tim)
529  (check-time-and-type 'time-tai->julian-day tim 'tai)
530  (tm:time-tai->julian-day tim) )
531
532(define (time-monotonic->julian-day tim)
533  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
534  (tm:time-monotonic->julian-day tim) )
535
536(define (time->julian-day tim)
537  (or
538    (tm:time->julian-day (check-time 'time->julian-day tim))
539    (error-convert 'time->julian-day 'time 'julian-day tim) ) )
540
541(define (time-utc->modified-julian-day tim)
542  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
543  (tm:time-utc->modified-julian-day tim) )
544
545(define (time-tai->modified-julian-day tim)
546  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
547  (tm:time-tai->modified-julian-day tim) )
548
549(define (time-monotonic->modified-julian-day tim)
550  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
551  (tm:time-monotonic->modified-julian-day tim) )
552
553(define (time->modified-julian-day tim)
554  (or
555    (tm:time->modified-julian-day (check-time 'time->modified-julian-day tim))
556    (error-convert 'time->modified-julian-day 'time 'modified-julian-day tim) ) )
557
558;; Julian-day to Time
559
560(define (julian-day->time-utc jdn)
561  (tm:julian-day->time-utc (check-julian-day 'julian-day->time-utc jdn)) )
562
563(define (julian-day->time-tai jdn)
564  (let ((tim (tm:julian-day->time-utc (check-julian-day 'julian-day->time-tai jdn))))
565    (tm:time-utc->time-tai tim tim) ) )
566
567(define (julian-day->time-monotonic jdn)
568  (let ((tim (julian-day->time-utc (check-julian-day 'julian-day->time-monotonic jdn))))
569    (tm:time-utc->time-monotonic tim tim) ) )
570
571(define (julian-day->date jdn . tzi)
572  (tm:time-utc->date
573    (tm:julian-day->time-utc (check-julian-day 'julian-day->date jdn))
574    (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )
575
576(define (modified-julian-day->time-utc mjdn)
577  (tm:modified-julian-day->time-utc
578    (check-julian-day 'modified-julian-day->time-utc mjdn)) )
579
580(define (modified-julian-day->time-tai mjdn)
581  (let (
582    (tim
583      (tm:modified-julian-day->time-utc
584        (check-julian-day 'modified-julian-day->time-tai mjdn))) )
585    (tm:time-utc->time-tai tim tim) ) )
586
587(define (modified-julian-day->time-monotonic mjdn)
588  (let (
589    (tim
590      (tm:modified-julian-day->time-utc
591        (check-julian-day 'modified-julian-day->time-monotonic mjdn))) )
592    (tm:time-utc->time-monotonic tim tim) ) )
593
594(define (modified-julian-day->date mjdn . tzi)
595  (tm:time-utc->date
596    (tm:modified-julian-day->time-utc
597      (check-julian-day 'modified-julian-day->date mjdn))
598    (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )
599
600;; The Julian-day
601
602(define (current-julian-day)
603  (tm:time-utc->julian-day (tm:current-time-utc)) )
604
605(define (current-modified-julian-day)
606  (tm:time-utc->modified-julian-day (tm:current-time-utc)) )
607
608;;; Module Begin
609
610(date-adjuster-create
611  years           (year yrs yr y)                  date-adjuster-years
612  quarters        (quarter qtrs qtr Q)             date-adjuster-quarters
613  months          (month mons mon mns mn M)        date-adjuster-months
614  weeks           (week wks wk w)                  date-adjuster-weeks
615  days            (day dys dy d)                   date-adjuster-duration
616  hours           (hour hrs hr h)                  date-adjuster-duration
617  minutes         (minute mins min m)              date-adjuster-duration
618  seconds         (second secs sec s)              date-adjuster-duration
619  milliseconds    (millisecond millis milli ms)    date-adjuster-duration
620  microseconds    (microsecond micros micro us)    date-adjuster-duration
621  nanoseconds     (nanosecond nanos nano ns)       date-adjuster-duration
622)
623
624(define +date-key-lexographic-order+ '(
625  years
626  quarters
627  months
628  weeks
629  days
630  hours
631  minutes
632  seconds
633  milliseconds
634  microseconds
635  nanoseconds
636))
637
638(define (date-key= a b)
639  (eq? a b) )
640
641(define (date-key< a b)
642  (fx< 0 (date-key-compare a b)) )
643
644(define (date-key-compare a b)
645  (-
646    (list-index (cut eq? a <>) +date-key-lexographic-order+)
647    (list-index (cut eq? b <>) +date-key-lexographic-order+)) )
648
649) ;module srfi-19-date
Note: See TracBrowser for help on using the repository browser.