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

fixed a bug in the ->d contract checking (wrt tail dropping)

Browse Source 
svn: r12987
This commit is contained in:
Robby Findler 2009-01-03 16:57:46 +00:00
parent 3af2ea45d0
commit 97e00eef97
2 changed files with 47 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scheme/private/contract-arrow.ss
View File

@ -924,10 +924,11 @@ v4 todo:
(cond (cond
[(and rng [(and rng
(not (and first-mark (not (and first-mark
(eq? this->d-id first-mark)))) (eq? this->d-id (car first-mark))
(andmap eq? raw-orig-args (cdr first-mark)))))
(call-with-values (call-with-values
(λ () (λ ()
(with-continuation-mark ->d-tail-key this->d-id (with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
(thunk))) (thunk)))
(λ orig-results (λ orig-results
(let* ([range-count (length rng)] (let* ([range-count (length rng)]

48
collects/tests/mzscheme/contract-test.ss
View File

@ -5243,8 +5243,10 @@ so that propagation occurs.
(c))) (c)))
(ctest 2 ;; this one is not tail recursive, since the contract system
'tail-arrow-d1 ;; cannot tell that the range contract doesn't depend on 'arg'
(ctest 8
'tail-arrow-d1/changing-args
(let ([c (counter)]) (let ([c (counter)])
(letrec ([f (letrec ([f
(contract (->d ([arg any/c]) () (values [_ c] [_ c])) (contract (->d ([arg any/c]) () (values [_ c] [_ c]))
@ -5254,8 +5256,22 @@ so that propagation occurs.
(f 3)) (f 3))
(c))) (c)))
(ctest 1 (ctest 2
'tail-arrow-d2 'tail-arrow-d1
(let ([c (counter)])
(letrec ([x 5]
[f
(contract (->d ([arg any/c]) () (values [_ c] [_ c]))
(λ (_ignored) (if (zero? x) (values x x) (begin (set! x (- x 1)) (f _ignored))))
'pos
'neg)])
(f 'ignored))
(c)))
;; this one is just like the one two above.
(ctest 4
'tail-arrow-d2/changing-args
(let ([c (counter)]) (let ([c (counter)])
(letrec ([f (letrec ([f
(contract (->d ([arg any/c]) () [rng c]) (contract (->d ([arg any/c]) () [rng c])
@ -5265,6 +5281,18 @@ so that propagation occurs.
(f 3)) (f 3))
(c))) (c)))
(ctest 1
'tail-arrow-d2
(let ([c (counter)])
(letrec ([x 3]
[f
(contract (->d ([arg any/c]) () [rng c])
(λ (ignored) (if (zero? x) x (begin (set! x (- x 1)) (f ignored))))
'pos
'neg)])
(f 3))
(c)))
;; the tail-call optimization cannot handle two different ;; the tail-call optimization cannot handle two different
;; contracts on the stack one after the other one, so this ;; contracts on the stack one after the other one, so this
;; returns '(4 4) instead of '(1 1) (which would indicate ;; returns '(4 4) instead of '(1 1) (which would indicate
@ -5344,6 +5372,18 @@ so that propagation occurs.
(f 3))) (f 3)))
(test/pos-blame 'free-vars-change-so-cannot-drop-the-check
'(let ()
(define f
(contract (->d ([x number?]) () [_ (</c x)])
(lambda (x)
(cond
[(= x 0) 1]
[else (f 0)]))
'pos
'neg))
(f 10)))
; ;
; ;
; ;