~ chicken-core (chicken-5) /tests/scrutinizer-tests.scm

  1;;; scrutinizer unit tests
  2
  3(import-for-syntax
  4  (chicken format)
  5  (chicken compiler scrutinizer))
  6
  7(define-for-syntax success #t)
  8
  9(define-syntax test
 10  (er-macro-transformer
 11   (lambda (expr rename _)
 12     (define extra-fail-info '())
 13     (define (add-fail-info msg)
 14       (set! extra-fail-info (cons (string-append "  " msg) extra-fail-info))
 15       #f)
 16     (define pass
 17       (let loop ((e (cadr expr)))
 18         (case (car e)
 19           ;; invert test
 20           ((not) (not (loop (cadr e))))
 21           ;; subtype or type equality
 22           ((<=)  (and (type<=? (cadr e) (caddr e))
 23                       (match-types (caddr e) (cadr e))))
 24           ;; subtype
 25           ((<)   (and (or (type<=? (cadr e) (caddr e))
 26			   (add-fail-info "<= returned #f"))
 27		       (or (match-types (caddr e) (cadr e))
 28			   (add-fail-info ">= returned #f"))
 29                       (or (not (type<=? (caddr e) (cadr e)))
 30			   (add-fail-info "not >= returned #f"))))
 31           ;; type equality
 32           ((=)   (and (or (type<=? (cadr e) (caddr e))
 33			   (add-fail-info "<= failed"))
 34                       (or (type<=? (caddr e) (cadr e))
 35			   (add-fail-info ">= failed"))))
 36           ;; fuzzy match (both directions)
 37           ((?)   (and (match-types (cadr e) (caddr e))
 38                       (match-types (caddr e) (cadr e))))
 39           ;; fuzzy non-match (both directions)
 40           ((!)   (and (or (not (match-types (cadr e) (caddr e)))
 41			   (add-fail-info ">= was true"))
 42                       (or (not (match-types (caddr e) (cadr e)))
 43			   (add-fail-info "<= was true"))))
 44           ;; strict non-match (both directions)
 45           ((><)  (and (not (type<=? (cadr e) (caddr e)))
 46                       (not (type<=? (caddr e) (cadr e)))))
 47           ;; A refined with B gives C
 48           ((~>)  (let ((t (refine-types (cadr e) (caddr e))))
 49		    (or (equal? t (cadddr e))
 50			(add-fail-info
 51			 (format "Refined to `~a', but expected `~a'" t (cadddr e)) )))))))
 52     (printf "[~a] ~a~n" (if pass " OK " "FAIL") (cadr expr))
 53     (unless pass
 54       (for-each print extra-fail-info))
 55     (when (not pass) (set! success #f))
 56     (rename '(void)))))
 57
 58;;; wildcards
 59
 60(test (= * *))
 61(test (< x *))
 62
 63;;; structs
 64
 65(test (= (struct x) (struct x)))
 66(test (! (struct x) (struct y)))
 67
 68;;; undefined
 69
 70(test (= undefined undefined))
 71(test (< undefined *))
 72
 73;;; noreturn
 74
 75(test (= noreturn noreturn))
 76(test (< noreturn *))
 77(test (! undefined noreturn))
 78
 79;;; booleans
 80
 81(test (= boolean boolean))
 82(test (< true boolean))
 83(test (< false boolean))
 84(test (= (or true false) boolean))
 85
 86;;; numbers
 87
 88(test (= number number))
 89(test (< fixnum number))
 90(test (< float number))
 91(test (< bignum number))
 92(test (< ratnum number))
 93(test (< cplxnum number))
 94(test (< integer number))
 95(test (= (or fixnum float bignum ratnum cplxnum) number))
 96
 97(test (= integer integer))
 98(test (< fixnum integer))
 99(test (< bignum integer))
100(test (not (<= float integer)))
101(test (not (<= ratnum integer)))
102(test (not (<= cplxnum integer)))
103(test (= (or fixnum bignum) integer))
104
105;;; vectors
106
107(test (= vector vector))
108(test (= vector (vector-of *)))
109(test (< (vector-of x) (vector-of *)))
110
111(test (= (vector *) (vector *)))
112(test (= (vector x) (vector x)))
113(test (< (vector x) (vector *)))
114(test (< (vector *) (vector-of *)))
115(test (< (vector x) (vector-of *)))
116(test (< (vector x) (vector-of x)))
117
118(test (?  (vector *) (vector-of x)))
119(test (>< (vector *) (vector-of x)))
120
121(test (>< (vector *) (vector * *)))
122(test (>< (vector x) (vector * *)))
123(test (>< (vector *) (vector x x)))
124(test (>< (vector x) (vector x x)))
125
126;;; pairs
127
128(test (= pair pair))
129(test (= pair (pair * *)))
130(test (< (pair x *) pair))
131(test (< (pair * x) pair))
132(test (< (pair x x) pair))
133
134;;; lists
135
136(test (= null null))
137(test (? null list))
138(test (? null (list-of x)))
139(test (! null (list x)))
140(test (! null pair))
141
142(test (= list list))
143(test (= list (list-of *)))
144(test (< (list-of x) (list-of *)))
145
146(test (= (list *) (list *)))
147(test (= (list x) (list x)))
148(test (< (list x) (list *)))
149(test (< (list *) (list-of *)))
150(test (< (list x) (list-of *)))
151(test (< (list x) (list-of x)))
152
153(test (?  (list *) (list-of x)))
154(test (>< (list *) (list-of x)))
155
156(test (>< (list *) (list * *)))
157(test (>< (list x) (list * *)))
158(test (>< (list *) (list x x)))
159(test (>< (list x) (list x x)))
160
161(test (? (pair * *) (list-of *)))
162(test (? (pair x *) (list-of *)))
163(test (! (pair * x) (list-of *)))
164(test (! (pair x x) (list-of *)))
165(test (? (pair * *) (list-of x)))
166(test (? (pair x *) (list-of x)))
167(test (! (pair * x) (list-of x)))
168(test (! (pair x x) (list-of x)))
169
170;;; ports
171
172(test (= port port))
173(test (= (refine (input) port) (refine (input) port)))
174(test (= (refine (input output) port) (refine (input output) port)))
175(test (= (refine (output) port) (refine (output) port)))
176
177(test (< (refine (input) port) port))
178(test (< (refine (input output) port) port))
179(test (< (refine (output) port) port))
180(test (< (refine (input output) port) (refine (input) port)))
181(test (< (refine (input output) port) (refine (output) port)))
182(test (? (refine (input) port) (refine (output) port)))
183
184;;; unions
185
186(test (< x (or x y)))
187(test (< y (or x y)))
188
189(test (=  (or x number) (or x number)))
190(test (<  (or x number) (or x number string)))
191(test (>< (or x number) (or y string)))
192
193;;; negative types
194
195(test (< (not x) *))
196(test (! (not x) x))
197
198(test (< x (not y)))
199(test (< x (not (not x))))
200(test (< x (not (not (not y)))))
201
202(test (< x (or (not x) x)))
203(test (< x (or (not x) (not y))))
204
205(test (! x (not x)))
206(test (! x (not (not y))))
207(test (! x (not (not (not x)))))
208(test (! x (not (or x y))))
209(test (! x (or (not x) y)))
210(test (! x (not (not (not x)))))
211
212(test (?  (not x) (not y)))
213(test (?  (not x) (or x y)))
214(test (?  (not x) (or (not x) x)))
215(test (?  (not x) (or (not y) x)))
216(test (?  (not x) (or (not x) (not y))))
217(test (>< (not x) (not y)))
218(test (>< (not x) (or x y)))
219(test (>< (not x) (or (not x) x)))
220(test (>< (not x) (or (not y) x)))
221(test (>< (not x) (or (not x) (not y))))
222
223(test (< (or (not x) y) (not x)))
224(test (< (not (or x y)) (not x)))
225
226;;; negative wildcards (a bit weird...)
227
228(test (< (not *) *))
229(test (< (not (not *)) *))
230(test (< (not (not (not *))) *))
231
232(test (! (not *) x))
233(test (< (not *) (not x)))
234
235;;; procedures
236
237(test (= (procedure ()) (procedure ())))
238(test (= (procedure (x)) (procedure (x))))
239(test (= (procedure (#!rest x)) (procedure (#!rest x))))
240
241(test (= (procedure ()) (procedure ())))
242(test (= (procedure () x) (procedure () x)))
243;; FIXME
244;(test (= (procedure () . x) (procedure () . x)))
245
246(test (>< (procedure (x)) (procedure (y))))
247(test (>< (procedure () x) (procedure () y)))
248
249(test (? (procedure (x)) (procedure (*))))
250(test (? (procedure () x) (procedure () *)))
251
252(test (! (procedure (x)) (procedure ())))
253(test (! (procedure (x)) (procedure (x y))))
254(test (? (procedure (x)) (procedure (x #!rest y))))
255
256(test (! (procedure () x) (procedure ())))
257(test (! (procedure () x) (procedure () x y)))
258;; s.a.
259;(test (? (procedure () x) (procedure () x . y)))
260
261;;; refinements
262
263(test (= (refine (a) x)   (refine (a) x)))
264(test (< (refine (a b) x) (refine (a) x)))
265(test (= (refine (a b) x) (refine (a b) x)))
266
267(test (?  (refine (a) x) (refine (b) x)))
268(test (>< (refine (a) x) (refine (b) x)))
269
270(test (~> x y y))
271(test (~> x (or x y) x))
272(test (~> (or x y) x x))
273(test (~> (or x y) (or y z) y))
274
275(test (~> * (refine (a) x) (refine (a) x)))
276(test (~> (refine (a) *) x (refine (a) x)))
277(test (~> x (refine (a) *) (refine (a) x)))
278(test (~> (refine (a) x) * (refine (a) x)))
279(test (~> (refine (a) x) (refine (b) *) (refine (a b) x)))
280(test (~> (refine (a) x) (refine (b) *) (refine (a b) x)))
281
282(test (~> (refine (a) x) y y))
283(test (~> x (refine (a) y) (refine (a) y)))
284(test (~> (refine (a) x) (refine (b) y) (refine (b) y)))
285
286(test (~> (list fixnum number)
287          (list number fixnum)
288          (list fixnum fixnum)))
289(test (~> (vector x)
290          (vector (refine (a) x))
291          (vector (refine (a) x))))
292(test (~> (list x)
293          (list (refine (a) x))
294          (list (refine (a) x))))
295(test (~> (list x (list x))
296          (list (refine (a) *) (list (refine (b) *)))
297          (list (refine (a) x) (list (refine (b) x)))))
298(test (~> (list * (list *))
299          (list (refine (a) x) (list (refine (b) x)))
300          (list (refine (a) x) (list (refine (b) x)))))
301(test (~> (list (refine (a) x))
302          (refine (a) (list (refine (b) x)))
303          (refine (a) (list (refine (a b) x)))))
304(test (~> (list (refine (a) x))
305          (refine (a) (list (refine (b) y)))
306          (refine (a) (list (refine (b) y)))))
307(test (~> (or pair null) list list))
308
309(begin-for-syntax
310  (when (not success) (exit 1)))