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

added support for _ in range contracts

Browse Source 
fixed a bug in blame assignment
This commit is contained in:
Robby Findler 2010-08-05 17:01:31 -05:00
parent da9f5bd61a
commit 9bc1b63ed4
2 changed files with 78 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -75,7 +75,7 @@
partial-rngs partial-rngs
(->i-rng-dep-ctcs ctc) (->i-rng-dep-ctcs ctc)
partial-indy-rngs)))))) partial-indy-rngs))))))
#:name (λ (ctc) '->i) ;; WRONG #:name (λ (ctc) '(->i ...)) ;; WRONG
#:first-order (λ (ctc) (λ (x) #f)) ;; WRONG #:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
#:stronger (λ (this that) #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 ;; 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) ;; 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" ;; 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 ordered-args arg-indicies
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
wrapper-args indy-arg-vars wrapper-args indy-arg-vars
@ -286,21 +286,32 @@
arg arg
wrapper-arg wrapper-arg
(if (arg/res-vars 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)))]) #`(#,indy-arg-proj-var #,wrapper-arg)))])
(list))]) (list))])
#`(let (#,@indy-binding #`(let (#,@indy-binding
[#,wrapper-arg [#,wrapper-arg
#,(add-unsupplied-check #,(add-unsupplied-check
arg arg
wrapper-arg wrapper-arg
(if (arg/res-vars arg) (cond
#`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg swapped-blame) [(and (eres? arg) (arg/res-vars arg))
#`(#,arg-proj-var #,wrapper-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))))) #,body)))))
(define-for-syntax (add-result-checks an-istx (define-for-syntax (add-result-checks an-istx
ordered-ress res-indicies ordered-ress res-indicies
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
@ -313,6 +324,7 @@
#,(add-wrapper-let #,(add-wrapper-let
(add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress))) (add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress)))
#f
ordered-ress res-indicies ordered-ress res-indicies
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
@ -320,6 +332,17 @@
[else [else
arg-call-stx])) 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) (define-for-syntax (mk-wrapper-func an-istx used-indy-vars)
(let ([args+rst (append (istx-args an-istx) (let ([args+rst (append (istx-args an-istx)
(if (istx-rst an-istx) (if (istx-rst an-istx)
@ -414,13 +437,18 @@
(add-pre-cond (add-pre-cond
an-istx an-istx
arg/res-to-indy-var arg/res-to-indy-var
(add-eres-lets
an-istx
res-proj-vars
arg/res-to-indy-var
(add-result-checks (add-result-checks
an-istx an-istx
ordered-ress res-indicies ordered-ress res-indicies
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
arg/res-to-indy-var arg/res-to-indy-var
(args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args))) (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args))))
#t
ordered-args arg-indicies ordered-args arg-indicies
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
wrapper-args indy-arg-vars wrapper-args indy-arg-vars

41
collects/racket/contract/scratch.rkt
View File

@ -3,18 +3,51 @@
racket/pretty) racket/pretty)
(pretty-print (pretty-print
(syntax->datum (expand-once (syntax->datum
#'(->i () (#:x [x integer?]) #:rest [rst (listof number?)] [r any/c])))) (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 (pretty-print
(syntax->datum (expand (syntax->datum (expand
#'(->i () [x integer?])))) #'(->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: ;; timing tests: