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

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

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

@ -5265,7 +5265,11 @@ so that propagation occurs.
(f 3)) (f 3))
(c))) (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 'tail->d-mut-rec
(letrec ([odd-count 0] (letrec ([odd-count 0]
[pos-count 0] [pos-count 0]
@ -5318,6 +5322,28 @@ so that propagation occurs.
(f 4)) (f 4))
(c))) (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)))
; ;
; ;
; ;