suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
f8fa08dafb
racket/mats/cptypes.ms
Gustavo Massaccesi 24be6703bf cptypes: add support for call-with-values, apply and similar functions 
In some procedures, one of the arguments is a function that will surely be called
and the result is the result of the whole expression. These procedures need an
special version of define-specialize that gives more control.

original commit: f2f0401d2b83313e8cb0d5742e89ed098500cbd6
2020-02-08 23:18:23 -03:00

1062 lines
41 KiB
Scheme
Raw Blame History

;;; 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/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)]) (number? x)))
'(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) #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)))))
)
Reference in New Issue View Git Blame Copy Permalink