forked from scheme-requests-for-implementation/srfi-19
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathsrfi-19-test-suite.scm
210 lines (190 loc) · 7.22 KB
/
srfi-19-test-suite.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
;;; simple test procedures
(define s19-tests (list))
(define (define-s19-test! name thunk)
(let ((name (if (symbol? name) name (string->symbol name)))
(pr (assoc name s19-tests)))
(if pr
(set-cdr! pr thunk)
(set! s19-tests (append s19-tests (list (cons name thunk)))))))
(define (run-s19-test name thunk verbose)
(if verbose (begin (display ";;; Running ") (display name)))
(let ((result (thunk)))
(if verbose (begin (display ": ") (display (not (not result))) (newline)))
result))
(define (run-s19-tests . verbose)
(let ((runs 0) (goods 0) (bads 0) (verbose (if (cdr verbose) (cdr verbose) #f)))
(for-each (lambda (pr)
(set! runs (+ runs 1))
(if (run-s19-test (car pr) (cdr pr) verbose)
(set! goods (+ goods 1))
(set! bads (+ bads 1))))
s19-tests)
(if verbose
(begin
(display ";;; Results: Runs: ")
(display runs)
(display "; Goods: ")
(display goods)
(display "; Bads: ")
(display bads)
(if (> runs 0)
(begin
(display "; Pass rate: ")
(display (/ goods runs)))
(display "; No tests."))
(newline)))
(values runs goods bads)))
(set! s19-tests (list))
(define-s19-test! "Creating time structures"
(lambda ()
(not (null? (list (current-time 'time-tai)
(current-time 'time-utc)
(current-time 'time-monotonic)
(current-time 'time-thread)
(current-time 'time-process))))))
(define-s19-test! "Testing time resolutions"
(lambda ()
(not (null? (list (time-resolution 'time-tai)
(time-resolution 'time-utc)
(time-resolution 'time-monotonic)
(time-resolution 'time-thread)
(time-resolution 'time-process))))))
(define-s19-test! "Time comparisons (time=?, etc.)"
(lambda ()
(let ((t1 (make-time 'time-utc 0 1))
(t2 (make-time 'time-utc 0 1))
(t3 (make-time 'time-utc 0 2))
(t11 (make-time 'time-utc 1001 1))
(t12 (make-time 'time-utc 1001 1))
(t13 (make-time 'time-utc 1001 2))
)
(and (time=? t1 t2)
(time>? t3 t2)
(time<? t2 t3)
(time>=? t1 t2)
(time>=? t3 t2)
(time<=? t1 t2)
(time<=? t2 t3)
(time=? t11 t12)
(time>? t13 t12)
(time<? t12 t13)
(time>=? t11 t12)
(time>=? t13 t12)
(time<=? t11 t12)
(time<=? t12 t13)
))))
(define-s19-test! "Time difference"
(lambda ()
(let ((t1 (make-time 'time-utc 0 3000))
(t2 (make-time 'time-utc 0 1000))
(t3 (make-time 'time-duration 0 2000))
(t4 (make-time 'time-duration 0 -2000)))
(and
(time=? t3 (time-difference t1 t2))
(time=? t4 (time-difference t2 t1))))))
(define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
(let* (;; right on the edge they should be the same
(utc-basic (make-time 'time-utc 0 utc))
(tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
(utc->tai-basic (time-utc->time-tai utc-basic))
(tai->utc-basic (time-tai->time-utc tai-basic))
;; a second before they should be the old diff
(utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
(tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
(utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
(tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
;; a second later they should be the new diff
(utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
(tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
(utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
(tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
;; ok, let's move the clock half a month or so plus half a second
(shy (* 15 24 60 60))
(hs (/ (expt 10 9) 2))
;; a second later they should be the new diff
(utc-basic+2 (make-time 'time-utc hs (+ utc shy)))
(tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
(utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
(tai->utc-basic+2 (time-tai->time-utc tai-basic+2))
)
(and (time=? utc-basic tai->utc-basic)
(time=? tai-basic utc->tai-basic)
(time=? utc-basic-1 tai->utc-basic-1)
(time=? tai-basic-1 utc->tai-basic-1)
(time=? utc-basic+1 tai->utc-basic+1)
(time=? tai-basic+1 utc->tai-basic+1)
(time=? utc-basic+2 tai->utc-basic+2)
(time=? tai-basic+2 utc->tai-basic+2)
)))
(define-s19-test! "TAI-UTC Conversions"
(lambda ()
(and
(test-one-utc-tai-edge 915148800 32 31)
(test-one-utc-tai-edge 867715200 31 30)
(test-one-utc-tai-edge 820454400 30 29)
(test-one-utc-tai-edge 773020800 29 28)
(test-one-utc-tai-edge 741484800 28 27)
(test-one-utc-tai-edge 709948800 27 26)
(test-one-utc-tai-edge 662688000 26 25)
(test-one-utc-tai-edge 631152000 25 24)
(test-one-utc-tai-edge 567993600 24 23)
(test-one-utc-tai-edge 489024000 23 22)
(test-one-utc-tai-edge 425865600 22 21)
(test-one-utc-tai-edge 394329600 21 20)
(test-one-utc-tai-edge 362793600 20 19)
(test-one-utc-tai-edge 315532800 19 18)
(test-one-utc-tai-edge 283996800 18 17)
(test-one-utc-tai-edge 252460800 17 16)
(test-one-utc-tai-edge 220924800 16 15)
(test-one-utc-tai-edge 189302400 15 14)
(test-one-utc-tai-edge 157766400 14 13)
(test-one-utc-tai-edge 126230400 13 12)
(test-one-utc-tai-edge 94694400 12 11)
(test-one-utc-tai-edge 78796800 11 10)
(test-one-utc-tai-edge 63072000 10 0)
(test-one-utc-tai-edge 0 0 0) ;; at the epoch
(test-one-utc-tai-edge 10 0 0) ;; close to it ...
(test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
)))
(define (tm:date= d1 d2)
(and (= (date-year d1) (date-year d2))
(= (date-month d1) (date-month d2))
(= (date-day d1) (date-day d2))
(= (date-hour d1) (date-hour d2))
(= (date-second d1) (date-second d2))
(= (date-nanosecond d1) (date-nanosecond d2))
(= (date-zone-offset d1) (date-zone-offset d2))))
(define-s19-test! "TAI-Date Conversions"
(lambda ()
(and
(tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
(make-date 0 58 59 23 31 12 1998 0))
(tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
(make-date 0 59 59 23 31 12 1998 0))
(tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
(make-date 0 60 59 23 31 12 1998 0))
(tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
(make-date 0 0 0 0 1 1 1999 0)))))
(define-s19-test! "Date-UTC Conversions"
(lambda ()
(and
(time=? (make-time time-utc 0 (- 915148800 2))
(date->time-utc (make-date 0 58 59 23 31 12 1998 0)))
(time=? (make-time time-utc 0 (- 915148800 1))
(date->time-utc (make-date 0 59 59 23 31 12 1998 0)))
;; yes, I think this is acutally right.
(time=? (make-time time-utc 0 (- 915148800 0))
(date->time-utc (make-date 0 60 59 23 31 12 1998 0)))
(time=? (make-time time-utc 0 (- 915148800 0))
(date->time-utc (make-date 0 0 0 0 1 1 1999 0)))
(time=? (make-time time-utc 0 (+ 915148800 1))
(date->time-utc (make-date 0 1 0 0 1 1 1999 0))))))
(define-s19-test! "TZ Offset conversions"
(lambda ()
(let ((ct-utc (make-time time-utc 6320000 1045944859))
(ct-tai (make-time time-tai 6320000 1045944891))
(cd (make-date 6320000 19 14 15 22 2 2003 -18000)))
(and
(time=? ct-utc (date->time-utc cd))
(time=? ct-tai (date->time-tai cd))))))
(begin (newline) (run-s19-tests #t))