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

add missing contract checking

Browse Source
This commit is contained in:
Robby Findler 2015-08-20 15:08:57 -05:00
parent 0ba2d30fed
commit 725536b8b4
2 changed files with 104 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt
View File

@ -241,4 +241,33 @@
#:port [port #f])
(list user db password port)))
'neg #:database "db" #:password "password" #:user "user")
(list "user" "db" "password" #f)))
(list "user" "db" "password" #f))
(test/pos-blame
'->*neg-party19
'((neg-party-fn
(->* (any/c) (#:kw any/c) boolean?)
(λ (x #:kw [kw 0]) x))
'neg 42))
(test/neg-blame
'->*neg-party20
'((neg-party-fn
(->* (any/c) (#:kw any/c) #:pre #f any/c)
(λ (x #:kw [kw 0]) x))
'neg 42))
(test/pos-blame
'->*neg-party21
'((neg-party-fn
(->* (any/c) (#:kw any/c) any/c #:post #f)
(λ (x #:kw [kw 0]) x))
'neg 42))
(test/spec-passed/result
'->*neg-party22
'((neg-party-fn
(->* (any/c) (#:kw any/c) any)
(λ (x #:kw [kw 0]) x))
'neg 42)
42))

127
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -194,7 +194,7 @@
[(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)]
[(pre-check ...)
(if pre
(list #`(check-pre-cond #,pre blame neg-party f))
(list #`(check-pre-cond #,pre blame neg-party f))
(list))]
[(post-check ...)
(if post
@ -268,70 +268,91 @@
#`(case-lambda #,@case-lambda-clauses)])]
[else
#`(make-checking-proc f blame
#,(if pre pre #'#f)
'(#,@mandatory-kwds) (list kb ...)
'(#,@optional-kwds) (list okb ...)
#,(length regular-args) (list regb ... optb ...)
#,(if rest #'restb #'#f))]))
#,(if rest #'restb #'#f)
#,(if post post #'#f)
#,(if rngs #'(list rb ...) #'#f))]))
#`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '()))
#,body-proc)))))
(define (make-checking-proc f blame
(define (make-checking-proc f blame pre
original-mandatory-kwds kbs
original-optional-kwds okbs
minimum-arg-count rbs rest-ctc)
minimum-arg-count rbs rest-ctc
post rngs)
(make-keyword-procedure
(λ (actual-kwds actual-kwd-args neg-party . regular-args)
(check-arg-count minimum-arg-count (length rbs) regular-args f blame neg-party rest-ctc)
(check-keywords original-mandatory-kwds original-optional-kwds actual-kwds f blame neg-party)
(keyword-apply
f
actual-kwds
(let loop ([kwds actual-kwds]
[kwd-args actual-kwd-args]
[mandatory-kwds original-mandatory-kwds]
[optional-kwds original-optional-kwds]
[kbs kbs]
[okbs okbs])
(cond
[(null? kwd-args) '()]
[else
(define kwd (car kwds))
(define kwd-arg (car kwd-args))
(cond
[(and (pair? mandatory-kwds)
(equal? (car mandatory-kwds) kwd))
(cons (((car kbs) kwd-arg) neg-party)
(loop (cdr kwds)
(cdr kwd-args)
(cdr mandatory-kwds)
optional-kwds
(cdr kbs)
okbs))]
[(and (pair? optional-kwds)
(equal? (car optional-kwds) kwd))
(cons (((car okbs) kwd-arg) neg-party)
(loop (cdr kwds)
(cdr kwd-args)
mandatory-kwds
(cdr optional-kwds)
kbs
(cdr okbs)))]
[(pair? optional-kwds)
(loop kwds kwd-args mandatory-kwds (cdr optional-kwds) kbs (cdr okbs))]
[else
(error 'arrow-val-first.rkt
(string-append
"internal error:\n f ~s\n actual-kwds ~s"
"\n mandatory-kwds ~s\n optional-kwds ~s\n neg-party ~s")
f actual-kwds original-mandatory-kwds original-optional-kwds neg-party)])]))
(let loop ([regular-args regular-args]
[rbs rbs])
(cond
[(null? regular-args) '()]
[(null? rbs) ((rest-ctc regular-args) neg-party)]
[else
(cons (((car rbs) (car regular-args)) neg-party)
(loop (cdr regular-args) (cdr rbs)))]))))))
(define (mk-call)
(keyword-apply
f
actual-kwds
(let loop ([kwds actual-kwds]
[kwd-args actual-kwd-args]
[mandatory-kwds original-mandatory-kwds]
[optional-kwds original-optional-kwds]
[kbs kbs]
[okbs okbs])
(cond
[(null? kwd-args) '()]
[else
(define kwd (car kwds))
(define kwd-arg (car kwd-args))
(cond
[(and (pair? mandatory-kwds)
(equal? (car mandatory-kwds) kwd))
(cons (((car kbs) kwd-arg) neg-party)
(loop (cdr kwds)
(cdr kwd-args)
(cdr mandatory-kwds)
optional-kwds
(cdr kbs)
okbs))]
[(and (pair? optional-kwds)
(equal? (car optional-kwds) kwd))
(cons (((car okbs) kwd-arg) neg-party)
(loop (cdr kwds)
(cdr kwd-args)
mandatory-kwds
(cdr optional-kwds)
kbs
(cdr okbs)))]
[(pair? optional-kwds)
(loop kwds kwd-args mandatory-kwds (cdr optional-kwds) kbs (cdr okbs))]
[else
(error 'arrow-val-first.rkt
(string-append
"internal error:\n f ~s\n actual-kwds ~s"
"\n mandatory-kwds ~s\n optional-kwds ~s\n neg-party ~s")
f actual-kwds original-mandatory-kwds original-optional-kwds neg-party)])]))
(let loop ([regular-args regular-args]
[rbs rbs])
(cond
[(null? regular-args) '()]
[(null? rbs) ((rest-ctc regular-args) neg-party)]
[else
(cons (((car rbs) (car regular-args)) neg-party)
(loop (cdr regular-args) (cdr rbs)))]))))
(define complete-blame (blame-add-missing-party blame neg-party))
(when pre (check-pre-cond pre blame neg-party f))
(cond
[rngs
(define results (call-with-values mk-call list))
(define rng-len (length rngs))
(unless (= (length results) rng-len)
(arrow:bad-number-of-results complete-blame f rng-len results))
(when post (check-post-cond post blame neg-party f))
(apply
values
(for/list ([result (in-list results)]
[rng (in-list rngs)])
((rng result) neg-party)))]
[else
(mk-call)]))))
(build-populars popular-chaperone-key-table)
(define (lookup-popular-chaperone-key regular-arg-count