diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt
index cad1d22315..9cbd404757 100644
--- a/racket/collects/racket/contract/private/arrow-higher-order.rkt
+++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt
@@ -539,6 +539,8 @@
arrow-higher-order:lnp)]
[else
(define (arrow-higher-order:vfp val)
+ (define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
+ (apply plus-one-arity-function orig-blame val plus-one-constructor-args))
(wrapped-extra-arg-arrow
(cond
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
@@ -547,14 +549,18 @@
[else
(λ (neg-party)
(successfully-got-the-right-kind-of-function val neg-party))])
- (apply plus-one-arity-function orig-blame val plus-one-constructor-args)))
+ (if (equal? (procedure-result-arity val) expected-number-of-results)
+ proc-with-no-result-checking
+ normal-proc)))
(if okay-to-do-only-arity-check?
(λ (val)
(cond
[(procedure-arity-exactly/no-kwds val min-arity)
+ (define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
+ (apply plus-one-arity-function orig-blame val plus-one-constructor-args))
(wrapped-extra-arg-arrow
(λ (neg-party) val)
- (apply plus-one-arity-function orig-blame val plus-one-constructor-args))]
+ normal-proc)]
[else (arrow-higher-order:vfp val)]))
arrow-higher-order:vfp)])))
diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
index 6ceb0345ea..42f07e8c38 100644
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -238,7 +238,7 @@
(list #`(check-post-cond #,post blame neg-party f))
(list))]
[(restb) (generate-temporaries '(rest-args))])
- (define body-proc
+ (define (make-body-proc range-checking?)
(cond
[(or (and (null? optional-args)
(null? optional-kwds))
@@ -286,31 +286,47 @@
#`[#,the-args
(let ([blame+neg-party (cons blame neg-party)])
pre-check ...
- (define-values (failed res-x ...)
- (call-with-values
- (λ () (let-values (#,let-values-clause)
- #,full-call))
- (case-lambda
- [(res-x ...)
- (values #f res-x ...)]
- [args
- (values args #,@(map (λ (x) #'#f)
- (syntax->list #'(res-x ...))))])))
- (with-contract-continuation-mark
- blame+neg-party
- (cond
- [failed
- (wrong-number-of-results-blame
- blame neg-party f
- failed
- #,(length
- (syntax->list
- #'(res-x ...))))]
- [else
- post-check ...
- (values
- (rb res-x neg-party)
- ...)])))]
+ #,@
+ (cond
+ [range-checking?
+ (list
+ #`(define-values (failed res-x ...)
+ (call-with-values
+ (λ () (let-values (#,let-values-clause)
+ #,full-call))
+ (case-lambda
+ [(res-x ...)
+ (values #f res-x ...)]
+ [args
+ (values args #,@(map (λ (x) #'#f)
+ (syntax->list #'(res-x ...))))])))
+ #`(with-contract-continuation-mark
+ blame+neg-party
+ (cond
+ [failed
+ (wrong-number-of-results-blame
+ blame neg-party f
+ failed
+ #,(length
+ (syntax->list
+ #'(res-x ...))))]
+ [else
+ post-check ...
+ (values
+ (rb res-x neg-party)
+ ...)])))]
+ [else
+ (list
+ #`(define-values (res-x ...)
+ (let-values (#,let-values-clause)
+ #,full-call))
+ #`(with-contract-continuation-mark
+ blame+neg-party
+ (begin
+ post-check ...
+ (values
+ (rb res-x neg-party)
+ ...))))]))]
#`[#,the-args
pre-check ...
(let ([blame+neg-party (cons blame neg-party)])
@@ -339,9 +355,24 @@
#,(if rest #'restb #'#f)
#,(if post post #'#f)
#,(if rngs #'(list rb ...) #'#f))]))
+ (define body-proc (make-body-proc #t))
+ (define body-proc/no-range-checking (make-body-proc #f))
+ (define number-of-rngs (and rngs (with-syntax ([rngs rngs]) (length (syntax->list #'rngs)))))
#`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '()))
- (procedure-specialize
- #,body-proc))))))
+ (values
+ (procedure-specialize
+ #,body-proc)
+ #,(if rngs
+ #`(procedure-specialize
+ #,body-proc/no-range-checking)
+ #'shouldnt-be-called)
+ '#,(if rngs number-of-rngs 'there-is-no-range-contract)))))))
+
+(define (shouldnt-be-called . args)
+ (error 'arrow-val-first.rkt
+ (string-append
+ "this function should not ever be called because"
+ " procedure-result-arity shouldn't return 'there-is-no-range-contract")))
(define (make-checking-proc f blame pre
original-mandatory-kwds kbs
@@ -906,9 +937,11 @@
[else (cons (car _args) (loop (- n 1) (cdr _args)))]))))
(define (plus-one-arity-function blame f . args)
- (make-keyword-procedure
- (λ (kwds kwd-args . regular-args)
- (error 'plus-one-arity-function "not implemented for dynamic->*"))))
+ (define f
+ (make-keyword-procedure
+ (λ (kwds kwd-args . regular-args)
+ (error 'plus-one-arity-function "not implemented for dynamic->*"))))
+ (values f f 'not-a-number-so-it-doesnt-match-any-result-from-procedure-result-arity))
(define min-arity (length mandatory-domain-contracts))
(define optionals (length optional-domain-contracts))
@@ -1268,39 +1301,54 @@
(list (coerce-contract 'whatever void?))
#f
(λ (blame f _ignored-rng-ctcs _ignored-rng-proj)
- (λ (neg-party)
- (call-with-values
- (λ () (f))
- (case-lambda
- [(rng)
- (if (void? rng)
- rng
- (raise-blame-error blame #:missing-party neg-party rng
- '(expected: "void?" given: "~e")
- rng))]
- [args
- (wrong-number-of-results-blame blame neg-party f args 1)]))))
+ (values
+ (λ (neg-party)
+ (call-with-values
+ (λ () (f))
+ (case-lambda
+ [(rng)
+ (if (void? rng)
+ rng
+ (raise-blame-error blame #:missing-party neg-party rng
+ '(expected: "void?" given: "~e")
+ rng))]
+ [args
+ (wrong-number-of-results-blame blame neg-party f args 1)])))
+ (λ (neg-party)
+ (let ([rng (f)])
+ (if (void? rng)
+ rng
+ (raise-blame-error blame #:missing-party neg-party rng
+ '(expected: "void?" given: "~e")
+ rng))))
+ 1))
(get-chaperone-constructor))))
(define (mk-any/c->boolean-contract constructor)
+ (define (check-result blame neg-party rng)
+ (if (boolean? rng)
+ rng
+ (raise-blame-error blame #:missing-party neg-party rng
+ '(expected: "boolean?" given: "~e")
+ rng)))
(define (rng-checker f blame neg-party)
(case-lambda
[(rng)
- (if (boolean? rng)
- rng
- (raise-blame-error blame #:missing-party neg-party rng
- '(expected: "boolean?" given: "~e")
- rng))]
+ (check-result blame neg-party rng)]
[args
(wrong-number-of-results-blame blame neg-party f args 1)]))
(constructor 1 (list any/c) '() #f #f
(list (coerce-contract 'whatever boolean?))
#f
(λ (blame f _ignored-dom-contract _ignored-rng-contract)
- (λ (neg-party argument)
- (call-with-values
- (λ () (f argument))
- (rng-checker f blame neg-party))))
+ (values
+ (λ (neg-party argument)
+ (call-with-values
+ (λ () (f argument))
+ (rng-checker f blame neg-party)))
+ (λ (neg-party argument)
+ (check-result blame neg-party (f argument)))
+ 1))
(λ (blame f neg-party
_ignored-blame-party-info
_ignored-rng-ctcs