suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed an ->i bug

Browse Source
This commit is contained in:
Robby Findler 2010-08-18 19:29:39 -05:00
parent da173fed65
commit 3885223cee
2 changed files with 55 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/racket/contract/private/arr-i.rkt
View File

@ -449,8 +449,7 @@
;; but it contains #fs in places where we don't need the indy projections (because the corresponding ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; argument is not dependened on by anything) ;; argument is not dependened on by anything)
[indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary [indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (not (arg/res-vars x)) (and (free-identifier-mapping-get used-indy-vars
(free-identifier-mapping-get used-indy-vars
(arg/res-var x) (arg/res-var x)
(λ () #f)) (λ () #f))
(arg/res-var x)))) (arg/res-var x))))
@ -465,7 +464,7 @@
;; but it contains #fs in places where we don't need the indy projections (because the corresponding ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; result is not dependened on by anything) ;; result is not dependened on by anything)
[indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary [indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (not (arg/res-vars x)) (and #;(not (arg/res-vars x))
(free-identifier-mapping-get used-indy-vars (free-identifier-mapping-get used-indy-vars
(arg/res-var x) (arg/res-var x)
(λ () #f)) (λ () #f))
@ -492,15 +491,17 @@
#,@(if (istx-post an-istx) (list #'post-proc) '()) #,@(if (istx-post an-istx) (list #'post-proc) '())
;; first the non-dependent arg projections ;; first the non-dependent arg projections
#,@(filter values (map (λ (arg arg-proj-var) (and (not (arg/res-vars arg)) arg-proj-var)) #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var))
args+rst args+rst
(vector->list arg-proj-vars))) (vector->list arg-proj-vars)))
;; then the dependent arg projections ;; then the dependent arg projections
#,@(filter values (map (λ (arg arg-proj-var) (and (arg/res-vars arg) arg-proj-var)) #,@(filter values (map (λ (arg/res arg-proj-var) (and (arg/res-vars arg/res) arg-proj-var))
args+rst args+rst
(vector->list arg-proj-vars))) (vector->list arg-proj-vars)))
;; then the non-dependent indy arg projections ;; then the non-dependent indy arg projections
#,@(filter values (vector->list indy-arg-proj-vars)) #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var))
args+rst
(vector->list indy-arg-proj-vars)))
;; then the non-dependent res projections ;; then the non-dependent res projections
@ -512,7 +513,10 @@
(or (istx-ress an-istx) '()) (or (istx-ress an-istx) '())
(vector->list res-proj-vars))) (vector->list res-proj-vars)))
;; then the non-dependent indy res projections ;; then the non-dependent indy res projections
#,@(filter values (vector->list indy-res-proj-vars))) #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var))
(or (istx-ress an-istx) '())
(vector->list indy-res-proj-vars))))
(λ (val) (λ (val)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function (make-contracted-function
@ -547,7 +551,7 @@
(let ([ctc (coerce-contract '->i ctc)]) (let ([ctc (coerce-contract '->i ctc)])
(((contract-projection ctc) blame) obj))) (((contract-projection ctc) blame) obj)))
(define-for-syntax (used-indy-vars an-istx) (define-for-syntax (mk-used-indy-vars an-istx)
(let ([vars (make-free-identifier-mapping)]) (let ([vars (make-free-identifier-mapping)])
;; add in regular arguments' uses ;; add in regular arguments' uses
@ -584,7 +588,7 @@
(define-syntax (->i/m stx) (define-syntax (->i/m stx)
(let* ([an-istx (parse-->i stx)] (let* ([an-istx (parse-->i stx)]
[used-indy-vars (used-indy-vars an-istx)] [used-indy-vars (mk-used-indy-vars an-istx)]
[wrapper-func (mk-wrapper-func an-istx used-indy-vars)] [wrapper-func (mk-wrapper-func an-istx used-indy-vars)]
[args+rst (append (istx-args an-istx) [args+rst (append (istx-args an-istx)
(if (istx-rst an-istx) (if (istx-rst an-istx)

42
collects/tests/racket/contract-test.rktl
View File

@ -2433,6 +2433,48 @@
(unbox b)) (unbox b))
'(5 4 3 2 1)) '(5 4 3 2 1))
(test/spec-passed/result
'->i44
'((contract (->i ([x () any/c])
[y any/c]
#:post (x) x)
(lambda (x) x)
'pos
'neg)
#t)
'#t)
(test/pos-blame
'->i45
'((contract (->i ([x () any/c])
[y any/c]
#:post (x) x)
(lambda (x) x)
'pos
'neg)
#f))
(test/spec-passed/result
'->i46
'((contract (->i ([x any/c])
[y () any/c]
#:post (y) y)
(lambda (x) x)
'pos
'neg)
#t)
'#t)
(test/pos-blame
'->i47
'((contract (->i ([x any/c])
[y () any/c]
#:post (y) y)
(lambda (x) x)
'pos
'neg)
#f))
(test/pos-blame (test/pos-blame
'->i-arity1 '->i-arity1
'(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))