1;;; cptypes.ms 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16(define-syntax cptypes-equivalent-expansion? 17 (syntax-rules () 18 [(_ x y) 19 (equivalent-expansion? 20 (parameterize ([enable-cp0 #t] 21 [#%$suppress-primitive-inlining #f] 22 #;[optimize-level (max (optimize-level) 2)]) 23 (expand/optimize x)) 24 (parameterize ([enable-cp0 #t] 25 [#%$suppress-primitive-inlining #f] 26 #;[optimize-level (max (optimize-level) 2)]) 27 (expand/optimize y)))])) 28 29(define-syntax cptypes/once-equivalent-expansion? 30 ; Replace the default value of run-cp0 with a version that calls 31 ; cp0 only once instead of twice. 32 ; This is useful to test some reductions that are shared with cp0 33 ; or that should be executed in a single pass. 34 (syntax-rules () 35 [(_ x y) 36 (equivalent-expansion? 37 (parameterize ([run-cp0 (lambda (cp0 c) (cp0 c))] 38 [#%$suppress-primitive-inlining #f] 39 #;[optimize-level (max (optimize-level) 2)]) 40 (expand/optimize x)) 41 (parameterize ([run-cp0 (lambda (cp0 c) (#3%$cptypes c))] 42 [#%$suppress-primitive-inlining #f] 43 #;[optimize-level (max (optimize-level) 2)]) 44 (expand/optimize y)))])) 45 46(define-syntax cptypes/nocp0-equivalent-expansion? 47 ; When run-cp0 is call, use #3%$cptypes insted of the cp0 function provided. 48 ; This disables the reductions in cp0.ss, so it's posible to see 49 ; the isolated effect of the reduction in cptypes.ss. 50 (syntax-rules () 51 [(_ x y) 52 (equivalent-expansion? 53 (parameterize ([run-cp0 (lambda (cp0 c) (#3%$cptypes c))] 54 [#%$suppress-primitive-inlining #f] 55 #;[optimize-level (max (optimize-level) 2)]) 56 (expand/optimize x)) 57 (parameterize ([run-cp0 (lambda (cp0 c) (#3%$cptypes c))] 58 [#%$suppress-primitive-inlining #f] 59 #;[optimize-level (max (optimize-level) 2)]) 60 (expand/optimize y)))])) 61 62(mat cptypes-handcoded 63 (cptypes-equivalent-expansion? 64 '(vector? (vector)) ;actually reduced by folding, not cptypes 65 #t) 66 (cptypes-equivalent-expansion? 67 '(vector? (vector 1 2 3)) 68 #t) 69 (cptypes-equivalent-expansion? 70 '(vector? (box 1)) 71 #f) 72 (cptypes-equivalent-expansion? 73 '(box? (vector 1 2 3)) 74 #f) 75 (cptypes-equivalent-expansion? 76 '(box? (box 1)) 77 #t) 78 (cptypes-equivalent-expansion? 79 '(pair? (cons 1 2)) 80 #t) 81 (cptypes-equivalent-expansion? 82 '(pair? (list 1 2)) 83 #t) 84 (cptypes-equivalent-expansion? 85 '(pair? (list)) 86 #f) 87 (cptypes-equivalent-expansion? 88 '(eq? (newline) (void)) 89 '(begin (newline) #t)) 90 (cptypes-equivalent-expansion? 91 '(eq? (newline) 0) 92 '(begin (newline) #f)) 93 (cptypes-equivalent-expansion? 94 '(lambda (x) (vector-set! x 0 0) (vector? x)) 95 '(lambda (x) (vector-set! x 0 0) #t)) 96 (cptypes-equivalent-expansion? 97 '(lambda (x) (vector-set! x 0 0) (box? x)) 98 '(lambda (x) (vector-set! x 0 0) #f)) 99 (cptypes-equivalent-expansion? 100 '(lambda (x y) (vector-set! x 0 0) (set! y (vector? x))) 101 '(lambda (x y) (vector-set! x 0 0) (set! y #t))) 102 (cptypes-equivalent-expansion? 103 '(lambda (x y) (set! y (vector-ref x 0)) (list (vector? x) y)) 104 '(lambda (x y) (set! y (vector-ref x 0)) (list #t y))) 105 (cptypes-equivalent-expansion? 106 '(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list (vector? x) y y))) 107 '(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list #t y y)))) 108 (cptypes-equivalent-expansion? 109 '(lambda (x) (vector-set! x 0 0) (let ([y (vector? x)]) (list (random 7) y y))) 110 '(lambda (x) (vector-set! x 0 0) (let ([y #t]) (list (random 7) y y)))) 111 (cptypes-equivalent-expansion? 112 '(lambda (x) (let ([y (vector-ref x 0)]) (list (vector? x) y y))) 113 '(lambda (x) (let ([y (vector-ref x 0)]) (list #t y y)))) 114 (cptypes-equivalent-expansion? 115 '(lambda (x) (let ([y (vector-ref x 0)]) 116 (let ([z (vector? x)]) 117 (list y y z z)))) 118 '(lambda (x) (let ([y (vector-ref x 0)]) 119 (let ([z #t]) 120 (list y y z z))))) 121 (cptypes-equivalent-expansion? 122 '(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) (vector? x)) 123 '(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) #t)) 124 (cptypes-equivalent-expansion? 125 '(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) (vector? x)) 126 '(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) #t)) 127 (cptypes-equivalent-expansion? 128 '(let ([y (vector 1 2 3)]) (display (list (vector? y) y y))) 129 '(let ([y (vector 1 2 3)]) (display (list #t y y)))) 130 (cptypes-equivalent-expansion? 131 '(let ([y (vector 1 2 3)]) (display (list y y)) (vector? y)) 132 '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) 133 (cptypes-equivalent-expansion? 134 '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) y)) 135 '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) 136 (cptypes-equivalent-expansion? 137 '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6))) 138 '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) 139 (cptypes-equivalent-expansion? 140 '(lambda (x) (when (null? x) (display x))) 141 '(lambda (x) (when (null? x) (display '())))) 142 (cptypes-equivalent-expansion? 143 '(lambda (x) (when (vector? x) (eq? x 'vector?))) 144 '(lambda (x) (when (vector? x) #f))) 145 (cptypes-equivalent-expansion? 146 '(lambda (x) (when (vector? x) (pair? x))) 147 '(lambda (x) (when (vector? x) #f))) 148 (cptypes-equivalent-expansion? 149 '(lambda (x) (when (vector? x) (vector? x))) 150 '(lambda (x) (when (vector? x) #t))) 151 (cptypes-equivalent-expansion? 152 '(lambda (x) (when (procedure? x) (procedure? x))) 153 '(lambda (x) (when (procedure? x) #t))) 154 (cptypes-equivalent-expansion? 155 '(lambda (f) (f) (procedure? f)) 156 '(lambda (f) (f) #t)) 157 (cptypes-equivalent-expansion? 158 '(lambda (x) 159 (vector-set! x 0 0) 160 (let loop ([n 1000]) 161 (unless (zero? n) 162 (display (vector? x)) 163 (loop (- n 1))))) 164 '(lambda (x) 165 (vector-set! x 0 0) 166 (let loop ([n 1000]) 167 (unless (zero? n) 168 (display #t) 169 (loop (- n 1)))))) 170 (cptypes-equivalent-expansion? 171 '(lambda (x) 172 (let loop ([n 1000]) 173 (unless (zero? n) 174 (vector-set! x 0 n) 175 (loop (- n 1)))) 176 (vector? x)) 177 '(lambda (x) 178 (let loop ([n 1000]) 179 (unless (zero? n) 180 (vector-set! x 0 n) 181 (loop (- n 1)))) 182 (vector? x))) 183 (cptypes-equivalent-expansion? 184 '(begin (error 'who "msg") 1) ;could be reduced in cp0 185 '(begin (error 'who "msg") 2)) 186 (cptypes-equivalent-expansion? 187 '(lambda (x) (vector-set! x) 1) 188 '(lambda (x) (vector-set! x) 2)) 189 (cptypes-equivalent-expansion? 190 '(lambda (x) (#2%-) 1) 191 '(lambda (x) (#2%-) 2)) 192 (cptypes-equivalent-expansion? 193 '(lambda (x) (#2%make-vector x 0 7) 1) 194 '(lambda (x) (#2%make-vector x 0 7) 2)) 195 (cptypes-equivalent-expansion? 196 '(lambda (x) (vector-set! x 0 0) (set-box! x 0) 1) 197 '(lambda (x) (vector-set! x 0 0) (set-box! x 0) 2)) 198 (cptypes-equivalent-expansion? 199 '(lambda (x) (vector-set! (box 5) 0 0) 1) 200 '(lambda (x) (vector-set! (box 5) 0 0) 2)) 201 (cptypes-equivalent-expansion? 202 '(lambda (x) (#2%odd? x) (real? x)) 203 '(lambda (x) (#2%odd? x) #t)) 204 (cptypes-equivalent-expansion? 205 '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 1) 206 '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 2)) 207 (cptypes-equivalent-expansion? 208 '(lambda (x) (when (or (fixnum? x) (bignum? x)) (zero? x))) 209 '(lambda (x) (when (or (fixnum? x) (bignum? x)) (#3%eq? x 0)))) 210 (cptypes-equivalent-expansion? 211 '(lambda (x) (when (and (or (fixnum? x) (bignum? x)) (zero? x)) x)) 212 '(lambda (x) (when (and (or (fixnum? x) (bignum? x)) (zero? x)) 0))) 213 (cptypes-equivalent-expansion? 214 '(lambda (x) (when (fixnum? x) (zero? x))) 215 '(lambda (x) (when (fixnum? x) (#3%fxzero? x)))) 216 (cptypes-equivalent-expansion? 217 '(lambda (x) (when (and (fixnum? x) (zero? x)) x)) 218 '(lambda (x) (when (and (fixnum? x) (zero? x)) 0))) 219 (cptypes-equivalent-expansion? 220 '(lambda (x f) (when (list-assuming-immutable? x) (f x) (list-assuming-immutable? x))) 221 '(lambda (x f) (when (list-assuming-immutable? x) (f x) #t))) 222 (not (cptypes-equivalent-expansion? 223 '(lambda (x f) (when (list? x) (f x) (unless (list? x) 1))) 224 '(lambda (x f) (when (list? x) (f x) (unless (list? x) 2))))) 225 (cptypes-equivalent-expansion? 226 '(lambda (f) (define x '(1 2 3)) (f x) (list-assuming-immutable? x)) 227 '(lambda (f) (define x '(1 2 3)) (f x) #t)) 228 (cptypes-equivalent-expansion? 229 '(lambda () (define x '(1 2 3)) (pair? x)) 230 '(lambda () (define x '(1 2 3)) #t)) 231) 232 233(mat cptypes-type-if 234 (cptypes-equivalent-expansion? 235 '(lambda (x) (if (vector-ref x 0) (newline) (void)) (vector? x)) 236 '(lambda (x) (if (vector-ref x 0) (newline) (void)) #t)) 237 (cptypes-equivalent-expansion? 238 '(lambda (x) (if (vector-ref x 0) (vector? x) (void))) 239 '(lambda (x) (if (vector-ref x 0) #t (void)))) 240 (cptypes-equivalent-expansion? 241 '(lambda (x) (if (vector-ref x 0) (void) (vector? x))) 242 '(lambda (x) (if (vector-ref x 0) (void) #t))) 243 (cptypes-equivalent-expansion? 244 '(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) (vector? x)) 245 '(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) #t)) 246 (not (cptypes-equivalent-expansion? 247 '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) (vector? x)) 248 '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) #t))) 249 (not (cptypes-equivalent-expansion? 250 '(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) (vector? x)) 251 '(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) #t))) 252 (cptypes-equivalent-expansion? 253 '(lambda (x) (vector-set! x 0 0) (if x (newline) (void))) 254 '(lambda (x) (vector-set! x 0 0) (if #t (newline) (void)))) 255 (cptypes-equivalent-expansion? 256 '(lambda (x) (vector-set! x 0 0) (if (vector? x) (newline) (void))) 257 '(lambda (x) (vector-set! x 0 0) (if #t (newline) (void)))) 258 (cptypes-equivalent-expansion? 259 '(lambda (x) (when (vector? x) (if x (newline) (void)))) 260 '(lambda (x) (when (vector? x) (if #t (newline) (void))))) 261 (not (cptypes-equivalent-expansion? 262 '(lambda (x) (when (boolean? x) (if x (newline) (void)))) 263 '(lambda (x) (when (boolean? x) (if #t (newline) (void)))))) 264 (cptypes-equivalent-expansion? 265 '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (vector? x) (void))) 266 '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) #t (void)))) 267 (cptypes-equivalent-expansion? 268 '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) (vector? x))) 269 '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) #t))) 270 (cptypes-equivalent-expansion? 271 '(lambda (x) (if (vector? x) (vector? x) (void))) 272 '(lambda (x) (if (vector? x) #t (void)))) 273 (not (cptypes-equivalent-expansion? 274 '(lambda (x) (if (vector? x) (void) (vector? x))) 275 '(lambda (x) (if (vector? x) (void) #t)))) 276 (cptypes-equivalent-expansion? 277 '(lambda (x y) (if (vector? x) (if (vector? y) (list (vector? x) (vector? y)) (void)) (void))) 278 '(lambda (x y) (if (vector? x) (if (vector? y) (list #t #t) (void)) (void)))) 279 (cptypes-equivalent-expansion? 280 '(lambda (x y) (if (and (vector? x) (vector? y)) (list (vector? x) (vector? y)) (void))) 281 '(lambda (x y) (if (and (vector? x) (vector? y)) (list #t #t) (void)))) 282 (not (cptypes-equivalent-expansion? 283 '(lambda (x y) (if (or (vector? x) (vector? y)) (vector? x) (void))) 284 '(lambda (x y) (if (or (vector? x) (vector? y)) #t (void))))) 285 (not (cptypes-equivalent-expansion? 286 '(lambda (x y) (if (or (vector? x) (vector? y)) (vector? y) (void))) 287 '(lambda (x y) (if (or (vector? x) (vector? y)) #t (void))))) 288 (cptypes-equivalent-expansion? 289 '(lambda (x y) (if (if (vector? x) (vector? y) #f) (list (vector? x) (vector? y)) (void))) 290 '(lambda (x y) (if (if (vector? x) (vector? y) #f) (list #t #t) (void)))) 291 (cptypes-equivalent-expansion? 292 '(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) (vector? x))) 293 '(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) #t))) 294 (cptypes-equivalent-expansion? 295 '(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (display x) (number? x))) 296 '(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (display x) #f))) 297 (cptypes-equivalent-expansion? 298 '(lambda (t) (let ([x (if t 1 2)]) (fixnum? x))) 299 '(lambda (t) (let ([x (if t 1 2)]) #t))) 300 (cptypes-equivalent-expansion? 301 '(lambda (t) (let ([x (if t 1 2.0)]) (number? x))) 302 '(lambda (t) (let ([x (if t 1 2.0)]) #t))) 303 (cptypes-equivalent-expansion? 304 '(if (error 'who "msg") (display 1) (display 2)) 305 '(if (error 'who "msg") (display -1) (display -2))) 306 (cptypes-equivalent-expansion? 307 '(begin (if (error 'who "msg") (display 1) (display 2)) (display 3)) 308 '(begin (if (error 'who "msg") (display 1) (display 2)) (display -3))) 309 (cptypes-equivalent-expansion? 310 '(begin (if (box? (box 0)) (error 'who "msg") (void)) (display 1)) 311 '(begin (if (box? (box 0)) (error 'who "msg") (void)) (display -1))) 312 (not (cptypes-equivalent-expansion? 313 '(begin (if (box? (box 0)) (void) (error 'who "msg")) (display 1)) 314 '(begin (if (box? (box 0)) (void) (error 'who "msg")) (display -1)))) 315 (cptypes-equivalent-expansion? 316 '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) (vector? x)) 317 '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) #t)) 318 (cptypes-equivalent-expansion? 319 '(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) (vector? x)) 320 '(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) #t)) 321 (cptypes-equivalent-expansion? 322 '(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display 1)) 323 '(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display -1))) 324 (cptypes-equivalent-expansion? 325 '(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) (vector? x)) 326 '(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) #t)) 327 (not (cptypes-equivalent-expansion? 328 '(lambda (x y) (if y (void) (vector-set! x 0 0)) (vector? x)) 329 '(lambda (x y) (if y (void) (vector-set! x 0 0)) #t))) 330 (not (cptypes-equivalent-expansion? 331 '(lambda (x y) (if y (vector-set! x 0 0) (void)) (vector? x)) 332 '(lambda (x y) (if y (vector-set! x 0 0) (void)) #t))) 333 (cptypes-equivalent-expansion? 334 '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (vector? x) (void))) 335 '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) #t (void)))) 336 (cptypes-equivalent-expansion? 337 '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (vector? x) (void))) 338 '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) #t (void)))) 339 (not (cptypes-equivalent-expansion? 340 '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) (vector? x))) 341 '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) #t)))) 342 (not (cptypes-equivalent-expansion? 343 '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) (vector? x))) 344 '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) #t)))) 345 (cptypes-equivalent-expansion? 346 '(lambda (t) (vector? (if t (vector 1) (vector 2)))) 347 '(lambda (t) (if t (vector 1) (vector 2)) #t)) 348 (cptypes-equivalent-expansion? 349 '(number? (if t 1 2.0)) 350 '(begin (if t 1 2.0) #t)) 351 (cptypes-equivalent-expansion? 352 '(lambda (t) (fixnum? (if t 1 2))) 353 '(lambda (t) (if t 1 2.0) #t)) 354 (cptypes-equivalent-expansion? 355 '(lambda (t) (boolean? (if t #t #f))) 356 '(lambda (t) (if t #t #f) #t)) 357 (cptypes-equivalent-expansion? 358 '(lambda (t) ((lambda (x) (if x #t #f)) (if t (vector 1) (box 1)))) 359 '(lambda (t) (if t (vector 1) (box 1)) #t)) 360 (cptypes-equivalent-expansion? 361 '(lambda (t)(not (if t (vector 1) (box 1)))) 362 '(lambda (t) (if t (vector 1) (box 1)) #f)) 363 (cptypes-equivalent-expansion? 364 '(lambda (x y z f) 365 (let ([t (if x (vector 1) (box 1))]) 366 (if (if y t z) (f t 1) (f t 2)))) 367 '(lambda (x y z f) 368 (let ([t (if x (vector 1) (box 1))]) 369 (if (if y #t z) (f t 1) (f t 2))))) 370 (not (cptypes-equivalent-expansion? 371 '(lambda (x y z f) 372 (let ([t (vector? x)]) 373 (if (if y t z) (f t 1) (f t 2)))) 374 '(lambda (x y z f) 375 (let ([t (vector? x)]) 376 (if (if y #t z) (f t 1) (f t 2)))))) 377 (not (cptypes-equivalent-expansion? 378 '(lambda (x y z f) 379 (let ([t (vector? x)]) 380 (if (if y t z) (f t 1) (f t 2)))) 381 '(lambda (x y z f) 382 (let ([t (vector? x)]) 383 (if (if y #f z) (f t 1) (f t 2)))))) 384 (cptypes-equivalent-expansion? 385 '(lambda (t b) 386 (if (if t (newline) (unbox b)) (vector? b) (box? b))) 387 '(lambda (t b) 388 (if (if t (newline) (unbox b)) (vector? b) #t))) 389 (cptypes-equivalent-expansion? 390 '(lambda (t b) 391 (if (if t (unbox b) (newline)) (vector? b) (box? b))) 392 '(lambda (t b) 393 (if (if t (unbox b) (newline)) (vector? b) #t))) 394 (cptypes-equivalent-expansion? 395 '(lambda (t b) 396 (if (if t #f (unbox b)) (vector? b) (box? b))) 397 '(lambda (t b) 398 (if (if t #f (unbox b)) #f (box? b)))) 399 (cptypes-equivalent-expansion? 400 '(lambda (t b) 401 (if (if t (unbox b) #f) (vector? b) (box? b))) 402 '(lambda (t b) 403 (if (if t (unbox b) #f) #f (box? b)))) 404) 405 406(mat cptype-directly-applied-case-lambda 407 (equal? 408 (parameterize ([enable-type-recovery #t] 409 [run-cp0 (lambda (cp0 x) x)]) 410 (eval 411 '(let ([t ((lambda (x y) (cons y x)) 'a 'b)]) 412 (list t t)))) 413 '((b . a) (b . a))) 414 (equal? 415 (parameterize ([enable-type-recovery #t] 416 [run-cp0 (lambda (cp0 x) x)]) 417 (eval 418 '(let ([t ((lambda (x . y) (cons y x)) 'a 'b 'c 'd)]) 419 (list t t)))) 420 '(((b c d) . a) ((b c d) . a))) 421 (equal? 422 (parameterize ([enable-type-recovery #t] 423 [run-cp0 (lambda (cp0 x) x)]) 424 (eval 425 '(let ([t ((case-lambda 426 [(x) (cons 'first x)] 427 [(x y) (cons* 'second y x)] 428 [(x . y) (cons* 'third y x)]) 'a 'b)]) 429 (list t t)))) 430 '((second b . a) (second b . a))) 431 (equal? 432 (parameterize ([enable-type-recovery #t] 433 [run-cp0 (lambda (cp0 x) x)]) 434 (eval 435 '(let ([t ((case-lambda 436 [(x) (cons 'first x)] 437 [(x y) (cons* 'second y x)] 438 [(x . y) (cons* 'third y x)]) 'a 'b 'c)]) 439 (list t t)))) 440 '((third (b c) . a) (third (b c) . a))) 441 (equal? 442 (parameterize ([enable-type-recovery #t] 443 [run-cp0 (lambda (cp0 x) x)]) 444 (eval 445 '(let ([t 'z]) 446 ((lambda args (set! t (cons args t))) 'a 'b 'c) 447 t))) 448 '((a b c) . z)) 449 (equal? 450 (parameterize ([enable-type-recovery #t] 451 [run-cp0 (lambda (cp0 x) x)]) 452 (eval 453 '(let ([t 'z]) 454 ((lambda args (set! t (cons args t))) 'a 'b 'c) 455 t))) 456 '((a b c) . z)) 457 (equal? 458 (parameterize ([enable-type-recovery #t] 459 [run-cp0 (lambda (cp0 x) x)]) 460 (eval 461 '(let ([t 'z]) 462 ((lambda (x . y) (set! t (cons* y x t))) 'a 'b 'c) 463 t))) 464 '((b c) a . z)) 465 (equal? 466 (parameterize ([enable-type-recovery #t] 467 [run-cp0 (lambda (cp0 x) x)]) 468 (eval 469 '(let ([t 'z]) 470 ((case-lambda 471 [(x) (set! t (cons* 'first x t))] 472 [(x y) (set! t (cons* 'second y x t))] 473 [(x . y) (set! t (cons* 'third y x t))]) 'a 'b) 474 t))) 475 '(second b a . z)) 476 (equal? 477 (parameterize ([enable-type-recovery #t] 478 [run-cp0 (lambda (cp0 x) x)]) 479 (eval 480 '(let ([t 'z]) 481 ((case-lambda 482 [(x) (set! t (cons* 'first x t))] 483 [(x y) (set! t (cons* 'second y x t))] 484 [(x . y) (set! t (cons* 'third y x t))]) 'a 'b 'c 'd) 485 t))) 486 '(third (b c d) a . z)) 487) 488 489(define (test-chain/preamble/self preamble check-self? l) 490 (let loop ([l l]) 491 (if (null? l) 492 #t 493 (and (or (not check-self?) 494 (cptypes-equivalent-expansion? 495 `(let () 496 ,preamble 497 (lambda (x) (when (,(car l) x) (,(car l) x)))) 498 `(let () 499 ,preamble 500 (lambda (x) (when (,(car l) x) #t))))) 501 (let loop ([t (cdr l)]) 502 (if (null? t) 503 #t 504 (and (cptypes-equivalent-expansion? 505 `(let () 506 ,preamble 507 (lambda (x) (when (,(car l) x) (,(car t) x)))) 508 `(let () 509 ,preamble 510 (lambda (x) (when (,(car l) x) #t)))) 511 (not (cptypes-equivalent-expansion? 512 `(let () 513 ,preamble 514 (lambda (x) (when (,(car t) x) (,(car l) x)))) 515 `(let () 516 ,preamble 517 (lambda (x) (when (,(car t) x) #t))))) 518 (loop (cdr t))))) 519 (loop (cdr l)))))) 520 521(define (test-chain l) 522 (test-chain/preamble/self '(void) #t l)) 523 524(define (test-chain* l) 525 (test-chain/preamble/self '(void) #f l)) 526 527(define (test-chain/preamble preamble l) 528 (test-chain/preamble/self preamble #t l)) 529 530(define (test-chain*/preamble l) 531 (test-chain/preamble/self preamble #f l)) 532 533(define (test-disjoint/preamble/self preamble check-self? l) 534 (let loop ([l l]) 535 (if (null? l) 536 #t 537 (and (or (not check-self?) 538 (cptypes-equivalent-expansion? 539 `(let () 540 ,preamble 541 (lambda (x) (when (,(car l) x) (,(car l) x)))) 542 `(let () 543 ,preamble 544 (lambda (x) (when (,(car l) x) #t))))) 545 (let loop ([t (cdr l)]) 546 (if (null? t) 547 #t 548 (and (cptypes-equivalent-expansion? 549 `(let () 550 ,preamble 551 (lambda (x) (when (,(car l) x) (,(car t) x)))) 552 `(let () 553 ,preamble 554 (lambda (x) (when (,(car l) x) #f)))) 555 (cptypes-equivalent-expansion? 556 `(let () 557 ,preamble 558 (lambda (x) (when (,(car t) x) (,(car l) x)))) 559 `(let () 560 ,preamble 561 (lambda (x) (when (,(car t) x) #f)))) 562 (loop (cdr t))))) 563 (loop (cdr l)))))) 564 565(define (test-disjoint l) 566 (test-disjoint/preamble/self '(void) #t l)) 567 568(define (test-disjoint* l) 569 (test-disjoint/preamble/self '(void) #f l)) 570 571(define (test-disjoint/preamble preamble l) 572 (test-disjoint/preamble/self preamble #t l)) 573 574(define (test-disjoint*/preamble preamble l) 575 (test-disjoint/preamble/self preamble #f l)) 576 577(mat cptypes-type-implies? 578 (test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?)) 579 (test-chain* '((lambda (x) (or (eq? x 0) (eq? x 10))) fixnum? #;exact-integer? real? number?)) 580 (test-chain* '(fixnum? integer? real?)) 581 (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error 582 (test-chain* '(bignum? exact? number?)) ; exact? may raise an error 583 (test-chain '((lambda (x) (eqv? x (expt 256 100))) bignum? real? number?)) 584 (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?)) 585 (test-chain* '((lambda (x) (or (eqv? x 0.0) (eqv? x 3.14))) flonum? real? number?)) 586 (test-chain* '((lambda (x) (or (eq? x 0) (eqv? x 3.14))) real? number?)) 587 (test-chain '(gensym? symbol?)) 588 (test-chain '((lambda (x) (eq? x 'banana)) symbol?)) 589 (test-chain '(not boolean?)) 590 (test-chain '((lambda (x) (eq? x #t)) boolean?)) 591 (test-chain* '(record? #3%$record?)) 592 (test-chain* '((lambda (x) (eq? x car)) procedure?)) 593 (test-chain* '(record-type-descriptor? #3%$record?)) 594 (test-chain* '(null? list-assuming-immutable? list? #;(lambda (x) (or (null? x) (pair? x))))) 595 (test-disjoint '(pair? box? #3%$record? number? 596 vector? string? bytevector? fxvector? symbol? 597 char? boolean? null? (lambda (x) (eq? x (void))) 598 eof-object? bwp-object? procedure?)) 599 (test-disjoint '(pair? box? real? gensym? not)) 600 (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? x #t)))) 601 (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x)))) 602 (test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?)) 603 (test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?)) 604 (test-disjoint '((lambda (x) (eq? x 'banana)) (lambda (x) (eq? x 'apple)))) 605 (test-disjoint* '(list? record? vector?)) 606 (not (test-disjoint* '(list? null?))) 607 (not (test-disjoint* '(list? pair?))) 608 (not (test-disjoint* '(list-assuming-immutable? null?))) 609 (not (test-disjoint* '(list-assuming-immutable? pair?))) 610 (not (test-disjoint* '(list-assuming-immutable? list?))) 611) 612 613; use a gensym to make expansions equivalent 614(define my-rec (gensym "my-rec")) 615(define my-sub-rec (gensym "my-sub-rec")) 616(mat cptypes-type-record? 617 ; define-record 618 (parameterize ([optimize-level 2]) 619 (cptypes-equivalent-expansion? 620 `(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) (my-rec? x))) 621 `(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) #t)))) 622 (parameterize ([optimize-level 2]) 623 (cptypes-equivalent-expansion? 624 `(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) (my-rec? x))) 625 `(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) #t)))) 626 (cptypes-equivalent-expansion? 627 `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x))) 628 `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t))) 629 (cptypes-equivalent-expansion? 630 `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2))) 631 `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2)))) 632 633 (test-chain/preamble `(define-record ,my-rec (a)) '(my-rec? #3%$record?)) 634 (test-chain/preamble `(begin 635 (define-record ,my-rec (a)) 636 (define-record ,(gensym "sub-rec") ,my-rec (b))) 637 '(sub-rec? my-rec? #3%$record?)) 638 (test-disjoint/preamble `(define-record ,my-rec (a)) '(my-rec? pair? null? not number?)) 639 (test-disjoint/preamble `(begin 640 (define-record ,my-rec (a)) 641 (define-record ,(gensym "other-rec") (a))) 642 '(my-rec? other-rec?)) 643 644 ; define-record-type 645 (parameterize ([optimize-level 2]) 646 (cptypes-equivalent-expansion? 647 `(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) (my-rec? x))) 648 `(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) #t)))) 649 (parameterize ([optimize-level 2]) 650 (cptypes-equivalent-expansion? 651 `(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) (my-rec? x))) 652 `(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) #t)))) 653 (cptypes-equivalent-expansion? 654 `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x))) 655 `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t))) 656 (cptypes-equivalent-expansion? 657 `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2))) 658 `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2)))) 659 660 (test-chain/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? #3%$record?)) 661 #;(test-chain/preamble `(begin 662 (define-record-type ,my-rec (fields a)) 663 (define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b))) 664 '(sub-rec? my-rec? #3%$record?)) 665 (test-disjoint/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? pair? null? not number?)) 666 #;(test-disjoint/preamble `(begin 667 (define-record-type ,my-rec (fields a)) 668 (define-record-type ,(gensym "other-rec") (fields a))) 669 '(my-rec? other-rec?)) 670 671 ; define-record-type (sealed #t) 672 (parameterize ([optimize-level 2]) 673 (cptypes-equivalent-expansion? 674 `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) (my-rec? x))) 675 `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) #t)))) 676 (parameterize ([optimize-level 2]) 677 (cptypes-equivalent-expansion? 678 `(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) (my-rec? x))) 679 `(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) #t)))) 680 (cptypes-equivalent-expansion? 681 `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x))) 682 `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) #t))) 683 (cptypes-equivalent-expansion? 684 `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2))) 685 `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2)))) 686 687 (test-chain/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? #3%$record?)) 688 #;(test-chain/preamble `(begin 689 (define-record-type ,my-rec (fields a)) 690 (define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b) (sealed #t))) 691 '(sub-rec? my-rec? #3%$record?)) 692 (test-disjoint/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? pair? null? not number?)) 693 #;(test-disjoint/preamble `(begin 694 (define-record-type ,my-rec (fields a) (sealed #t)) 695 (define-record-type ,(gensym "other-rec") (fields a) (sealed #t))) 696 '(my-rec? other-rec?)) 697 #;(test-disjoint/preamble `(begin 698 (define-record-type ,my-rec (fields a) (sealed #t)) 699 (define-record-type ,(gensym "other-rec") (fields a))) 700 '(my-rec? other-rec?)) 701 702 ;; substituting `record-instance?` 703 (cptypes-equivalent-expansion? 704 `(let () 705 (define-record-type ,my-rec (fields a)) 706 (define-record-type ,my-sub-rec (fields a) (parent ,my-rec)) 707 (lambda (x) (and (my-rec? x) (list 'ok (my-sub-rec? x))))) 708 `(let () 709 (define-record-type ,my-rec (fields a)) 710 (define-record-type ,my-sub-rec (fields a) (parent ,my-rec)) 711 (lambda (x) (and (my-rec? x) (list 'ok (#3%record-instance? x (record-type-descriptor ,my-sub-rec))))))) 712 713 ;; substituting `sealed-record-instance?` 714 (cptypes-equivalent-expansion? 715 `(let () 716 (define-record-type ,my-rec (fields a)) 717 (define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t)) 718 (lambda (x) (and (my-rec? x) (list 'ok (my-sub-rec? x))))) 719 `(let () 720 (define-record-type ,my-rec (fields a)) 721 (define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t)) 722 (lambda (x) (and (my-rec? x) (list 'ok (#3%$sealed-record-instance? x (record-type-descriptor ,my-sub-rec))))))) 723 724 ;; obviously incompatible rtds 725 ;; the third pass is needed to eliminate #3%$value 726 (parameterize ([run-cp0 (lambda (cp0 x) (cp0 (cp0 (cp0 x))))]) 727 (cptypes-equivalent-expansion? 728 `(let () 729 (define-record I (a)) 730 (define A (make-record-type-descriptor* 'a #f #f #f #f 1 0)) 731 (lambda (x) (and ((record-predicate A) x) (I? x)))) 732 `(begin 733 (make-record-type-descriptor* 'a #f #f #f #f 1 0) 734 (lambda (x) #f)))) 735) 736 737(mat cptypes-lists 738 (cptypes-equivalent-expansion? 739 '(lambda (x) (when (list-assuming-immutable? x) (list? (cdr x)))) 740 '(lambda (x) (when (list-assuming-immutable? x) (cdr x) #t))) 741 (cptypes-equivalent-expansion? 742 '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) (list? (cdr x)))) 743 '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) #t))) 744 (cptypes-equivalent-expansion? 745 '(lambda (x) (when (list-assuming-immutable? x) (list? (cdr (error 'e ""))))) 746 '(lambda (x) (when (list-assuming-immutable? x) (error 'e "")))) 747 (cptypes-equivalent-expansion? 748 '(lambda (x) (when (vector? x) (list? (#2%cdr x)) 1)) 749 '(lambda (x) (when (vector? x) (#2%cdr x)))) 750) 751 752(mat cptypes-unsafe 753 (cptypes-equivalent-expansion? 754 '(lambda (x) (when (pair? x) (car x))) 755 '(lambda (x) (when (pair? x) (#3%car x)))) 756 (cptypes-equivalent-expansion? 757 '(lambda (x) (when (pair? x) (cdr x))) 758 '(lambda (x) (when (pair? x) (#3%cdr x)))) 759 (not (cptypes-equivalent-expansion? 760 '(lambda (x) (when (pair? x) (#2%cadr x))) 761 '(lambda (x) (when (pair? x) (#3%cadr x))))) 762 (cptypes-equivalent-expansion? 763 '(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (fxmax x y))) 764 '(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (#3%fxmax x y)))) 765 (cptypes-equivalent-expansion? 766 '(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (fxmax x y))) 767 '(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (#3%fxmax x y)))) 768 (cptypes-equivalent-expansion? 769 '(lambda (x) (when (fixnum? x) (fxmax x 5))) 770 '(lambda (x) (when (fixnum? x) (#3%fxmax x 5)))) 771 (cptypes-equivalent-expansion? 772 '(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (fxmax x y z))) 773 '(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (#3%fxmax x y z)))) 774 (cptypes-equivalent-expansion? 775 '(lambda (x) (when (fixnum? x) (fxzero? x))) 776 '(lambda (x) (when (fixnum? x) (#3%fxzero? x)))) 777 (not (cptypes-equivalent-expansion? 778 '(lambda (x) (when (number? x) (#2%odd? x))) 779 '(lambda (x) (when (number? x) (#3%odd? x))))) 780 (cptypes-equivalent-expansion? 781 '(lambda (x) (when (number? x) (#2%exact? x))) 782 '(lambda (x) (when (number? x) (#3%exact? x)))) 783 (not (cptypes-equivalent-expansion? 784 '(lambda (x) (#2%exact? x)) 785 '(lambda (x) (#3%exact? x)))) 786) 787 788(mat cptypes-rest-argument 789 (cptypes/nocp0-equivalent-expansion? 790 '((lambda (x . r) (pair? r)) 1) 791 '((lambda (x . r) #f) 1)) 792 (cptypes/nocp0-equivalent-expansion? 793 '((lambda (x . r) (null? r)) 1) 794 '((lambda (x . r) #t) 1)) 795 (cptypes/nocp0-equivalent-expansion? 796 '((lambda (x . r) (pair? r)) 1 2) 797 '((lambda (x . r) #t) 1 2)) 798 (cptypes/nocp0-equivalent-expansion? 799 '((lambda (x . r) (null? r)) 1 2) 800 '((lambda (x . r) #f) 1 2)) 801) 802 803(mat cptypes-delay 804 (cptypes-equivalent-expansion? 805 '(lambda (b) (map (lambda (x) (box? b)) (unbox b))) 806 '(lambda (b) (map (lambda (x) #t) (unbox b)))) 807 (cptypes-equivalent-expansion? 808 '(lambda (b) (list (lambda (x) (box? b)) (unbox b))) 809 '(lambda (b) (list (lambda (x) #t) (unbox b)))) 810 (cptypes-equivalent-expansion? 811 '(lambda (b) (list (unbox b) (lambda (x) (box? b)))) 812 '(lambda (b) (list (unbox b) (lambda (x) #t)))) 813) 814 815(mat cptypes-call-with-values 816 ; The single value case is handled by cp0 817 (cptypes-equivalent-expansion? 818 '(lambda (v) 819 (call-with-values 820 (lambda () (vector-ref v 0)) 821 (lambda (y) (list (vector? v) (vector-ref v 1) y)))) 822 '(lambda (v) 823 (call-with-values 824 (lambda () (vector-ref v 0)) 825 (lambda (y) (list #t (vector-ref v 1) y))))) 826 (cptypes-equivalent-expansion? 827 '(lambda (t) 828 (call-with-values 829 (lambda () (if t (box 2) (box 3))) 830 (lambda (y) (list y (box? y))))) 831 '(lambda (t) 832 (call-with-values 833 (lambda () (if t (box 2) (box 3))) 834 (lambda (y) (list y #t))))) 835 (cptypes-equivalent-expansion? 836 '(lambda (t b) 837 (call-with-values 838 (lambda () (if t 1 2)) 839 (lambda (y) (display (unbox b)))) 840 (box? b)) 841 '(lambda (t b) 842 (call-with-values 843 (lambda () (if t 1 2)) 844 (lambda (y) (display (unbox b)))) 845 #t)) 846 (cptypes-equivalent-expansion? 847 '(lambda (b) 848 (call-with-values 849 (lambda () (if (unbox b) 1 2)) 850 (lambda (y) (display y))) 851 (box? b)) 852 '(lambda (b) 853 (call-with-values 854 (lambda () (if (unbox b) 1 2)) 855 (lambda (y) (display y))) 856 #t)) 857 858 (cptypes-equivalent-expansion? 859 '(lambda (b) 860 (call-with-values 861 (lambda () (if (unbox b) 1 (values 2 3))) 862 (lambda (x y) (list x y (box? b))))) 863 '(lambda (b) 864 (call-with-values 865 (lambda () (if (unbox b) 1 (values 2 3))) 866 (lambda (x y) (list x y #t))))) 867 (cptypes-equivalent-expansion? 868 '(lambda (t b) 869 (call-with-values 870 (lambda () (if t 1 (values 2 3))) 871 (lambda (x y) (display (list x y (unbox b))))) 872 (box? b)) 873 '(lambda (t b) 874 (call-with-values 875 (lambda () (if t 1 (values 2 3))) 876 (lambda (x y) (display (list x y (unbox b))))) 877 #t)) 878 (cptypes-equivalent-expansion? 879 '(lambda (b) 880 (call-with-values 881 (lambda () (if (unbox b) 1 (values 2 3))) 882 (lambda (x y) (display (list x y)))) 883 (box? b)) 884 '(lambda (b) 885 (call-with-values 886 (lambda () (if (unbox b) 1 (values 2 3))) 887 (lambda (x y) (display (list x y)))) 888 #t)) 889 890 (cptypes-equivalent-expansion? 891 '(lambda (b) 892 (call-with-values 893 (case-lambda 894 [() (if (unbox b) 1 (values 2 3))] 895 [(x) (error 'e "")]) 896 (lambda (x y) (list x y (box? b))))) 897 '(lambda (b) 898 (call-with-values 899 (case-lambda 900 [() (if (unbox b) 1 (values 2 3))] 901 [(x) (error 'e "")]) 902 (lambda (x y) (list x y #t))))) 903 (cptypes-equivalent-expansion? 904 '(lambda (t b) 905 (call-with-values 906 (lambda () (if t 1 (values 2 3))) 907 (case-lambda 908 [(x y) (display (list x y (unbox b)))] 909 [(x) (error 'e "")])) 910 (box? b)) 911 '(lambda (t b) 912 (call-with-values 913 (lambda () (if t 1 (values 2 3))) 914 (case-lambda 915 [(x y) (display (list x y (unbox b)))] 916 [(x) (error 'e "")])) 917 #t)) 918 (cptypes-equivalent-expansion? 919 '(lambda (b) 920 (call-with-values 921 (case-lambda 922 [() (if (unbox b) 1 (values 2 3))] 923 [(x) (error 'e "")]) 924 (lambda (x y) (display (list x y)))) 925 (box? b)) 926 '(lambda (b) 927 (call-with-values 928 (case-lambda 929 [() (if (unbox b) 1 (values 2 3))] 930 [(x) (error 'e "")]) 931 (lambda (x y) (display (list x y)))) 932 #t)) 933 934 (cptypes-equivalent-expansion? 935 '(lambda (t b) 936 (call-with-values 937 (begin (display (unbox b)) (lambda () (if t 1 (values b 2)))) 938 (lambda (x y) (list x y (box? b))))) 939 '(lambda (t b) 940 (call-with-values 941 (begin (display (unbox b)) (lambda () (if t 1 (values b 2)))) 942 (lambda (x y) (list x y #t))))) 943 ; This is difficult to handle in cptypes, so I ignored it. 944 ; But it is anyway handled by cp0. 945 #;(cptypes-equivalent-expansion? 946 '(lambda (t b) 947 (call-with-values 948 (lambda () (if t 1 (values b (box? b)))) 949 (begin (display (unbox b)) (lambda (x y) (list x y b))))) 950 '(lambda (t b) 951 (call-with-values 952 (lambda () (if t 1 (values b #t))) 953 (begin (display (unbox b)) (lambda (x y) (list x y b)))))) 954 955 (cptypes-equivalent-expansion? 956 '(lambda (t) 957 (number? 958 (call-with-values 959 (lambda () (if t 1 (values 2 3))) 960 (case-lambda [(x y) 2] [(x) 1])))) 961 '(lambda (t) 962 (call-with-values 963 (lambda () (if t 1 (values 2 3))) 964 (case-lambda [(x y) 2] [(x) 1])) 965 #t)) 966 (cptypes-equivalent-expansion? 967 '(lambda (t) 968 (number? 969 (call-with-values 970 (lambda () (if t 1 (values 2 3))) 971 (case-lambda [(x y) 2] [(x) (error 'e "")])))) 972 '(lambda (t) 973 (call-with-values 974 (lambda () (if t 1 (values 2 3))) 975 (case-lambda [(x y) 2] [(x) (error 'e "")])) 976 #t)) 977 978 (cptypes-equivalent-expansion? 979 '(lambda (t f) 980 (call-with-values 981 (lambda () (if t 1 (values 2 3))) 982 f) 983 (procedure? f)) 984 '(lambda (t f) 985 (call-with-values 986 (lambda () (if t 1 (values 2 3))) 987 f) 988 #t)) 989 (cptypes-equivalent-expansion? 990 '(lambda (t f) 991 (call-with-values 992 f 993 (lambda (x y) (+ x y))) 994 (procedure? f)) 995 '(lambda (t f) 996 (call-with-values 997 f 998 (lambda (x y) (+ x y))) 999 #t)) 1000 (cptypes-equivalent-expansion? 1001 '(lambda (t f) 1002 (when (box? f) 1003 (call-with-values 1004 (lambda () (if t 1 (values 2 3))) 1005 f) 1006 111)) 1007 '(lambda (t f) 1008 (when (box? f) 1009 (call-with-values 1010 (lambda () (if t 1 (values 2 3))) 1011 f) 1012 222))) 1013 (cptypes-equivalent-expansion? 1014 '(lambda (t f) 1015 (when (box? f) 1016 (call-with-values 1017 f 1018 (lambda (x y) (+ x y))) 1019 111)) 1020 '(lambda (t f) 1021 (when (box? f) 1022 (call-with-values 1023 f 1024 (lambda (x y) (+ x y))) 1025 222))) 1026) 1027 1028(mat cptypes-apply 1029 (cptypes-equivalent-expansion? 1030 '(lambda (l b) 1031 (apply (lambda (x) (display (list (unbox b) x))) l) 1032 (box? b)) 1033 '(lambda (l b) 1034 (apply (lambda (x) (display (list (unbox b) x))) l) 1035 #t)) 1036 (cptypes-equivalent-expansion? 1037 '(lambda (l b) 1038 (apply (lambda (x y) (display (list (unbox b) x))) 7 l) 1039 (box? b)) 1040 '(lambda (l b) 1041 (apply (lambda (x y) (display (list (unbox b) x))) 7 l) 1042 #t)) 1043 (cptypes-equivalent-expansion? 1044 '(lambda (l b) 1045 (apply (lambda (x) (display (list b x))) (unbox b)) 1046 (box? b)) 1047 '(lambda (l b) 1048 (apply (lambda (x) (display (list b x))) (unbox b)) 1049 #t)) 1050 (cptypes-equivalent-expansion? 1051 '(lambda (l b) 1052 (apply (lambda (x y) (display (list b x y))) 7 (unbox b)) 1053 (box? b)) 1054 '(lambda (l b) 1055 (apply (lambda (x y) (display (list b x y))) 7 (unbox b)) 1056 #t)) 1057 1058 (cptypes-equivalent-expansion? 1059 ; with #3% the argument may be inlined and then executed in reverse order 1060 '(lambda (l b) 1061 (#2%apply (lambda (x y) (list (box? b) x y)) 7 (unbox b))) 1062 '(lambda (l b) 1063 (#2%apply (lambda (x y) (list #t x y)) 7 (unbox b)))) 1064 1065 (cptypes-equivalent-expansion? 1066 '(lambda (l b) 1067 (apply 1068 (case-lambda 1069 [(x) (list (unbox b) x)] 1070 [(x y) (error 'e "")]) 1071 l) 1072 (box? b)) 1073 '(lambda (l b) 1074 (apply 1075 (case-lambda 1076 [(x) (list (unbox b) x)] 1077 [(x y) (error 'e "")]) 1078 l) 1079 #t)) 1080 1081 (cptypes-equivalent-expansion? 1082 '(lambda (l) 1083 (number? 1084 (apply (lambda (x y) (+ x y)) l))) 1085 '(lambda (l) 1086 (apply (lambda (x y) (+ x y)) l) 1087 #t)) 1088 (cptypes-equivalent-expansion? 1089 '(lambda (l) 1090 (number? 1091 (apply 1092 (case-lambda 1093 [(x y) (+ x y)] 1094 [() (error 'e "")]) 1095 l))) 1096 '(lambda (l) 1097 (apply 1098 (case-lambda 1099 [(x y) (+ x y)] 1100 [() (error 'e "")]) 1101 l) 1102 #t)) 1103 1104 (cptypes-equivalent-expansion? 1105 '(lambda (f l) 1106 (apply f l) 1107 (procedure? f)) 1108 '(lambda (f l) 1109 (apply f l) 1110 #t)) 1111 (cptypes-equivalent-expansion? 1112 '(lambda (t f) 1113 (when (box? f) 1114 (apply f l) 1115 111)) 1116 '(lambda (t f) 1117 (when (box? f) 1118 (apply f l) 1119 222))) 1120) 1121 1122(mat cptypes-dynamic-wind 1123 (cptypes-equivalent-expansion? 1124 '(lambda (f) 1125 (box? (dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f)))) 1126 '(lambda (f) 1127 (begin 1128 (dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f)) 1129 #t))) 1130 1131 (cptypes-equivalent-expansion? 1132 '(lambda (b) 1133 (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f)) 1134 (box? b)) 1135 '(lambda (b) 1136 (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f)) 1137 #t)) 1138 (cptypes-equivalent-expansion? 1139 '(lambda (b) 1140 (dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f)) 1141 (box? b)) 1142 '(lambda (b) 1143 (dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f)) 1144 #t)) 1145 (cptypes-equivalent-expansion? 1146 '(lambda (b) 1147 (dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b))) 1148 (box? b)) 1149 '(lambda (b) 1150 (dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b))) 1151 #t)) 1152 1153 (cptypes-equivalent-expansion? 1154 '(lambda (b) 1155 (dynamic-wind (lambda (x) (unbox b)) (lambda () (box? b)) (lambda () #f))) 1156 '(lambda (b) 1157 (dynamic-wind (lambda (x) (unbox b)) (lambda () #t) (lambda () #f)))) 1158 (cptypes-equivalent-expansion? 1159 '(lambda (b) 1160 (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () (box? b)))) 1161 '(lambda (b) 1162 (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #t) ))) 1163 (not (cptypes-equivalent-expansion? 1164 '(lambda (b) 1165 (dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () (box? b)))) 1166 '(lambda (b) 1167 (dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () #t))))) 1168) 1169 1170(mat cptypes-result-type 1171 ; test the special case for predicates 1172 (cptypes-equivalent-expansion? 1173 '(number? (optimize-level)) 1174 '(begin (optimize-level) #t)) 1175 ; this does't work for now, test a few weaker versions 1176 #;(cptypes-equivalent-expansion? 1177 '(eq? (optimize-level 0) (void)) 1178 '(begin (optimize-level 0) #t)) 1179 (cptypes-equivalent-expansion? 1180 '(number? (optimize-level 0)) 1181 '(begin (optimize-level 0) #f)) 1182 (parameterize ([optimize-level 0]) 1183 (eq? (optimize-level 0) (void))) 1184) 1185 1186(mat cptypes-drop 1187 (cptypes/once-equivalent-expansion? 1188 '(pair? (list 1 (display 2) 3)) 1189 '(begin (display 2) #t)) 1190 (cptypes/once-equivalent-expansion? 1191 '(vector? (list 1 (display 2) 3)) 1192 '(begin (display 2) #f)) 1193 (cptypes/once-equivalent-expansion? 1194 '(pair? (list 1 (vector 2 (display 3) 4))) 1195 '(begin (display 3) #t)) 1196 (cptypes/once-equivalent-expansion? 1197 '(vector? (list 1 (vector 2 (display 3) 4))) 1198 '(begin (display 3) #f)) 1199 ; regression test: check that the compiler doesn't loop forever 1200 ; when the return arity is unknown 1201 (cptypes-equivalent-expansion? 1202 '(lambda (f) (box? (box (f)))) 1203 '(lambda (f) (#3%$value (f)) #t)) 1204) 1205 1206(mat cptypes-store-immediate 1207 (cptypes-equivalent-expansion? 1208 '(lambda (v) 1209 (let loop ([i 0]) 1210 (when (fx< i (vector-length v)) 1211 (vector-set! v i i) 1212 (loop (fx+ i 1))))) 1213 '(lambda (v) 1214 (let loop ([i 0]) 1215 (when (fx< i (vector-length v)) 1216 (vector-set! v i (#3%$fixmediate i)) 1217 (loop (fx+ i 1)))))) 1218 (cptypes-equivalent-expansion? 1219 '(lambda (x y) (set-box! x (if (vector? y) #t (error 't)))) 1220 '(lambda (x y) (set-box! x (#3%$fixmediate (if (vector? y) #t (error 't)))))) 1221) 1222 1223(mat cptypes-maybe 1224 (cptypes-equivalent-expansion? 1225 '(lambda (x) (when (or (not x) (vector? x)) (box? x))) 1226 '(lambda (x) (when (or (not x) (vector? x)) #f))) 1227 (not (cptypes-equivalent-expansion? 1228 '(lambda (x) (when (or (not x) (vector? x)) (vector? x))) 1229 '(lambda (x) (when (or (not x) (vector? x)) #t)))) 1230 (cptypes-equivalent-expansion? 1231 '(lambda (x) (when (or (not x) (vector? x)) (when x (vector? x)))) 1232 '(lambda (x) (when (or (not x) (vector? x)) (when x #t)))) 1233 (cptypes-equivalent-expansion? 1234 '(lambda (x) (when (or (not x) (char? x)) (when x (char? x)))) 1235 '(lambda (x) (when (or (not x) (char? x)) (when x #t)))) 1236 (cptypes-equivalent-expansion? 1237 '(lambda (s) (define x (string->number s)) (when x (number? x))) 1238 '(lambda (s) (define x (string->number s)) (when x #t))) 1239 (cptypes-equivalent-expansion? 1240 '(lambda (p) (define x (get-char p)) (not x)) 1241 '(lambda (p) (define x (get-char p)) #f)) 1242 (cptypes-equivalent-expansion? 1243 '(lambda (p) (define x (get-char p)) (box? x)) 1244 '(lambda (p) (define x (get-char p)) #f)) 1245(cptypes-equivalent-expansion? 1246 '(lambda (p) (define x (get-u8 p)) (when (number? p) (fixnum? p))) 1247 '(lambda (p) (define x (get-u8 p)) (when (number? p) #t))) 1248) 1249 1250(mat cptypes-unreachable 1251 (cptypes-equivalent-expansion? 1252 '(lambda (x) (if (pair? x) (car x) (#3%assert-unreachable))) 1253 '(lambda (x) (#3%car x))) 1254 (not 1255 (cptypes-equivalent-expansion? 1256 '(lambda (x) (if (pair? x) (car x) (#2%assert-unreachable))) 1257 '(lambda (x) (#3%car x)))) 1258) 1259 1260(mat cptypes-bottom 1261 (cptypes-equivalent-expansion? 1262 '(lambda (x) (error 'x "no") (add1 x)) 1263 '(lambda (x) (error 'x "no"))) 1264 (cptypes-equivalent-expansion? 1265 '(lambda (f) (f (error 'x "no") f)) 1266 '(lambda (f) (error 'x "no"))) 1267 (cptypes-equivalent-expansion? 1268 '(lambda (f) ((error 'x "no") f f)) 1269 '(lambda (f) (error 'x "no"))) 1270 (cptypes-equivalent-expansion? 1271 '(lambda (x) (if (error 'x "no") (add1 x) (sub1 x))) 1272 '(lambda (x) (error 'x "no"))) 1273 (cptypes-equivalent-expansion? 1274 '(lambda (x) (+ (error 'x "no") x)) 1275 '(lambda (x) (error 'x "no"))) 1276 (cptypes-equivalent-expansion? 1277 '(lambda (x) (list x (add1 x) (error 'x "no") (sub1 x))) 1278 '(lambda (x) (error 'x "no"))) 1279 (cptypes-equivalent-expansion? 1280 '(lambda (x) (apply x (add1 x) (error 'x "no") (sub1 x))) 1281 '(lambda (x) (error 'x "no"))) 1282 (cptypes-equivalent-expansion? 1283 '(lambda (x) (apply (error 'x "no") (add1 x) (sub1 x))) 1284 '(lambda (x) (error 'x "no"))) 1285 (cptypes-equivalent-expansion? 1286 '(lambda (x) (let* ([x (add1 x)] [y (error 'x "no")]) (+ x y))) 1287 '(lambda (x) (add1 x) (error 'x "no"))) 1288 (cptypes-equivalent-expansion? 1289 '(lambda (x) (list (if (odd? x) (error 'x "no") (error 'x "nah")) 17)) 1290 '(lambda (x) (if (odd? x) (error 'x "no") (error 'x "nah")))) 1291 (cptypes-equivalent-expansion? 1292 '(let ([x #f]) (case-lambda [() x] [(y) (set! x (error 'x "no"))])) 1293 '(let ([x #f]) (case-lambda [() x] [(y) (error 'x "no")]))) 1294 1295 (cptypes-equivalent-expansion? 1296 '(lambda (x) (+ (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))) 1)) 1297 '(lambda (x) (#%$value (call-setting-continuation-attachment 'a (lambda () (error 'x "no")))))) 1298 (not 1299 (cptypes-equivalent-expansion? 1300 '(lambda (x) (+ (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))) 1)) 1301 '(lambda (x) (call-setting-continuation-attachment 'a (lambda () (error 'x "no")))))) 1302 (cptypes-equivalent-expansion? 1303 '(lambda (x) (+ (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) 1304 '(lambda (x) (#%$value (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no")))))) 1305 (not 1306 (cptypes-equivalent-expansion? 1307 '(lambda (x) (+ (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) 1308 '(lambda (x) (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no")))))) 1309 (cptypes-equivalent-expansion? 1310 '(lambda (x) (+ (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) 1311 '(lambda (x) (#%$value (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no")))))) 1312 (not 1313 (cptypes-equivalent-expansion? 1314 '(lambda (x) (+ (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) 1315 '(lambda (x) (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no")))))) 1316) 1317