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)) 325