1115 lines
43 KiB
Scheme
1115 lines
43 KiB
Scheme
;;; cptypes.ms
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
(define-syntax cptypes-equivalent-expansion?
|
|
(syntax-rules ()
|
|
[(_ x y)
|
|
(equivalent-expansion?
|
|
(parameterize ([enable-cp0 #t]
|
|
[#%$suppress-primitive-inlining #f]
|
|
#;[optimize-level (max (optimize-level) 2)])
|
|
(expand/optimize x))
|
|
(parameterize ([enable-cp0 #t]
|
|
[#%$suppress-primitive-inlining #f]
|
|
#;[optimize-level (max (optimize-level) 2)])
|
|
(expand/optimize y)))]))
|
|
|
|
(define-syntax cptypes/once-equivalent-expansion?
|
|
; Replace the default value of run-cp0 with a version that calls
|
|
; cp0 only once instead of twice.
|
|
; This is useful to test some reductions that are shared with cp0
|
|
; or that should be executed in a single pass.
|
|
(syntax-rules ()
|
|
[(_ x y)
|
|
(equivalent-expansion?
|
|
(parameterize ([run-cp0 (lambda (cp0 c) (cp0 c))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
#;[optimize-level (max (optimize-level) 2)])
|
|
(expand/optimize x))
|
|
(parameterize ([run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
#;[optimize-level (max (optimize-level) 2)])
|
|
(expand/optimize y)))]))
|
|
|
|
(define-syntax cptypes/nocp0-equivalent-expansion?
|
|
; When run-cp0 is call, use #3%$cptypes insted of the cp0 function provided.
|
|
; This disables the reductions in cp0.ss, so it's posible to see
|
|
; the isolated effect of the reduction in cptypes.ss.
|
|
(syntax-rules ()
|
|
[(_ x y)
|
|
(equivalent-expansion?
|
|
(parameterize ([run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
#;[optimize-level (max (optimize-level) 2)])
|
|
(expand/optimize x))
|
|
(parameterize ([run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
#;[optimize-level (max (optimize-level) 2)])
|
|
(expand/optimize y)))]))
|
|
|
|
(mat cptypes-handcoded
|
|
(cptypes-equivalent-expansion?
|
|
'(vector? (vector)) ;actually reduced by folding, not cptypes
|
|
#t)
|
|
(cptypes-equivalent-expansion?
|
|
'(vector? (vector 1 2 3))
|
|
#t)
|
|
(cptypes-equivalent-expansion?
|
|
'(vector? (box 1))
|
|
#f)
|
|
(cptypes-equivalent-expansion?
|
|
'(box? (vector 1 2 3))
|
|
#f)
|
|
(cptypes-equivalent-expansion?
|
|
'(box? (box 1))
|
|
#t)
|
|
(cptypes-equivalent-expansion?
|
|
'(pair? (cons 1 2))
|
|
#t)
|
|
(cptypes-equivalent-expansion?
|
|
'(pair? (list 1 2))
|
|
#t)
|
|
(cptypes-equivalent-expansion?
|
|
'(pair? (list))
|
|
#f)
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (vector? x))
|
|
'(lambda (x) (vector-set! x 0 0) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (box? x))
|
|
'(lambda (x) (vector-set! x 0 0) #f))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (vector-set! x 0 0) (set! y (vector? x)))
|
|
'(lambda (x y) (vector-set! x 0 0) (set! y #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (set! y (vector-ref x 0)) (list (vector? x) y))
|
|
'(lambda (x y) (set! y (vector-ref x 0)) (list #t y)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list (vector? x) y y)))
|
|
'(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list #t y y))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (let ([y (vector? x)]) (list (random 7) y y)))
|
|
'(lambda (x) (vector-set! x 0 0) (let ([y #t]) (list (random 7) y y))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (let ([y (vector-ref x 0)]) (list (vector? x) y y)))
|
|
'(lambda (x) (let ([y (vector-ref x 0)]) (list #t y y))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (let ([y (vector-ref x 0)])
|
|
(let ([z (vector? x)])
|
|
(list y y z z))))
|
|
'(lambda (x) (let ([y (vector-ref x 0)])
|
|
(let ([z #t])
|
|
(list y y z z)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) (vector? x))
|
|
'(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) (vector? x))
|
|
'(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(let ([y (vector 1 2 3)]) (display (list (vector? y) y y)))
|
|
'(let ([y (vector 1 2 3)]) (display (list #t y y))))
|
|
(cptypes-equivalent-expansion?
|
|
'(let ([y (vector 1 2 3)]) (display (list y y)) (vector? y))
|
|
'(let ([y (vector 1 2 3)]) (display (list y y)) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(vector? (let ([y (vector 1 2 3)]) (display (list y y)) y))
|
|
'(begin (let ([y (vector 1 2 3)]) (display (list y y)) y) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(vector? (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)))
|
|
'(begin (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (null? x) (display x)))
|
|
'(lambda (x) (when (null? x) (display '()))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (vector? x) (eq? x 'vector?)))
|
|
'(lambda (x) (when (vector? x) #f)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (vector? x) (pair? x)))
|
|
'(lambda (x) (when (vector? x) #f)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (vector? x) (vector? x)))
|
|
'(lambda (x) (when (vector? x) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (procedure? x) (procedure? x)))
|
|
'(lambda (x) (when (procedure? x) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (f) (f) (procedure? f))
|
|
'(lambda (f) (f) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x)
|
|
(vector-set! x 0 0)
|
|
(let loop ([n 1000])
|
|
(unless (zero? n)
|
|
(display (vector? x))
|
|
(loop (- n 1)))))
|
|
'(lambda (x)
|
|
(vector-set! x 0 0)
|
|
(let loop ([n 1000])
|
|
(unless (zero? n)
|
|
(display #t)
|
|
(loop (- n 1))))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x)
|
|
(let loop ([n 1000])
|
|
(unless (zero? n)
|
|
(vector-set! x 0 n)
|
|
(loop (- n 1))))
|
|
(vector? x))
|
|
'(lambda (x)
|
|
(let loop ([n 1000])
|
|
(unless (zero? n)
|
|
(vector-set! x 0 n)
|
|
(loop (- n 1))))
|
|
(vector? x)))
|
|
(cptypes-equivalent-expansion?
|
|
'(begin (error 'who "msg") 1) ;could be reduced in cp0
|
|
'(begin (error 'who "msg") 2))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x) 1)
|
|
'(lambda (x) (vector-set! x) 2))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (#2%-) 1)
|
|
'(lambda (x) (#2%-) 2))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (#2%make-vector x 0 7) 1)
|
|
'(lambda (x) (#2%make-vector x 0 7) 2))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (set-box! x 0) 1)
|
|
'(lambda (x) (vector-set! x 0 0) (set-box! x 0) 2))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! (box 5) 0 0) 1)
|
|
'(lambda (x) (vector-set! (box 5) 0 0) 2))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (#2%odd? x) (real? x))
|
|
'(lambda (x) (#2%odd? x) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (#2%odd? x) 1)
|
|
'(lambda (x) (vector-set! x 0 0) (#2%odd? x) 2))
|
|
)
|
|
|
|
(mat cptypes-type-if
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (vector-ref x 0) (newline) (void)) (vector? x))
|
|
'(lambda (x) (if (vector-ref x 0) (newline) (void)) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (vector-ref x 0) (vector? x) (void)))
|
|
'(lambda (x) (if (vector-ref x 0) #t (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (vector-ref x 0) (void) (vector? x)))
|
|
'(lambda (x) (if (vector-ref x 0) (void) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) (vector? x))
|
|
'(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) #t))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) (vector? x))
|
|
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) #t)))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) (vector? x))
|
|
'(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (if x (newline) (void)))
|
|
'(lambda (x) (vector-set! x 0 0) (if #t (newline) (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (if (vector? x) (newline) (void)))
|
|
'(lambda (x) (vector-set! x 0 0) (if #t (newline) (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (vector? x) (if x (newline) (void))))
|
|
'(lambda (x) (when (vector? x) (if #t (newline) (void)))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (boolean? x) (if x (newline) (void))))
|
|
'(lambda (x) (when (boolean? x) (if #t (newline) (void))))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (vector? x) (void)))
|
|
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) #t (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) (vector? x)))
|
|
'(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (vector? x) (vector? x) (void)))
|
|
'(lambda (x) (if (vector? x) #t (void))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (vector? x) (void) (vector? x)))
|
|
'(lambda (x) (if (vector? x) (void) #t))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (vector? x) (if (vector? y) (list (vector? x) (vector? y)) (void)) (void)))
|
|
'(lambda (x y) (if (vector? x) (if (vector? y) (list #t #t) (void)) (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (and (vector? x) (vector? y)) (list (vector? x) (vector? y)) (void)))
|
|
'(lambda (x y) (if (and (vector? x) (vector? y)) (list #t #t) (void))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (or (vector? x) (vector? y)) (vector? x) (void)))
|
|
'(lambda (x y) (if (or (vector? x) (vector? y)) #t (void)))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (or (vector? x) (vector? y)) (vector? y) (void)))
|
|
'(lambda (x y) (if (or (vector? x) (vector? y)) #t (void)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (if (vector? x) (vector? y) #f) (list (vector? x) (vector? y)) (void)))
|
|
'(lambda (x y) (if (if (vector? x) (vector? y) #f) (list #t #t) (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) (vector? x)))
|
|
'(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (display x) (number? x)))
|
|
'(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (display x) #f)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) (let ([x (if t 1 2)]) (fixnum? x)))
|
|
'(lambda (t) (let ([x (if t 1 2)]) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) (let ([x (if t 1 2.0)]) (number? x)))
|
|
'(lambda (t) (let ([x (if t 1 2.0)]) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(if (error 'who "msg") (display 1) (display 2))
|
|
'(if (error 'who "msg") (display -1) (display -2)))
|
|
(cptypes-equivalent-expansion?
|
|
'(begin (if (error 'who "msg") (display 1) (display 2)) (display 3))
|
|
'(begin (if (error 'who "msg") (display 1) (display 2)) (display -3)))
|
|
(cptypes-equivalent-expansion?
|
|
'(begin (if (box? (box 0)) (error 'who "msg") (void)) (display 1))
|
|
'(begin (if (box? (box 0)) (error 'who "msg") (void)) (display -1)))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(begin (if (box? (box 0)) (void) (error 'who "msg")) (display 1))
|
|
'(begin (if (box? (box 0)) (void) (error 'who "msg")) (display -1))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) (vector? x))
|
|
'(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) (vector? x))
|
|
'(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display 1))
|
|
'(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display -1)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) (vector? x))
|
|
'(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) #t))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if y (void) (vector-set! x 0 0)) (vector? x))
|
|
'(lambda (x y) (if y (void) (vector-set! x 0 0)) #t)))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if y (vector-set! x 0 0) (void)) (vector? x))
|
|
'(lambda (x y) (if y (vector-set! x 0 0) (void)) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (vector? x) (void)))
|
|
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) #t (void))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (vector? x) (void)))
|
|
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) #t (void))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) (vector? x)))
|
|
'(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) #t))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) (vector? x)))
|
|
'(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) #t))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) (vector? (if t (vector 1) (vector 2))))
|
|
'(lambda (t) (if t (vector 1) (vector 2)) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(number? (if t 1 2.0))
|
|
'(begin (if t 1 2.0) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) (fixnum? (if t 1 2)))
|
|
'(lambda (t) (if t 1 2.0) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) (boolean? (if t #t #f)))
|
|
'(lambda (t) (if t #t #f) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t) ((lambda (x) (if x #t #f)) (if t (vector 1) (box 1))))
|
|
'(lambda (t) (if t (vector 1) (box 1)) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t)(not (if t (vector 1) (box 1))))
|
|
'(lambda (t) (if t (vector 1) (box 1)) #f))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y z f)
|
|
(let ([t (if x (vector 1) (box 1))])
|
|
(if (if y t z) (f t 1) (f t 2))))
|
|
'(lambda (x y z f)
|
|
(let ([t (if x (vector 1) (box 1))])
|
|
(if (if y #t z) (f t 1) (f t 2)))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y z f)
|
|
(let ([t (vector? x)])
|
|
(if (if y t z) (f t 1) (f t 2))))
|
|
'(lambda (x y z f)
|
|
(let ([t (vector? x)])
|
|
(if (if y #t z) (f t 1) (f t 2))))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x y z f)
|
|
(let ([t (vector? x)])
|
|
(if (if y t z) (f t 1) (f t 2))))
|
|
'(lambda (x y z f)
|
|
(let ([t (vector? x)])
|
|
(if (if y #f z) (f t 1) (f t 2))))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(if (if t (newline) (unbox b)) (vector? b) (box? b)))
|
|
'(lambda (t b)
|
|
(if (if t (newline) (unbox b)) (vector? b) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(if (if t (unbox b) (newline)) (vector? b) (box? b)))
|
|
'(lambda (t b)
|
|
(if (if t (unbox b) (newline)) (vector? b) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(if (if t #f (unbox b)) (vector? b) (box? b)))
|
|
'(lambda (t b)
|
|
(if (if t #f (unbox b)) #f (box? b))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(if (if t (unbox b) #f) (vector? b) (box? b)))
|
|
'(lambda (t b)
|
|
(if (if t (unbox b) #f) #f (box? b))))
|
|
)
|
|
|
|
(mat cptype-directly-applied-case-lambda
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t ((lambda (x y) (cons y x)) 'a 'b)])
|
|
(list t t))))
|
|
'((b . a) (b . a)))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t ((lambda (x . y) (cons y x)) 'a 'b 'c 'd)])
|
|
(list t t))))
|
|
'(((b c d) . a) ((b c d) . a)))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t ((case-lambda
|
|
[(x) (cons 'first x)]
|
|
[(x y) (cons* 'second y x)]
|
|
[(x . y) (cons* 'third y x)]) 'a 'b)])
|
|
(list t t))))
|
|
'((second b . a) (second b . a)))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t ((case-lambda
|
|
[(x) (cons 'first x)]
|
|
[(x y) (cons* 'second y x)]
|
|
[(x . y) (cons* 'third y x)]) 'a 'b 'c)])
|
|
(list t t))))
|
|
'((third (b c) . a) (third (b c) . a)))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t 'z])
|
|
((lambda args (set! t (cons args t))) 'a 'b 'c)
|
|
t)))
|
|
'((a b c) . z))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t 'z])
|
|
((lambda args (set! t (cons args t))) 'a 'b 'c)
|
|
t)))
|
|
'((a b c) . z))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t 'z])
|
|
((lambda (x . y) (set! t (cons* y x t))) 'a 'b 'c)
|
|
t)))
|
|
'((b c) a . z))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t 'z])
|
|
((case-lambda
|
|
[(x) (set! t (cons* 'first x t))]
|
|
[(x y) (set! t (cons* 'second y x t))]
|
|
[(x . y) (set! t (cons* 'third y x t))]) 'a 'b)
|
|
t)))
|
|
'(second b a . z))
|
|
(equal?
|
|
(parameterize ([enable-type-recovery #t]
|
|
[run-cp0 (lambda (cp0 x) x)])
|
|
(eval
|
|
'(let ([t 'z])
|
|
((case-lambda
|
|
[(x) (set! t (cons* 'first x t))]
|
|
[(x y) (set! t (cons* 'second y x t))]
|
|
[(x . y) (set! t (cons* 'third y x t))]) 'a 'b 'c 'd)
|
|
t)))
|
|
'(third (b c d) a . z))
|
|
)
|
|
|
|
(define (test-chain/preamble/self preamble check-self? l)
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
#t
|
|
(and (or (not check-self?)
|
|
(cptypes-equivalent-expansion?
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) (,(car l) x))))
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) #t)))))
|
|
(let loop ([t (cdr l)])
|
|
(if (null? t)
|
|
#t
|
|
(and (cptypes-equivalent-expansion?
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) (,(car t) x))))
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) #t))))
|
|
(not (cptypes-equivalent-expansion?
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car t) x) (,(car l) x))))
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car t) x) #t)))))
|
|
(loop (cdr t)))))
|
|
(loop (cdr l))))))
|
|
|
|
(define (test-chain l)
|
|
(test-chain/preamble/self '(void) #t l))
|
|
|
|
(define (test-chain* l)
|
|
(test-chain/preamble/self '(void) #f l))
|
|
|
|
(define (test-chain/preamble preamble l)
|
|
(test-chain/preamble/self preamble #t l))
|
|
|
|
(define (test-chain*/preamble l)
|
|
(test-chain/preamble/self preamble #f l))
|
|
|
|
(define (test-disjoint/preamble/self preamble check-self? l)
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
#t
|
|
(and (or (not check-self?)
|
|
(cptypes-equivalent-expansion?
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) (,(car l) x))))
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) #t)))))
|
|
(let loop ([t (cdr l)])
|
|
(if (null? t)
|
|
#t
|
|
(and (cptypes-equivalent-expansion?
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) (,(car t) x))))
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car l) x) #f))))
|
|
(cptypes-equivalent-expansion?
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car t) x) (,(car l) x))))
|
|
`(let ()
|
|
,preamble
|
|
(lambda (x) (when (,(car t) x) #f))))
|
|
(loop (cdr t)))))
|
|
(loop (cdr l))))))
|
|
|
|
(define (test-disjoint l)
|
|
(test-disjoint/preamble/self '(void) #t l))
|
|
|
|
(define (test-disjoint* l)
|
|
(test-disjoint/preamble/self '(void) #f l))
|
|
|
|
(define (test-disjoint/preamble preamble l)
|
|
(test-disjoint/preamble/self preamble #t l))
|
|
|
|
(define (test-disjoint*/preamble preamble l)
|
|
(test-disjoint/preamble/self preamble #f l))
|
|
|
|
(mat cptypes-type-implies?
|
|
(test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?))
|
|
(test-chain* '(fixnum? integer? real?))
|
|
(test-chain* '(fixnum? exact? number?)) ; exact? may raise an error
|
|
(test-chain* '((lambda (x) (eq? x (expt 256 100))) real? number?)) ; bignum?
|
|
(test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
|
|
(test-chain '(gensym? symbol?))
|
|
(test-chain '(not boolean?))
|
|
(test-chain '((lambda (x) (eq? x #t)) boolean?))
|
|
(test-chain* '(record? #3%$record?))
|
|
(test-chain* '((lambda (x) (eq? x car)) procedure?))
|
|
(test-chain* '(record-type-descriptor? #3%$record?))
|
|
(test-disjoint '(pair? box? #3%$record? number?
|
|
vector? string? bytevector? fxvector? symbol?
|
|
char? boolean? null? (lambda (x) (eq? x (void)))
|
|
eof-object? bwp-object? procedure?))
|
|
(test-disjoint '(pair? box? real? gensym? not))
|
|
(test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? x #t))))
|
|
(test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x))))
|
|
(test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?))
|
|
(test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?))
|
|
(test-disjoint* '(list? record? vector?))
|
|
(not (test-disjoint* '(list? null?)))
|
|
(not (test-disjoint* '(list? pair?)))
|
|
)
|
|
|
|
; use a gensym to make expansions equivalent
|
|
(define my-rec (gensym "my-rec"))
|
|
(mat cptypes-type-record?
|
|
; define-record
|
|
(parameterize ([optimize-level 2])
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
|
|
`(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) #t))))
|
|
(parameterize ([optimize-level 2])
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) (my-rec? x)))
|
|
`(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) #t))))
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
|
|
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
|
|
`(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
|
|
|
|
(test-chain/preamble `(define-record ,my-rec (a)) '(my-rec? #3%$record?))
|
|
(test-chain/preamble `(begin
|
|
(define-record ,my-rec (a))
|
|
(define-record ,(gensym "sub-rec") ,my-rec (b)))
|
|
'(sub-rec? my-rec? #3%$record?))
|
|
(test-disjoint/preamble `(define-record ,my-rec (a)) '(my-rec? pair? null? not number?))
|
|
(test-disjoint/preamble `(begin
|
|
(define-record ,my-rec (a))
|
|
(define-record ,(gensym "other-rec") (a)))
|
|
'(my-rec? other-rec?))
|
|
|
|
; define-record-type
|
|
(parameterize ([optimize-level 2])
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
|
|
`(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) #t))))
|
|
(parameterize ([optimize-level 2])
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) (my-rec? x)))
|
|
`(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) #t))))
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
|
|
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
|
|
`(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
|
|
|
|
(test-chain/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? #3%$record?))
|
|
#;(test-chain/preamble `(begin
|
|
(define-record-type ,my-rec (fields a))
|
|
(define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b)))
|
|
'(sub-rec? my-rec? #3%$record?))
|
|
(test-disjoint/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? pair? null? not number?))
|
|
#;(test-disjoint/preamble `(begin
|
|
(define-record-type ,my-rec (fields a))
|
|
(define-record-type ,(gensym "other-rec") (fields a)))
|
|
'(my-rec? other-rec?))
|
|
|
|
; define-record-type (sealed #t)
|
|
(parameterize ([optimize-level 2])
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
|
|
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) #t))))
|
|
(parameterize ([optimize-level 2])
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) (my-rec? x)))
|
|
`(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) #t))))
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
|
|
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
|
|
(cptypes-equivalent-expansion?
|
|
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
|
|
`(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
|
|
|
|
(test-chain/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? #3%$record?))
|
|
#;(test-chain/preamble `(begin
|
|
(define-record-type ,my-rec (fields a))
|
|
(define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b) (sealed #t)))
|
|
'(sub-rec? my-rec? #3%$record?))
|
|
(test-disjoint/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? pair? null? not number?))
|
|
#;(test-disjoint/preamble `(begin
|
|
(define-record-type ,my-rec (fields a) (sealed #t))
|
|
(define-record-type ,(gensym "other-rec") (fields a) (sealed #t)))
|
|
'(my-rec? other-rec?))
|
|
#;(test-disjoint/preamble `(begin
|
|
(define-record-type ,my-rec (fields a) (sealed #t))
|
|
(define-record-type ,(gensym "other-rec") (fields a)))
|
|
'(my-rec? other-rec?))
|
|
)
|
|
|
|
(mat cptypes-unsafe
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (pair? x) (car x)))
|
|
'(lambda (x) (when (pair? x) (#3%car x))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (pair? x) (cdr x)))
|
|
'(lambda (x) (when (pair? x) (#3%cdr x))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (pair? x) (#2%cadr x)))
|
|
'(lambda (x) (when (pair? x) (#3%cadr x)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (fxmax x y)))
|
|
'(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (#3%fxmax x y))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (fxmax x y)))
|
|
'(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (#3%fxmax x y))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (fixnum? x) (fxmax x 5)))
|
|
'(lambda (x) (when (fixnum? x) (#3%fxmax x 5))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (fxmax x y z)))
|
|
'(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (#3%fxmax x y z))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (fixnum? x) (fxzero? x)))
|
|
'(lambda (x) (when (fixnum? x) (#3%fxzero? x))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (number? x) (#2%odd? x)))
|
|
'(lambda (x) (when (number? x) (#3%odd? x)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (x) (when (number? x) (#2%exact? x)))
|
|
'(lambda (x) (when (number? x) (#3%exact? x))))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (x) (#2%exact? x))
|
|
'(lambda (x) (#3%exact? x))))
|
|
)
|
|
|
|
(mat cptypes-rest-argument
|
|
(cptypes/nocp0-equivalent-expansion?
|
|
'((lambda (x . r) (pair? r)) 1)
|
|
'((lambda (x . r) #f) 1))
|
|
(cptypes/nocp0-equivalent-expansion?
|
|
'((lambda (x . r) (null? r)) 1)
|
|
'((lambda (x . r) #t) 1))
|
|
(cptypes/nocp0-equivalent-expansion?
|
|
'((lambda (x . r) (pair? r)) 1 2)
|
|
'((lambda (x . r) #t) 1 2))
|
|
(cptypes/nocp0-equivalent-expansion?
|
|
'((lambda (x . r) (null? r)) 1 2)
|
|
'((lambda (x . r) #f) 1 2))
|
|
)
|
|
|
|
(mat cptypes-delay
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b) (map (lambda (x) (box? b)) (unbox b)))
|
|
'(lambda (b) (map (lambda (x) #t) (unbox b))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b) (list (lambda (x) (box? b)) (unbox b)))
|
|
'(lambda (b) (list (lambda (x) #t) (unbox b))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b) (list (unbox b) (lambda (x) (box? b))))
|
|
'(lambda (b) (list (unbox b) (lambda (x) #t))))
|
|
)
|
|
|
|
(mat cptypes-call-with-values
|
|
; The single value case is handled by cp0
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (v)
|
|
(call-with-values
|
|
(lambda () (vector-ref v 0))
|
|
(lambda (y) (list (vector? v) (vector-ref v 1) y))))
|
|
'(lambda (v)
|
|
(call-with-values
|
|
(lambda () (vector-ref v 0))
|
|
(lambda (y) (list #t (vector-ref v 1) y)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t)
|
|
(call-with-values
|
|
(lambda () (if t (box 2) (box 3)))
|
|
(lambda (y) (list y (box? y)))))
|
|
'(lambda (t)
|
|
(call-with-values
|
|
(lambda () (if t (box 2) (box 3)))
|
|
(lambda (y) (list y #t)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 2))
|
|
(lambda (y) (display (unbox b))))
|
|
(box? b))
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 2))
|
|
(lambda (y) (display (unbox b))))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(lambda () (if (unbox b) 1 2))
|
|
(lambda (y) (display y)))
|
|
(box? b))
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(lambda () (if (unbox b) 1 2))
|
|
(lambda (y) (display y)))
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(lambda () (if (unbox b) 1 (values 2 3)))
|
|
(lambda (x y) (list x y (box? b)))))
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(lambda () (if (unbox b) 1 (values 2 3)))
|
|
(lambda (x y) (list x y #t)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(lambda (x y) (display (list x y (unbox b)))))
|
|
(box? b))
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(lambda (x y) (display (list x y (unbox b)))))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(lambda () (if (unbox b) 1 (values 2 3)))
|
|
(lambda (x y) (display (list x y))))
|
|
(box? b))
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(lambda () (if (unbox b) 1 (values 2 3)))
|
|
(lambda (x y) (display (list x y))))
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(case-lambda
|
|
[() (if (unbox b) 1 (values 2 3))]
|
|
[(x) (error 'e "")])
|
|
(lambda (x y) (list x y (box? b)))))
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(case-lambda
|
|
[() (if (unbox b) 1 (values 2 3))]
|
|
[(x) (error 'e "")])
|
|
(lambda (x y) (list x y #t)))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(case-lambda
|
|
[(x y) (display (list x y (unbox b)))]
|
|
[(x) (error 'e "")]))
|
|
(box? b))
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(case-lambda
|
|
[(x y) (display (list x y (unbox b)))]
|
|
[(x) (error 'e "")]))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(case-lambda
|
|
[() (if (unbox b) 1 (values 2 3))]
|
|
[(x) (error 'e "")])
|
|
(lambda (x y) (display (list x y))))
|
|
(box? b))
|
|
'(lambda (b)
|
|
(call-with-values
|
|
(case-lambda
|
|
[() (if (unbox b) 1 (values 2 3))]
|
|
[(x) (error 'e "")])
|
|
(lambda (x y) (display (list x y))))
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(begin (display (unbox b)) (lambda () (if t 1 (values b 2))))
|
|
(lambda (x y) (list x y (box? b)))))
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(begin (display (unbox b)) (lambda () (if t 1 (values b 2))))
|
|
(lambda (x y) (list x y #t)))))
|
|
; This is difficult to handle in cptypes, so I ignored it.
|
|
; But it is anyway handled by cp0.
|
|
#;(cptypes-equivalent-expansion?
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values b (box? b))))
|
|
(begin (display (unbox b)) (lambda (x y) (list x y b)))))
|
|
'(lambda (t b)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values b #t)))
|
|
(begin (display (unbox b)) (lambda (x y) (list x y b))))))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t)
|
|
(number?
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(case-lambda [(x y) 2] [(x) 1]))))
|
|
'(lambda (t)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(case-lambda [(x y) 2] [(x) 1]))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t)
|
|
(number?
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(case-lambda [(x y) 2] [(x) (error 'e "")]))))
|
|
'(lambda (t)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
(case-lambda [(x y) 2] [(x) (error 'e "")]))
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t f)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
f)
|
|
(procedure? f))
|
|
'(lambda (t f)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
f)
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t f)
|
|
(call-with-values
|
|
f
|
|
(lambda (x y) (+ x y)))
|
|
(procedure? f))
|
|
'(lambda (t f)
|
|
(call-with-values
|
|
f
|
|
(lambda (x y) (+ x y)))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t f)
|
|
(when (box? f)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
f)
|
|
111))
|
|
'(lambda (t f)
|
|
(when (box? f)
|
|
(call-with-values
|
|
(lambda () (if t 1 (values 2 3)))
|
|
f)
|
|
222)))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t f)
|
|
(when (box? f)
|
|
(call-with-values
|
|
f
|
|
(lambda (x y) (+ x y)))
|
|
111))
|
|
'(lambda (t f)
|
|
(when (box? f)
|
|
(call-with-values
|
|
f
|
|
(lambda (x y) (+ x y)))
|
|
222)))
|
|
)
|
|
|
|
(mat cptypes-apply
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l b)
|
|
(apply (lambda (x) (display (list (unbox b) x))) l)
|
|
(box? b))
|
|
'(lambda (l b)
|
|
(apply (lambda (x) (display (list (unbox b) x))) l)
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l b)
|
|
(apply (lambda (x y) (display (list (unbox b) x))) 7 l)
|
|
(box? b))
|
|
'(lambda (l b)
|
|
(apply (lambda (x y) (display (list (unbox b) x))) 7 l)
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l b)
|
|
(apply (lambda (x) (display (list b x))) (unbox b))
|
|
(box? b))
|
|
'(lambda (l b)
|
|
(apply (lambda (x) (display (list b x))) (unbox b))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l b)
|
|
(apply (lambda (x y) (display (list b x y))) 7 (unbox b))
|
|
(box? b))
|
|
'(lambda (l b)
|
|
(apply (lambda (x y) (display (list b x y))) 7 (unbox b))
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
; with #3% the argument may be inlined and then executed in reverse order
|
|
'(lambda (l b)
|
|
(#2%apply (lambda (x y) (list (box? b) x y)) 7 (unbox b)))
|
|
'(lambda (l b)
|
|
(#2%apply (lambda (x y) (list #t x y)) 7 (unbox b))))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l b)
|
|
(apply
|
|
(case-lambda
|
|
[(x) (list (unbox b) x)]
|
|
[(x y) (error 'e "")])
|
|
l)
|
|
(box? b))
|
|
'(lambda (l b)
|
|
(apply
|
|
(case-lambda
|
|
[(x) (list (unbox b) x)]
|
|
[(x y) (error 'e "")])
|
|
l)
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l)
|
|
(number?
|
|
(apply (lambda (x y) (+ x y)) l)))
|
|
'(lambda (l)
|
|
(apply (lambda (x y) (+ x y)) l)
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (l)
|
|
(number?
|
|
(apply
|
|
(case-lambda
|
|
[(x y) (+ x y)]
|
|
[() (error 'e "")])
|
|
l)))
|
|
'(lambda (l)
|
|
(apply
|
|
(case-lambda
|
|
[(x y) (+ x y)]
|
|
[() (error 'e "")])
|
|
l)
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (f l)
|
|
(apply f l)
|
|
(procedure? f))
|
|
'(lambda (f l)
|
|
(apply f l)
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (t f)
|
|
(when (box? f)
|
|
(apply f l)
|
|
111))
|
|
'(lambda (t f)
|
|
(when (box? f)
|
|
(apply f l)
|
|
222)))
|
|
)
|
|
|
|
(mat cptypes-dynamic-wind
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (f)
|
|
(box? (dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f))))
|
|
'(lambda (f)
|
|
(begin
|
|
(dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f))
|
|
#t)))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f))
|
|
(box? b))
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f))
|
|
(box? b))
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f))
|
|
#t))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b)))
|
|
(box? b))
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b)))
|
|
#t))
|
|
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) (unbox b)) (lambda () (box? b)) (lambda () #f)))
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) (unbox b)) (lambda () #t) (lambda () #f))))
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () (box? b))))
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #t) )))
|
|
(not (cptypes-equivalent-expansion?
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () (box? b))))
|
|
'(lambda (b)
|
|
(dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () #t)))))
|
|
)
|
|
|
|
(mat cptypes-result-type
|
|
; test the special case for predicates
|
|
(cptypes-equivalent-expansion?
|
|
'(number? (optimize-level))
|
|
'(begin (optimize-level) #t))
|
|
; this does't work for now, test a few weaker versions
|
|
#;(cptypes-equivalent-expansion?
|
|
'(eq? (optimize-level 0) (void))
|
|
'(begin (optimize-level 0) #t))
|
|
(cptypes-equivalent-expansion?
|
|
'(number? (optimize-level 0))
|
|
'(begin (optimize-level 0) #f))
|
|
(parameterize ([optimize-level 0])
|
|
(eq? (optimize-level 0) (void)))
|
|
)
|
|
|
|
(mat cptypes-drop
|
|
(cptypes/once-equivalent-expansion?
|
|
'(pair? (list 1 (display 2) 3))
|
|
'(begin (display 2) #t))
|
|
(cptypes/once-equivalent-expansion?
|
|
'(vector? (list 1 (display 2) 3))
|
|
'(begin (display 2) #f))
|
|
(cptypes/once-equivalent-expansion?
|
|
'(pair? (list 1 (vector 2 (display 3) 4)))
|
|
'(begin (display 3) #t))
|
|
(cptypes/once-equivalent-expansion?
|
|
'(vector? (list 1 (vector 2 (display 3) 4)))
|
|
'(begin (display 3) #f))
|
|
; regression test: check that the compiler doesn't loop forever
|
|
; when the return arity is unknown
|
|
(cptypes-equivalent-expansion?
|
|
'(lambda (f) (box? (box (f))))
|
|
'(lambda (f) (#3%$value (f)) #t))
|
|
)
|