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

  1;;;; scrutiny-tests.scm
  2
  3(define (a)
  4  (define (b)
  5    (define (c)
  6      (let ((x (+ 3 4)))
  7	(if x 1 2)))))			; expected boolean but got number in conditional
  8
  9(define (b)
 10  (let ((x #t))
 11    (if x 1 2)))			; #t is always true
 12
 13(define (foo x)
 14  (if x 				; branches return differing number of results
 15      (values 1 2)
 16      (values 1 2 (+ (+ (+ (+  3)))))))
 17
 18(let ((bar +))
 19  (bar 3 'a))				; expected number, got symbol
 20
 21(string?)				; expected 1 argument, got 0
 22
 23(print (values 1 2))			; expected 1 result, got 2
 24(print (values))			; expected 1 result, got 0
 25
 26(let ((x 100))
 27  (x))					; expected procedure, got fixnum
 28
 29(print (+ 'a 'b))			; expected 2 numbers, but got symbols
 30
 31(set! car 33)				; 33 does not match type of car
 32
 33((values 1 2))				; expected procedure, got fixnum (canonicalizes to 1 result)
 34
 35; this should *not* signal a warning:
 36(define (test-values x)
 37  (define (fail) (error "failed"))
 38  (if x
 39      (values 42 43)
 40      (fail)))
 41
 42; same case, but nested
 43(define (test-values2 x y)
 44  (define (fail) (error "failed"))
 45  (if x
 46      (values 42 43)
 47      (if y (values 99 100) (fail))))
 48
 49(define (foo)
 50  (define (bar) (if foo 1))		; should not warn (local)
 51  (for-each void '(1 2 3))		; should not warn (self-call)
 52  (if foo 2)				; not in tail position
 53  (if bar 3))				; should warn
 54
 55;; noreturn conditional branch enforces "number" on x
 56(define (foo2 x)
 57  (if (string? x) (error "foo") (+ x 3))
 58  (string-append x "abc"))
 59
 60;; implicit declaration of foo3
 61(declare (hide foo3))
 62
 63(define (foo3 x)
 64  (string-append x "abc"))
 65
 66(foo3 99)
 67
 68;; predicate
 69(define (foo4 x)
 70  (if (string? x)
 71      (+ x 1)
 72      (+ x 2)))				; ok
 73
 74;; enforcement
 75(define (foo5 x)
 76  (string-append x "abc")
 77  (+ x 3))
 78
 79;; aliasing
 80(define (foo6 x)
 81  (let ((y x))
 82    (string-append x "abc")
 83    (+ x 3)))				;XXX (+ y 3) does not work yet
 84
 85;; user-defined predicate
 86(: foo7 (* -> boolean : string))
 87(define (foo7 x) (string? x))
 88
 89(when (foo7 x)
 90  (+ x 1))				; will warn about "x" being a string
 91
 92;; declared procedure types are enforcing
 93(define-type s2s (string -> symbol))
 94
 95(: foo8 s2s)
 96(define (foo8 x) (string->symbol x))
 97(: foo9 s2s)
 98(declare (enforce-argument-types foo9))
 99(define (foo9 x) (string->symbol x))
100
101(define (foo10 x)
102  (foo8 x)
103  (+ x 1)			; foo8 does not enforce x (no warning)
104  (foo9 x)			; + enforces number on x
105  (+ x 1))			; foo9 does enforce
106
107;; trigger warnings for incompatible types in "the" forms
108(define (foo10 x)
109  (string-append (the pair (substring x 0 10))) ; 1
110  (the * (values 1 2))				; 1 + 2
111  (the * (values))				; 3
112  (the fixnum (* x y)))				; nothing (but warns about "x" being string)
113
114
115;; Reported by Joerg Wittenberger:
116;
117; - assignment inside first conditional does not invalidate blist
118;;  entries for "ins"/"del" in outer flow.
119
120(define (write-blob-to-sql sql identifier last blob c-c)
121 (define ins '())
122 (define del '())
123 (if (vector? blob)
124     (begin
125	(set! ins (vector-ref blob 1))
126	(set! del (vector-ref blob 2))
127	(set! blob (vector-ref blob 0))))
128 (if (or (pair? ins)
129	 (pair? del))
130     (<handle-ins-and-del>))
131 (<do-some-more>))
132
133;; Checking whether reported line numbers inside modules are correct
134(module foo (blabla)
135  (import scheme)
136  (define (blabla)
137    (+ 1 'x)))
138
139;; Reported by megane in #884:
140;;
141;; Custom types defined in modules need to be resolved during canonicalization
142(module bar ()
143  (import scheme chicken.type)
144  (define-type footype string)
145  (the footype "bar"))
146
147;; Record type tags with module namespaces should not warn (#1513)
148(module foo *
149  (import (scheme) (chicken base) (chicken type))
150  (: make-foo (string --> (struct foo)))
151  (define-record foo bar))
152
153(: deprecated-procedure deprecated)
154(define (deprecated-procedure x) (+ x x))
155(deprecated-procedure 1)
156
157(: another-deprecated-procedure (deprecated replacement-procedure))
158(define (another-deprecated-procedure x) (+ x x))
159(another-deprecated-procedure 2)
160
161;; Needed to use "over-all-instantiations" or matching "vector"/"list" type
162;; with "vector-of"/"list-of" type (reported by megane)
163(: apply1 (forall (a b) (procedure ((procedure (#!rest a) b) (list-of a)) b)))
164
165(define (apply1 f args)
166  (apply f args))
167
168(apply1 + (list 'a 2 3)) ; <- no type warning (#948)
169(apply1 + (cons 'a (cons 2 (cons 3 '())))) ; <- same here (#952)
170
171;; multiple-value return syntax
172(: mv (-> . *))
173(: mv (procedure () . *))
174
175;; procedures from the type environment should still enforce, etc.
176(let ((x (the (or fixnum string) _))
177      (f (the (forall (a)
178                (a -> (-> a)))
179              (lambda (a)
180                (lambda () a)))))
181  (((f +)) x)  ; (or fixnum string) -> fixnum
182  (fixnum? x)) ; should report
183
184;; typeset reduction
185
186(: char-or-string? (* -> boolean : (or char string)))
187
188(let ((x _))
189  (if (char-or-string? x)
190      (symbol? x)   ; should report with x = (or char string)
191      (string? x))) ; should report with x = (not (or char string))
192
193(let ((x (the fixnum _)))
194  (if (char-or-string? x)
195      (symbol? x)   ; should report with x = (or char string)
196      (string? x))) ; should report with x = fixnum
197
198(let ((x (the (or char symbol) _)))
199  (if (char-or-string? x)
200      (symbol? x)   ; should report with x = char
201      (string? x))) ; should report with x = symbol
202
203(let ((x (the (or char symbol string) _)))
204  (if (char-or-string? x)
205      (symbol? x)   ; should report with x = (or char string)
206      (string? x))) ; should report with x = symbol
207
208;; list- and pair-type argument matching
209
210(let ((f (the (pair -> *) _))) (f (list)))        ; warning
211(let ((f (the (pair -> *) _))) (f (make-list x))) ; no warning
212(let ((f (the (null -> *) _))) (f (list 1)))      ; warning
213(let ((f (the (null -> *) _))) (f (make-list x))) ; no warning
214(let ((f (the (list -> *) _))) (f (cons 1 2)))    ; warning
215(let ((f (the (list -> *) _))) (f (cons 1 x)))    ; no warning
216
217
218;; Indexing into vectors or lists of known size.
219(let ((v1 (vector 'a 'b 'c)))
220  (define (vector-ref-warn1) (vector-ref v1 -1))
221  ;; After the first expression, v1's type is smashed to (vector * * *)!
222  (define (vector-ref-warn2) (vector-ref v1 3))
223  (define (vector-ref-warn3) (vector-ref v1 4))
224  (define (vector-ref-nowarn1) (vector-ref v1 0))
225  (define (vector-ref-nowarn2) (vector-ref v1 2))
226  (define (vector-ref-standard-warn1) (vector-ref v1 'bad))
227  (define (vector-set!-warn1) (vector-set! v1 -1 'whatever))
228  (define (vector-set!-warn2) (vector-set! v1 3 'whatever))
229  (define (vector-set!-warn3) (vector-set! v1 4 'whatever))
230  (define (vector-set!-nowarn1) (vector-set! v1 0 'whatever))
231  (define (vector-set!-nowarn2) (vector-set! v1 2 'whatever))
232  (define (vector-set!-standard-warn1) (vector-set! v1 'bad 'whatever)))
233
234;; The specific list type will be smashed to just "(or pair null)"
235;; after the first operation.  This is why the let is repeated;
236;; otherwise we won't get the warnings for subsequent references.
237(let ((l1 (list 'a 'b 'c)))
238  (define (list-ref-warn1) (list-ref l1 -1)))
239;; This warns regardless of not knowing the length of the list
240(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
241  (define (list-ref-warn2) (list-ref l2 -1)))
242;; Not knowing the length of a "list-of" is not an issue here
243(let ((l3 (the (list-of symbol) '(x y z))))
244  (define (list-ref-warn3) (list-ref l3 -1)))
245(let ((l1 (list 'a 'b 'c)))
246  (define (list-ref-warn4) (list-ref l1 3)))
247;; This can't warn: it strictly doesn't know the length of the list.
248;; The eval could return a list of length >= 1!
249#;(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
250  (define (list-ref-warn5) (list-ref l2 3)))
251(let ((l1 (list 'a 'b 'c)))
252  (define (list-ref-warn5) (list-ref l1 4)))
253;; Same as above
254#;(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
255  (define (list-ref-warn6) (list-ref l2 4)))
256
257;; We add the second check to ensure that we don't give false warnings
258;; for smashed types, because we don't know the original size.
259(let ((l1 (list 'a 'b 'c)))
260  (define (list-ref-nowarn1) (list-ref l1 0))
261  (define (list-ref-nowarn2) (list-ref l1 0)))
262(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
263  (define (list-ref-nowarn3) (list-ref l2 0))
264  (define (list-ref-nowarn4) (list-ref l2 0)))
265(let ((l1 (list 'a 'b 'c)))
266  (define (list-ref-nowarn5) (list-ref l1 2))
267  (define (list-ref-nowarn6) (list-ref l1 2)))
268(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
269  (define (list-ref-nowarn7) (list-ref l2 2))
270  (define (list-ref-nowarn8) (list-ref l2 2)))
271;; Verify that we don't give bogus warnings, like mentioned above.
272(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
273  (define (list-ref-nowarn9) (list-ref l2 5)))
274;; We don't know the length of a "list-of", so we can't warn
275(let ((l3 (the (list-of symbol) '(x y z))))
276  (define (list-ref-nowarn10) (list-ref l3 100)))
277
278;; The second check here should still give a warning, this has
279;; nothing to do with component smashing.
280(let ((l1 (list 'a 'b 'c)))
281  (define (list-ref-standard-warn1) (list-ref l1 'bad))
282  (define (list-ref-standard-warn2) (list-ref l1 'bad)))
283(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
284  (define (list-ref-standard-warn3) (list-ref l2 'bad))
285  (define (list-ref-standard-warn4) (list-ref l2 'bad)))
286
287;; Test type preservation of list-ref
288(let ((l1 (list 'a 'b 'c)))
289  (define (list-ref-type-warn1) (add1 (list-ref l1 1))))
290(let ((l2 (cons 'a (cons 'b (cons 'c (eval '(list)))))))
291  (define (list-ref-type-warn2) (add1 (list-ref l2 1))))
292;; This is handled by the list-ref entry in types.db, *not* the
293;; special-cased code.
294(let ((l3 (the (list-of symbol) '(a b c))))
295  (define (list-ref-type-warn3) (add1 (list-ref l3 1))))
296
297;; Sanity check
298(let ((l1 (list 1 2 3)))
299  (define (list-ref-type-nowarn1) (add1 (list-ref l1 1))))
300(let ((l2 (cons 1 (cons 2 (cons 3 (eval '(list)))))))
301  (define (list-ref-type-nowarn2) (add1 (list-ref l2 1))))
302(let ((l3 (the (list-of fixnum) '(1 2 3))))
303  (define (list-ref-type-nowarn3) (add1 (list-ref l3 1))))
304
305;; Test type preservation of append (TODO: decouple from list-ref)
306(let ((l1 (append (list 'x 'y) (list 1 2 (eval '(list))))))
307  (define (append-result-type-warn1) (add1 (list-ref l1 1))))
308;; This currently doesn't warn because pair types aren't joined yet
309#;(let ((l2 (append (cons 'x (cons 'y (eval '(list)))) (list 'x 'y))))
310  (define (append-result-type-warn2) (add1 (list-ref l2 1))))
311(let ((l3 (append (the (list-of symbol) '(x y)) '(a b))))
312  (define (append-result-type-warn2) (add1 (list-ref l3 3))))
313
314(let ((l1 (append (list 1 2) (list 'x 'y (eval '(list))))))
315  (define (append-result-type-nowarn1) (add1 (list-ref l1 1))))
316(let ((l2 (append (cons 1 (cons 2 (eval '(list)))) (list 'x))))
317  (define (append-result-type-nowarn2) (add1 (list-ref l2 1))))
318(let ((l3 (append (the (list-of fixnum) '(1 2)) '(x y))))
319  (define (append-result-type-nowarn3) (add1 (list-ref l3 1))))
320
321;; Check the trail is restored from the combined typeenv
322(compiler-typecase (list 2 'a)
323  ((forall (x) (list x x)) 1)
324  (else #t))