use unsafe-{chaperone,impersonate}-procedure in racket/contract
for contracts where the arity of the given function is exactly the arity that the contract expects (i.e. no optional arguments are turned into madatory or dropped)
This commit is contained in:
Robby Findler
parent
41c8d5bc27
commit
308c918a42
|
|
@ -154,36 +154,46 @@
|
|||
[(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
|
||||
[(rng-late-neg-projs ...) (if rngs rngs '())]
|
||||
[(rng-x ...) (if rngs (generate-temporaries rngs) '())])
|
||||
(with-syntax ([(rng-checker-name ...)
|
||||
(if rngs
|
||||
(list (gen-id 'rng-checker))
|
||||
null)]
|
||||
[(rng-checker ...)
|
||||
(if rngs
|
||||
(list
|
||||
(with-syntax ([rng-len (length rngs)])
|
||||
(with-syntax ([rng-results
|
||||
#'(values (rng-late-neg-projs rng-x neg-party)
|
||||
...)])
|
||||
#'(case-lambda
|
||||
[(rng-x ...)
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
post ...
|
||||
rng-results))]
|
||||
[args
|
||||
(arrow:bad-number-of-results blame val rng-len args
|
||||
#:missing-party neg-party)]))))
|
||||
null)])
|
||||
|
||||
(define rng-checker
|
||||
(and rngs
|
||||
(with-syntax ([rng-len (length rngs)]
|
||||
[rng-results #'(values (rng-late-neg-projs rng-x neg-party) ...)])
|
||||
#'(case-lambda
|
||||
[(rng-x ...)
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
post ...
|
||||
rng-results))]
|
||||
[args
|
||||
(arrow:bad-number-of-results blame val rng-len args
|
||||
#:missing-party neg-party)]))))
|
||||
(define (wrap-call-with-values-and-range-checking stx)
|
||||
(if rngs
|
||||
;; with this version, the unsafe-procedure-chaperone
|
||||
;; wrappers would work only when the number of values
|
||||
;; the function returns is known to be a match for
|
||||
;; what the contract wants.
|
||||
#;
|
||||
#`(let-values ([(rng-x ...) #,stx])
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
post ...
|
||||
(values (rng-late-neg-projs rng-x neg-party) ...))))
|
||||
#`(call-with-values
|
||||
(λ () #,stx)
|
||||
#,rng-checker)
|
||||
stx))
|
||||
|
||||
(let* ([min-method-arity (length doms)]
|
||||
[max-method-arity (+ min-method-arity (length opt-doms))]
|
||||
[min-arity (+ (length this-args) min-method-arity)]
|
||||
[max-arity (+ min-arity (length opt-doms))]
|
||||
[req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
|
||||
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
|
||||
[need-apply-values? (or dom-rest (not (null? opt-doms)))]
|
||||
[no-rng-checking? (not rngs)])
|
||||
[need-apply? (or dom-rest (not (null? opt-doms)))])
|
||||
(with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)]
|
||||
[basic-params
|
||||
(cond
|
||||
|
|
@ -227,6 +237,7 @@
|
|||
(for/fold ([s #'null])
|
||||
([tx (in-list (map cdr put-in-reverse))])
|
||||
(tx s)))])
|
||||
|
||||
(with-syntax ([kwd-lam-params
|
||||
(if dom-rest
|
||||
#'(this-param ...
|
||||
|
|
@ -239,7 +250,7 @@
|
|||
kwd-param ...))]
|
||||
[basic-return
|
||||
(let ([inner-stx-gen
|
||||
(if need-apply-values?
|
||||
(if need-apply?
|
||||
(λ (s) #`(apply values #,@s
|
||||
this-param ...
|
||||
dom-projd-args ...
|
||||
|
|
@ -248,16 +259,41 @@
|
|||
#,@s
|
||||
this-param ...
|
||||
dom-projd-args ...)))])
|
||||
(if no-rng-checking?
|
||||
(inner-stx-gen #'())
|
||||
(if rngs
|
||||
(arrow:check-tail-contract rng-ctcs
|
||||
blame-party-info
|
||||
neg-party
|
||||
#'(rng-checker-name ...)
|
||||
inner-stx-gen)))]
|
||||
(list rng-checker)
|
||||
inner-stx-gen)
|
||||
(inner-stx-gen #'())))]
|
||||
[basic-unsafe-return
|
||||
(let ([inner-stx-gen
|
||||
(λ (stuff)
|
||||
(define the-call/no-marks
|
||||
(if need-apply?
|
||||
#`(apply val
|
||||
this-param ...
|
||||
dom-projd-args ...
|
||||
opt+rest-uses)
|
||||
#`(val this-param ... dom-projd-args ...)))
|
||||
(define the-call
|
||||
#`(with-continuation-mark arrow:tail-contract-key
|
||||
(list* neg-party blame-party-info #,rng-ctcs)
|
||||
#,the-call/no-marks))
|
||||
(cond
|
||||
[(null? (syntax-e stuff)) ;; surely there must a better way
|
||||
the-call]
|
||||
[else (wrap-call-with-values-and-range-checking the-call)]))])
|
||||
(if rngs
|
||||
(arrow:check-tail-contract rng-ctcs
|
||||
blame-party-info
|
||||
neg-party
|
||||
#'not-a-null
|
||||
inner-stx-gen)
|
||||
(inner-stx-gen #'())))]
|
||||
[kwd-return
|
||||
(let* ([inner-stx-gen
|
||||
(if need-apply-values?
|
||||
(if need-apply?
|
||||
(λ (s k) #`(apply values
|
||||
#,@s #,@k
|
||||
this-param ...
|
||||
|
|
@ -275,83 +311,80 @@
|
|||
(λ (s)
|
||||
(inner-stx-gen s #'(kwd-results))))])
|
||||
#`(let ([kwd-results kwd-stx])
|
||||
#,(if no-rng-checking?
|
||||
(outer-stx-gen #'())
|
||||
#,(if rngs
|
||||
(arrow:check-tail-contract rng-ctcs
|
||||
blame-party-info
|
||||
neg-party
|
||||
#'(rng-checker-name ...)
|
||||
outer-stx-gen))))])
|
||||
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
|
||||
[basic-lambda #'(λ basic-params
|
||||
;; Arrow contract domain checking is instrumented
|
||||
;; both here, and in `arity-checking-wrapper'.
|
||||
;; We need to instrument here, because sometimes
|
||||
;; a-c-w doesn't wrap, and just returns us.
|
||||
;; We need to instrument in a-c-w to count arity
|
||||
;; checking time.
|
||||
;; Overhead of double-wrapping has not been
|
||||
;; noticeable in my measurements so far.
|
||||
;; - stamourv
|
||||
(list rng-checker)
|
||||
outer-stx-gen)
|
||||
(outer-stx-gen #'()))))])
|
||||
|
||||
;; Arrow contract domain checking is instrumented
|
||||
;; both here, and in `arity-checking-wrapper'.
|
||||
;; We need to instrument here, because sometimes
|
||||
;; a-c-w doesn't wrap, and just returns us.
|
||||
;; We need to instrument in a-c-w to count arity
|
||||
;; checking time.
|
||||
;; Overhead of double-wrapping has not been
|
||||
;; noticeable in my measurements so far.
|
||||
;; - stamourv
|
||||
(with-syntax ([basic-lambda #'(λ basic-params
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
pre ... basic-return)))]
|
||||
[basic-unsafe-lambda #'(λ basic-params
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
pre ... basic-unsafe-return)))]
|
||||
[kwd-lambda-name (gen-id 'kwd-lambda)]
|
||||
[kwd-lambda #`(λ kwd-lam-params
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(let ()
|
||||
pre ... kwd-return)))])
|
||||
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
|
||||
(cond
|
||||
[(and (null? req-keywords) (null? opt-keywords))
|
||||
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
|
||||
(let ([basic-lambda-name basic-lambda])
|
||||
(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
basic-lambda-name
|
||||
void
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))))]
|
||||
[(pair? req-keywords)
|
||||
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
|
||||
(let ([kwd-lambda-name kwd-lambda])
|
||||
(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
void
|
||||
kwd-lambda-name
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))))]
|
||||
[else
|
||||
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
|
||||
(let ([basic-lambda-name basic-lambda]
|
||||
[kwd-lambda-name kwd-lambda])
|
||||
(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
basic-lambda-name
|
||||
kwd-lambda-name
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))))])))))))))))
|
||||
(cond
|
||||
[(and (null? req-keywords) (null? opt-keywords))
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
basic-lambda basic-unsafe-lambda
|
||||
void
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))]
|
||||
[(pair? req-keywords)
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
void #t
|
||||
kwd-lambda
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))]
|
||||
[else
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party
|
||||
basic-lambda #t
|
||||
kwd-lambda
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))])))))))))
|
||||
|
||||
(define (maybe-cons-kwd c x r neg-party)
|
||||
(if (eq? arrow:unspecified-dom x)
|
||||
r
|
||||
(cons (c x neg-party) r)))
|
||||
|
||||
(define (->-proj chaperone-or-impersonate-procedure ctc
|
||||
(define (->-proj chaperone? ctc
|
||||
;; fields of the 'ctc' struct
|
||||
min-arity doms kwd-infos rest pre? rngs post?
|
||||
plus-one-arity-function chaperone-constructor
|
||||
|
|
@ -414,10 +447,15 @@
|
|||
(if partial-rest (list partial-rest) '())))
|
||||
(define blame-party-info (arrow:get-blame-party-info orig-blame))
|
||||
(define (successfully-got-the-right-kind-of-function val neg-party)
|
||||
(define chap/imp-func (apply chaperone-constructor
|
||||
orig-blame val
|
||||
neg-party blame-party-info
|
||||
rngs the-args))
|
||||
(define-values (chap/imp-func use-unsafe-chaperone-procedure?)
|
||||
(apply chaperone-constructor
|
||||
orig-blame val
|
||||
neg-party blame-party-info
|
||||
rngs the-args))
|
||||
(define chaperone-or-impersonate-procedure
|
||||
(if use-unsafe-chaperone-procedure?
|
||||
(if chaperone? unsafe-chaperone-procedure unsafe-impersonate-procedure)
|
||||
(if chaperone? chaperone-procedure impersonate-procedure)))
|
||||
(cond
|
||||
[chap/imp-func
|
||||
(if (or post? (not rngs))
|
||||
|
|
|
|||
|
|
@ -962,11 +962,12 @@
|
|||
(cons result-checker args-dealt-with)
|
||||
args-dealt-with)))))
|
||||
|
||||
(arrow:arity-checking-wrapper f blame neg-party
|
||||
interposition-proc interposition-proc
|
||||
min-arity max-arity
|
||||
min-arity max-arity
|
||||
mandatory-keywords optional-keywords))))
|
||||
(values (arrow:arity-checking-wrapper f blame neg-party
|
||||
interposition-proc #f interposition-proc
|
||||
min-arity max-arity
|
||||
min-arity max-arity
|
||||
mandatory-keywords optional-keywords)
|
||||
#f))))
|
||||
|
||||
(build--> 'dynamic->*
|
||||
mandatory-domain-contracts optional-domain-contracts
|
||||
|
|
@ -1159,11 +1160,13 @@
|
|||
(arrow:keywords-match man-kwds opt-kwds x)
|
||||
#t))
|
||||
|
||||
(define (make-property build-X-property chaperone-or-impersonate-procedure)
|
||||
(define (make-property chaperone?)
|
||||
(define build-X-property
|
||||
(if chaperone? build-chaperone-contract-property build-contract-property))
|
||||
(define val-first-proj
|
||||
(λ (->stct)
|
||||
(maybe-warn-about-val-first ->stct)
|
||||
(->-proj chaperone-or-impersonate-procedure ->stct
|
||||
(->-proj chaperone? ->stct
|
||||
(base->-min-arity ->stct)
|
||||
(base->-doms ->stct)
|
||||
(base->-kwd-infos ->stct)
|
||||
|
|
@ -1176,7 +1179,7 @@
|
|||
#f)))
|
||||
(define late-neg-proj
|
||||
(λ (->stct)
|
||||
(->-proj chaperone-or-impersonate-procedure ->stct
|
||||
(->-proj chaperone? ->stct
|
||||
(base->-min-arity ->stct)
|
||||
(base->-doms ->stct)
|
||||
(base->-kwd-infos ->stct)
|
||||
|
|
@ -1227,19 +1230,13 @@
|
|||
(not (base->-post? that))))
|
||||
|
||||
(define-struct (-> base->) ()
|
||||
#:property
|
||||
prop:chaperone-contract
|
||||
(make-property build-chaperone-contract-property chaperone-procedure))
|
||||
#:property prop:chaperone-contract (make-property #t))
|
||||
|
||||
(define-struct (predicate/c base->) ()
|
||||
#:property
|
||||
prop:chaperone-contract
|
||||
(make-property build-chaperone-contract-property chaperone-procedure))
|
||||
#:property prop:chaperone-contract (make-property #t))
|
||||
|
||||
(define-struct (impersonator-> base->) ()
|
||||
#:property
|
||||
prop:contract
|
||||
(make-property build-contract-property impersonate-procedure))
|
||||
#:property prop:contract (make-property #f))
|
||||
|
||||
(define ->void-contract
|
||||
(let-syntax ([get-chaperone-constructor
|
||||
|
|
@ -1303,25 +1300,27 @@
|
|||
'(expected: "a procedure that accepts 1 non-keyword argument"
|
||||
given: "~e")
|
||||
f))
|
||||
(cond
|
||||
[(and (struct-predicate-procedure? f)
|
||||
(not (impersonator? f)))
|
||||
#f]
|
||||
[(and (equal? (procedure-arity f) 1)
|
||||
(let-values ([(required mandatory) (procedure-keywords f)])
|
||||
(and (null? required)
|
||||
(null? mandatory))))
|
||||
(λ (arg)
|
||||
(values (rng-checker f blame neg-party) arg))]
|
||||
[(procedure-arity-includes? f 1)
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . other)
|
||||
(unless (null? kwds)
|
||||
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds))
|
||||
(unless (= 1 (length other))
|
||||
(arrow:raise-wrong-number-of-args-error #:missing-party neg-party
|
||||
blame f (length other) 1 1 1))
|
||||
(values (rng-checker f blame neg-party) (car other))))]))))
|
||||
(values (cond
|
||||
[(and (struct-predicate-procedure? f)
|
||||
(not (impersonator? f)))
|
||||
#f]
|
||||
[(and (equal? (procedure-arity f) 1)
|
||||
(let-values ([(required mandatory) (procedure-keywords f)])
|
||||
(and (null? required)
|
||||
(null? mandatory))))
|
||||
(λ (arg)
|
||||
(values (rng-checker f blame neg-party) arg))]
|
||||
[(procedure-arity-includes? f 1)
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . other)
|
||||
(unless (null? kwds)
|
||||
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds))
|
||||
(unless (= 1 (length other))
|
||||
(arrow:raise-wrong-number-of-args-error
|
||||
#:missing-party neg-party
|
||||
blame f (length other) 1 1 1))
|
||||
(values (rng-checker f blame neg-party) (car other))))])
|
||||
#f))))
|
||||
|
||||
(define -predicate/c (mk-any/c->boolean-contract predicate/c))
|
||||
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->))
|
||||
|
|
|
|||
|
|
@ -398,7 +398,7 @@
|
|||
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
|
||||
(let ([basic-lambda-name basic-lambda])
|
||||
(arity-checking-wrapper val blame neg-party
|
||||
basic-lambda-name
|
||||
basic-lambda-name #f
|
||||
void
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -410,7 +410,7 @@
|
|||
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
|
||||
(let ([kwd-lambda-name kwd-lambda])
|
||||
(arity-checking-wrapper val blame neg-party
|
||||
void
|
||||
void #f
|
||||
kwd-lambda-name
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -423,7 +423,7 @@
|
|||
(let ([basic-lambda-name basic-lambda]
|
||||
[kwd-lambda-name kwd-lambda])
|
||||
(arity-checking-wrapper val blame neg-party
|
||||
basic-lambda-name
|
||||
basic-lambda-name #f
|
||||
kwd-lambda-name
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
|
|
@ -433,15 +433,25 @@
|
|||
'(opt-kwd ...))))])))))))))))
|
||||
|
||||
;; should we pass both the basic-lambda and the kwd-lambda?
|
||||
(define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda
|
||||
;; if basic-unsafe-lambda is #f, returns only the one value,
|
||||
;; namely the chaperone wrapper. Otherwise, returns two values,
|
||||
;; a procedure and a boolean indicating it the procedure is the
|
||||
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
|
||||
;; also be #f, but that happens only when we know that basic-lambda
|
||||
;; can't be chosen (because there are keywords involved)
|
||||
(define (arity-checking-wrapper val blame neg-party basic-lambda basic-unsafe-lambda kwd-lambda
|
||||
min-method-arity max-method-arity min-arity max-arity
|
||||
req-kwd opt-kwd)
|
||||
;; should not build this unless we are in the 'else' case (and maybe not at all)
|
||||
(cond
|
||||
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
|
||||
(if (and (null? req-kwd) (null? opt-kwd))
|
||||
basic-lambda
|
||||
kwd-lambda)]
|
||||
(if (and (null? req-kwd) (null? opt-kwd))
|
||||
(if basic-unsafe-lambda
|
||||
(values basic-unsafe-lambda #t)
|
||||
basic-lambda)
|
||||
(if basic-unsafe-lambda
|
||||
(values kwd-lambda #f)
|
||||
kwd-lambda))]
|
||||
[else
|
||||
(define-values (vr va) (procedure-keywords val))
|
||||
(define all-kwds (append req-kwd opt-kwd))
|
||||
|
|
@ -493,9 +503,13 @@
|
|||
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
|
||||
"expected required keyword ~a"
|
||||
(car req-kwd)))))
|
||||
(if (or (not va) (pair? vr) (pair? va))
|
||||
(make-keyword-procedure kwd-checker basic-checker-name)
|
||||
basic-checker-name)]))
|
||||
(define proc
|
||||
(if (or (not va) (pair? vr) (pair? va))
|
||||
(make-keyword-procedure kwd-checker basic-checker-name)
|
||||
basic-checker-name))
|
||||
(if basic-unsafe-lambda
|
||||
(values proc #f)
|
||||
proc)]))
|
||||
|
||||
(define (raise-wrong-number-of-args-error
|
||||
blame #:missing-party [missing-party #f] val
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user