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

changed ->d so that it only checks the contract just above, not many above

Browse Source 
svn: r12986
This commit is contained in:
Robby Findler 2009-01-03 16:40:54 +00:00
parent ca58e72aa0
commit 3af2ea45d0
2 changed files with 79 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -903,19 +903,6 @@ v4 todo:
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
(loop (cdr args)
(cdr non-kwd-ctcs)))])))))]
[check-and-mark
(λ (marks)
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation")))
(if marks
(with-continuation-mark ->d-tail-key (cons this->d-id marks)
(thunk))
(thunk)))]
[rng (let ([rng (->d-range ->d-stct)])
(cond
[(not rng) #f]
@ -924,50 +911,61 @@ v4 todo:
(unbox rng))]
[else rng]))]
[rng-underscore? (box? (->d-range ->d-stct))])
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation")))
(call-with-immediate-continuation-mark
->d-tail-key
(λ (first-mark)
(if (and rng
(not (and first-mark
(member this->d-id first-mark))))
(call-with-values
(λ () (check-and-mark (or first-mark '())))
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation")))
(cond
[(and rng
(not (and first-mark
(eq? this->d-id first-mark))))
(call-with-values
(λ ()
(with-continuation-mark ->d-tail-key this->d-id
(thunk)))
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation")))
(unless (= range-count (length orig-results))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str)
(loop (cdr results) (cdr result-contracts)))]))))))
(check-and-mark #f))))))])
(unless (= range-count (length orig-results))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str)
(loop (cdr results) (cdr result-contracts)))]))))))]
[else
(thunk)])))))])
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args

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

@ -5265,7 +5265,11 @@ so that propagation occurs.
(f 3))
(c)))
(ctest '(1 1)
;; the tail-call optimization cannot handle two different
;; contracts on the stack one after the other one, so this
;; returns '(4 4) instead of '(1 1) (which would indicate
;; the optimization had happened).
(ctest '(4 4)
'tail->d-mut-rec
(letrec ([odd-count 0]
[pos-count 0]
@ -5318,6 +5322,28 @@ so that propagation occurs.
(f 4))
(c)))
(ctest '(1)
'mut-rec-with-any/c
(let ()
(define f
(contract (-> number? any/c)
(lambda (x)
(if (zero? x)
(continuation-mark-set->list (current-continuation-marks) 'tail-test)
(with-continuation-mark 'tail-test x
(g (- x 1)))))
'pos
'neg))
(define g
(contract (-> number? any/c)
(lambda (x)
(f x))
'pos
'neg))
(f 3)))
;
;
;