From 9bc1b63ed4ab1dce6faf538aa5361aa6facda0bc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 5 Aug 2010 17:01:31 -0500 Subject: [PATCH] added support for _ in range contracts fixed a bug in blame assignment --- collects/racket/contract/private/arr-i.rkt | 54 ++++++++++++++++------ collects/racket/contract/scratch.rkt | 41 ++++++++++++++-- 2 files changed, 78 insertions(+), 17 deletions(-) diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 8345312743..95bd1edb5f 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -75,7 +75,7 @@ partial-rngs (->i-rng-dep-ctcs ctc) partial-indy-rngs)))))) - #:name (λ (ctc) '->i) ;; WRONG + #:name (λ (ctc) '(->i ...)) ;; WRONG #:first-order (λ (ctc) (λ (x) #f)) ;; WRONG #:stronger (λ (this that) #f))) ;; WRONG @@ -253,7 +253,7 @@ ;; adds nested lets that bind the wrapper-args and the indy-arg-vars to projected values, with 'body' in the body of the let ;; also handles adding code to checki to see if usupplied args are present (skipping the contract check, if so) ;; WRONG: need to rename the variables in this function from "arg" to "arg/res" -(define-for-syntax (add-wrapper-let body +(define-for-syntax (add-wrapper-let body swapped-blame? ordered-args arg-indicies arg-proj-vars indy-arg-proj-vars wrapper-args indy-arg-vars @@ -286,21 +286,32 @@ arg wrapper-arg (if (arg/res-vars arg) - #`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg indy-dom-blame) + #`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg + #,(if swapped-blame? + #'indy-dom-blame + #'indy-rng-blame)) #`(#,indy-arg-proj-var #,wrapper-arg)))]) (list))]) - #`(let (#,@indy-binding [#,wrapper-arg #,(add-unsupplied-check arg wrapper-arg - (if (arg/res-vars arg) - #`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg swapped-blame) - #`(#,arg-proj-var #,wrapper-arg)))]) + (cond + [(and (eres? arg) (arg/res-vars arg)) + #`(un-dep #,(arg/res-var arg) #,wrapper-arg + #,(if swapped-blame? + #'swapped-blame + #'blame))] + [(arg/res-vars arg) + #`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg + #,(if swapped-blame? + #'swapped-blame + #'blame))] + [else + #`(#,arg-proj-var #,wrapper-arg)]))]) #,body))))) - (define-for-syntax (add-result-checks an-istx ordered-ress res-indicies res-proj-vars indy-res-proj-vars @@ -313,6 +324,7 @@ #,(add-wrapper-let (add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress))) + #f ordered-ress res-indicies res-proj-vars indy-res-proj-vars wrapper-ress indy-res-vars @@ -320,6 +332,17 @@ [else arg-call-stx])) +(define-for-syntax (add-eres-lets an-istx res-proj-vars arg/res-to-indy-var stx) + (cond + [(ormap eres? (istx-ress an-istx)) + (with-syntax ([(vars ...) (map arg/res-var (istx-ress an-istx))] + [(rhs ...) (map (λ (res-proj-var res) + #`(#,res-proj-var #,@(map arg/res-to-indy-var (arg/res-vars res)))) + (vector->list res-proj-vars) + (istx-ress an-istx))]) + #`(let ([vars rhs] ...) #,stx))] + [else stx])) + (define-for-syntax (mk-wrapper-func an-istx used-indy-vars) (let ([args+rst (append (istx-args an-istx) (if (istx-rst an-istx) @@ -414,13 +437,18 @@ (add-pre-cond an-istx arg/res-to-indy-var - (add-result-checks + (add-eres-lets an-istx - ordered-ress res-indicies - res-proj-vars indy-res-proj-vars - wrapper-ress indy-res-vars + res-proj-vars arg/res-to-indy-var - (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args))) + (add-result-checks + an-istx + ordered-ress res-indicies + res-proj-vars indy-res-proj-vars + wrapper-ress indy-res-vars + arg/res-to-indy-var + (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args)))) + #t ordered-args arg-indicies arg-proj-vars indy-arg-proj-vars wrapper-args indy-arg-vars diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt index ef8bcba33c..55f8f53b98 100644 --- a/collects/racket/contract/scratch.rkt +++ b/collects/racket/contract/scratch.rkt @@ -3,18 +3,51 @@ racket/pretty) (pretty-print - (syntax->datum (expand-once - #'(->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c])))) + (syntax->datum + (expand-once + #'(->i ([b (box/c integer?)]) + [res (b) (λ (x) #f)])))) + +(pretty-print + (syntax->datum + (expand-once + #'(->i ([b (box/c integer?)]) + [res (λ (x) #f)])))) + #; (pretty-print (syntax->datum (expand #'(->i () [x integer?])))) +(with-handlers ((values values)) + ((contract (->i ([b any/c]) + [res (b) (λ (x) #f)]) + (lambda (b) 1) + 'pos 'neg) + 1)) -((contract (->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c]) (lambda (#:x [x 1] . w) (cons x w)) 'pos 'neg) 2 3) -;; => '(1 2 3) +(with-handlers ((values values)) + ((contract (->i ([b (box/c integer?)]) + [_ (b) + (let ([v (unbox b)]) + (λ (x) + #f))]) + (lambda (b) (set-box! b (+ (unbox b) 1))) + 'pos 'neg) + (box 0))) + +(with-handlers ((values values)) + ((contract (->i ([b (box/c integer?)]) + [res (b) + (let ([v (unbox b)]) + (λ (x) + #f))]) + (lambda (b) (set-box! b (+ (unbox b) 1))) + 'pos 'neg) + (box 0))) +;; => pos violation #| ;; timing tests: