source: project/release/4/srfi-19/trunk/tests/run.scm @ 15754

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

Save

File size: 12.3 KB
Line 
1;;; simple test procedures
2
3(use srfi-19)
4
5(use numbers) ; Rational results from 'julian-day'
6
7(use srfi-1) ; For current-date w/o tz-locale test
8
9(use format) ; For conversion test
10
11;;
12
13(define s19-tests (list))
14
15(define (define-s19-test! name thunk)
16  (let ((name (if (symbol? name) name (string->symbol name)))
17        (pr (assoc name s19-tests)))
18    (if pr
19        (set-cdr! pr thunk)
20        (set! s19-tests (append s19-tests (list (cons name thunk)))))))
21
22(define (run-s19-test name thunk verbose)
23  (if verbose (begin (display ";;; Running ") (display name)))
24  (let ((result (thunk)))
25    (if verbose (begin (display ": ") (display (not (not result))) (newline)))
26    result))
27
28(define (run-s19-tests . verbose)
29  (let ((runs 0) (goods 0) (bads 0) (verbose (if (cdr verbose) (cdr verbose) #f)))
30    (for-each (lambda (pr)
31                (set! runs (+ runs 1))
32                (if (run-s19-test (car pr) (cdr pr) verbose)
33                    (set! goods (+ goods 1))
34                    (set! bads (+ bads 1))))
35              s19-tests)
36    (if verbose
37        (begin
38          (display ";;; Results: Runs: ")
39          (display runs)
40          (display "; Goods: ")
41          (display goods)
42          (display "; Bads: ")
43          (display bads)
44          (if (> runs 0)
45              (begin
46                (display "; Pass rate: ")
47                (display (/ goods runs)))
48              (display "; No tests."))
49          (newline)))
50    (values runs goods bads)))
51
52;;
53
54(define-s19-test! "Creating time structures"
55  (lambda ()
56    (not (null? (list (current-time 'time-tai)
57                      (current-time 'time-utc)
58                      (current-time 'time-monotonic)
59                      (current-time 'time-thread)
60                      (current-time 'time-process))))))
61
62(define-s19-test! "Testing time resolutions"
63  (lambda ()
64    (not (null? (list (time-resolution 'time-tai)
65                      (time-resolution 'time-utc)
66                      (time-resolution 'time-monotonic)
67                      (time-resolution 'time-thread)
68                      (time-resolution 'time-process))))))
69
70(define-s19-test! "Time comparisons (time=?, etc.)"
71  (lambda ()
72    (let ((t1 (make-time 'time-utc 0 1))
73          (t2 (make-time 'time-utc 0 1))
74          (t3 (make-time 'time-utc 0 2))
75          (t11 (make-time 'time-utc 1001 1))
76          (t12 (make-time 'time-utc 1001 1))
77          (t13 (make-time 'time-utc 1001 2)))
78      (and (time=? t1 t2)
79           (time>? t3 t2)
80           (time<? t2 t3)
81           (time>=? t1 t2)
82           (time>=? t3 t2)
83           (time<=? t1 t2)
84           (time<=? t2 t3)
85           (time=? t11 t12)
86           (time>? t13 t12)
87           (time<? t12 t13)
88           (time>=? t11 t12)
89           (time>=? t13 t12)
90           (time<=? t11 t12)
91           (time<=? t12 t13)
92           ))))
93
94(define-s19-test! "Time difference"
95  (lambda ()
96    (let ((t1 (make-time 'time-utc 0 3000))
97          (t2 (make-time 'time-utc 0 1000))
98          (t3 (make-time 'time-duration 0 2000))
99          (t4 (make-time 'time-duration 0 -2000)))
100      (and
101       (time=? t3 (time-difference t1 t2))
102       (time=? t4 (time-difference t2 t1))))))
103
104(define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
105  (let* (;; right on the edge they should be the same
106         (utc-basic (make-time 'time-utc 0 utc))
107         (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
108         (utc->tai-basic (time-utc->time-tai utc-basic))
109         (tai->utc-basic (time-tai->time-utc tai-basic))
110         ;; a second before they should be the old diff
111         (utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
112         (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
113         (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
114         (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
115         ;; a second later they should be the new diff
116         (utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
117         (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
118         (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
119         (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
120         ;; ok, let's move the clock half a month or so plus half a second
121         (shy (* 15 24 60 60))
122         (hs (/ (expt 10 9) 2))
123         ;; a second later they should be the new diff
124         (utc-basic+2 (make-time 'time-utc hs (+ utc shy)))
125         (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
126         (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
127         (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))
128         )
129    (and (time=? utc-basic tai->utc-basic)
130         (time=? tai-basic utc->tai-basic)
131         (time=? utc-basic-1 tai->utc-basic-1)
132         (time=? tai-basic-1 utc->tai-basic-1)
133         (time=? utc-basic+1 tai->utc-basic+1)
134         (time=? tai-basic+1 utc->tai-basic+1)
135         (time=? utc-basic+2 tai->utc-basic+2)
136         (time=? tai-basic+2 utc->tai-basic+2)
137         )))
138
139(define-s19-test! "TAI-UTC Conversions"
140  (lambda ()
141    (and
142     (test-one-utc-tai-edge 915148800  32 31)
143     (test-one-utc-tai-edge 867715200  31 30)
144     (test-one-utc-tai-edge 820454400  30 29)
145     (test-one-utc-tai-edge 773020800  29 28)
146     (test-one-utc-tai-edge 741484800  28 27)
147     (test-one-utc-tai-edge 709948800  27 26)
148     (test-one-utc-tai-edge 662688000  26 25)
149     (test-one-utc-tai-edge 631152000  25 24)
150     (test-one-utc-tai-edge 567993600  24 23)
151     (test-one-utc-tai-edge 489024000  23 22)
152     (test-one-utc-tai-edge 425865600  22 21)
153     (test-one-utc-tai-edge 394329600  21 20)
154     (test-one-utc-tai-edge 362793600  20 19)
155     (test-one-utc-tai-edge 315532800  19 18)
156     (test-one-utc-tai-edge 283996800  18 17)
157     (test-one-utc-tai-edge 252460800  17 16)
158     (test-one-utc-tai-edge 220924800  16 15)
159     (test-one-utc-tai-edge 189302400  15 14)
160     (test-one-utc-tai-edge 157766400  14 13)
161     (test-one-utc-tai-edge 126230400  13 12)
162     (test-one-utc-tai-edge 94694400   12 11)
163     (test-one-utc-tai-edge 78796800   11 10)
164     (test-one-utc-tai-edge 63072000   10 0)
165     (test-one-utc-tai-edge 0          0  0) ;; at the epoch
166     (test-one-utc-tai-edge 10         0  0) ;; close to it ...
167     (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
168     )))
169
170(define (tm:date= d1 d2)
171  (and (= (date-year d1) (date-year d2))
172       (= (date-month d1) (date-month d2))
173       (= (date-day d1) (date-day d2))
174       (= (date-hour d1) (date-hour d2))
175       (= (date-second d1) (date-second d2))
176       (= (date-nanosecond d1) (date-nanosecond d2))
177       (= (date-zone-offset d1) (date-zone-offset d2))))
178
179(define-s19-test! "TAI-Date Conversions"
180  (lambda ()
181    (and
182     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
183               (make-date 0 58 59 23 31 12 1998 0))
184     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
185               (make-date 0 59 59 23 31 12 1998 0))
186     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
187               (make-date 0 60 59 23 31 12 1998 0))
188     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
189               (make-date 0 0 0 0 1 1 1999 0)))))
190
191(define-s19-test! "Date-UTC Conversions"
192  (lambda ()
193    (and
194     (time=? (make-time time-utc 0 (- 915148800 2))
195             (date->time-utc (make-date 0 58 59 23 31 12 1998 0)))
196     (time=? (make-time time-utc 0 (- 915148800 1))
197             (date->time-utc (make-date 0 59 59 23 31 12 1998 0)))
198     ;; yes, I think this is acutally right.
199     (time=? (make-time time-utc 0 (- 915148800 0))
200             (date->time-utc (make-date 0 60 59 23 31 12 1998 0)))
201     (time=? (make-time time-utc 0 (- 915148800 0))
202             (date->time-utc (make-date 0 0 0 0 1 1 1999 0)))
203     (time=? (make-time time-utc 0 (+ 915148800 1))
204             (date->time-utc (make-date 0 1 0 0 1 1 1999 0))))))
205
206(define-s19-test! "TZ Offset conversions"
207  (lambda ()
208    (let ((ct-utc (make-time time-utc 6320000 1045944859))
209          (ct-tai (make-time time-tai 6320000 1045944891))
210          (cd (make-date 6320000 19 14 15 22 2 2003 -18000)))
211      (and
212       (time=? ct-utc (date->time-utc cd))
213       (time=? ct-tai (date->time-tai cd))))))
214
215(define-s19-test! "date->string conversions"
216  (lambda ()
217    (equal? "~.Tue.Tuesday.Jun.June.Tue Jun 05 04:03:02-0200 2007.05.06/05/07. 5,02.000001,Jun.04"
218             (date->string (make-date 1000 2 3 4 5 6 2007 -7200)
219                                       "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H"))))
220
221(define-s19-test! "string->date conversions"
222  (lambda ()
223    (equal? (make-date 0 53 4 0 19 10 2006 (local-timezone-locale))
224            (string->date "2006/10/19 00:04:53" "~Y/~m/~d ~H:~M:~S"))))
225
226(define-s19-test! "date<->julian-day conversions"
227  (lambda ()
228   (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
229     (and (tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))
230          (= 365
231             (- (date->julian-day (make-date 0 0 0 0 1 1 2004 0))
232                (date->julian-day (make-date 0 0 0 0 1 1 2003 0))))))))
233
234(define-s19-test! "date->modified-julian-day conversions"
235  (lambda ()
236    (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
237      (and (tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))
238           (= 365
239              (- (date->modified-julian-day (make-date 0 0 0 0 1 1 2004 0))
240                 (date->modified-julian-day (make-date 0 0 0 0 1 1 2003 0))))))))
241
242(define-s19-test! "Time -> Date"
243  (lambda ()
244    (time->date (current-time))))
245
246(define-s19-test! "date-year-day [2.5 bad argument type for car]"
247  (lambda ()
248    (= 1 (date-year-day (make-date 0 0 0 0 1 1 2007 0)))))
249
250(define-s19-test! "~1 date->string [2.5 ISO-8601 conversion]"
251  (lambda ()
252    (equal? "2007-01-01" (date->string (string->date "2007-01-01" "~Y-~m-~d") "~1"))))
253
254(define-s19-test! "milliseconds->time [2.6.1 was using NS/S for conversion!]"
255  (lambda ()
256    (let ([tim (milliseconds->time 10000)])
257      (and (= 10 (time-second tim))
258           (= 0 (time-nanosecond tim))))))
259
260(define-s19-test! "Only one minute [2.6.1 current-date w/o tz-locale was doing dst conversion!]"
261  (lambda ()
262    (let ([lst
263            (delete-duplicates
264              (fold
265                (lambda (n acc)
266                  (cons (date-minute (current-date)) acc))
267                '()
268                ;This number needs to be low enough that the fold completes
269                ;in sub-minute time (easy to achieve).
270                (iota 2000)))])
271      (= 1 (length lst)))))
272
273(define-s19-test! "Conversion"
274  (lambda ()
275   
276    (define (vector->date1 vec)
277      (make-date
278        0 0 0 0
279        (vector-ref vec 2)
280        (vector-ref vec 1)
281        (vector-ref vec 0)
282        0))
283   
284    (define (vector->date2 vec)
285      (string->date
286        (format "~4,48D~2,48D~2,48DZ" ; ZULU timezone!
287                (vector-ref vec 0)
288                (vector-ref vec 1)
289                (vector-ref vec 2))
290        "~Y~m~d~z"))
291   
292    (define (to-time obj ->date)
293      (cond
294        ((time? obj)   obj)
295        ((date? obj)   (date->time-utc obj))
296        ((vector? obj) (date->time-utc (->date obj)))))
297   
298    (define (distance-of-time ->date from to)
299      (let* ((from-time (to-time from ->date))
300             (to-time (to-time to ->date))
301             (diff (time-difference from-time to-time))
302             (distance-in-seconds (time-second diff)))
303        distance-in-seconds))
304   
305    (define vec1 (vector 2006 12 21))
306    (define vec2 (vector 2006 12 19))
307    (define vec3 (vector 2006 12 20))
308   
309    (define tod (current-date))
310
311    (let ([d1-1 (distance-of-time vector->date1 vec1 tod)]
312          [d1-2 (distance-of-time vector->date1 vec1 vec2)]
313          [d1-3 (distance-of-time vector->date1 vec3 tod)]
314          [d2-1 (distance-of-time vector->date2 vec1 tod)]
315          [d2-2 (distance-of-time vector->date2 vec1 vec2)]
316          [d2-3 (distance-of-time vector->date2 vec3 tod)])
317      (and (= d1-1 d2-1) (= d1-2 d2-2) (= d1-3 d2-3)))))
318
319(define-s19-test! "date-week-number"
320  (lambda ()
321    (and (eqv? 0 (date-week-number (make-date 0 0 0 0 1 1 2007 0) 0))
322         (eqv? 51 (date-week-number (make-date 0 0 0 0 27 12 2006 0) 1)))))
323
324(define-s19-test! "date-week-day"
325  (lambda ()
326    (and (eqv? 1 (date-week-day (make-date 0 0 0 0 1 1 2007 0)))
327         (eqv? 3 (date-week-day (make-date 0 0 0 0 27 12 2006 0))))))
328
329; Duration
330; Time Aritmetic (+ - * /)
331; Date Comparision
332; Date Aritmetic
333; Time Period
334
335;;
336
337(begin (newline) (run-s19-tests #t))
Note: See TracBrowser for help on using the repository browser.