diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 572d8cb3b0..29c8a62c34 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -177,15 +177,19 @@ [args (arrow:bad-number-of-results blame val rng-len args #:missing-party neg-party)])))) - (define (wrap-call-with-values-and-range-checking stx assume-result-values?) + (define (wrap-call-with-values-and-range-checking stx assume-result-values? do-tail-check?) (if rngs (if assume-result-values? - #`(let-values ([(rng-x ...) #,stx]) - (with-contract-continuation-mark - (cons blame neg-party) - (let () - post ... - (values (rng-late-neg-projs rng-x neg-party) ...)))) + (if do-tail-check? + #`(let-values ([(rng-x ...) #,stx]) + (with-contract-continuation-mark + (cons blame neg-party) + (let () + post ... + (values (rng-late-neg-projs rng-x neg-party) ...)))) + + #`(let-values ([(rng-x ...) #,stx]) + (values (rng-late-neg-projs rng-x neg-party) ...))) #`(call-with-values (λ () #,stx) #,rng-checker)) @@ -276,9 +280,11 @@ inner-stx-gen #'(cons blame neg-party)) (inner-stx-gen #'())))] - [(basic-unsafe-return basic-unsafe-return/result-values-assumed) + [(basic-unsafe-return + basic-unsafe-return/result-values-assumed + basic-unsafe-return/result-values-assumed/no-tail) (let () - (define (inner-stx-gen stuff assume-result-values?) + (define (inner-stx-gen stuff assume-result-values? do-tail-check?) (define arg-checking-expressions (if need-apply? #'(this-param ... dom-projd-args ... opt+rest-uses) @@ -301,27 +307,32 @@ #`(apply val tmps ...) #`(val tmps ...))))])) (define the-call - #`(with-continuation-mark arrow:tail-contract-key - (list* neg-party blame-party-info #,rng-ctcs) - #,the-call/no-tail-mark)) + (if do-tail-check? + #`(with-continuation-mark arrow:tail-contract-key + (list* neg-party blame-party-info #,rng-ctcs) + #,the-call/no-tail-mark) + the-call/no-tail-mark)) (cond [(null? (syntax-e stuff)) ;; surely there must a better way the-call/no-tail-mark] [else (wrap-call-with-values-and-range-checking the-call - assume-result-values?)])) - (define (mk-return assume-result-values?) - (if rngs - (arrow:check-tail-contract - rng-ctcs - blame-party-info - neg-party - #'not-a-null - (λ (x) (inner-stx-gen x assume-result-values?)) - #'(cons blame neg-party)) - (inner-stx-gen #'() assume-result-values?))) - (list (mk-return #f) (mk-return #t)))] + assume-result-values? + do-tail-check?)])) + (define (mk-return assume-result-values? do-tail-check?) + (if do-tail-check? + (if rngs + (arrow:check-tail-contract + rng-ctcs + blame-party-info + neg-party + #'not-a-null + (λ (x) (inner-stx-gen x assume-result-values? do-tail-check?)) + #'(cons blame neg-party)) + (inner-stx-gen #'() assume-result-values? do-tail-check?)) + (inner-stx-gen #'not-a-null assume-result-values? do-tail-check?))) + (list (mk-return #f #t) (mk-return #t #t) (mk-return #t #f)))] [kwd-return (let* ([inner-stx-gen (if need-apply? @@ -373,6 +384,10 @@ #'(λ basic-params (let () pre ... basic-unsafe-return/result-values-assumed))] + [basic-unsafe-lambda/result-values-assumed/no-tail + #'(λ basic-params + (let () + pre ... basic-unsafe-return/result-values-assumed/no-tail))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params (with-contract-continuation-mark @@ -386,6 +401,7 @@ basic-lambda basic-unsafe-lambda basic-unsafe-lambda/result-values-assumed + basic-unsafe-lambda/result-values-assumed/no-tail #,(and rngs (length rngs)) void #,min-method-arity @@ -397,7 +413,7 @@ [(pair? req-keywords) #`(arrow:arity-checking-wrapper val blame neg-party - void #t #f #f + void #t #f #f #f kwd-lambda #,min-method-arity #,max-method-arity @@ -408,7 +424,7 @@ [else #`(arrow:arity-checking-wrapper val blame neg-party - basic-lambda #t #f #f + basic-lambda #t #f #f #f kwd-lambda #,min-method-arity #,max-method-arity diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 5f8e4497e4..6ceb0345ea 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -90,7 +90,7 @@ post post/desc) (define regular-args/no-any/c (for/list ([stx (in-list regular-args)]) - (syntax-case stx () + (syntax-case stx (any/c) [any/c #f] [else stx]))) (define key (and (not pre) (not pre/desc) @@ -980,7 +980,7 @@ args-dealt-with))))) (values (arrow:arity-checking-wrapper f blame neg-party - interposition-proc #f interposition-proc #f #f + interposition-proc #f interposition-proc #f #f #f min-arity max-arity min-arity max-arity mandatory-keywords optional-keywords) diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 44e5c0a13b..dc5a07914e 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -406,7 +406,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 #f #f #f + basic-lambda-name #f #f #f #f void #,min-method-arity #,max-method-arity @@ -418,7 +418,7 @@ #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) (arity-checking-wrapper val blame neg-party - void #f #f #f + void #f #f #f #f kwd-lambda-name #,min-method-arity #,max-method-arity @@ -431,7 +431,7 @@ (let ([basic-lambda-name basic-lambda] [kwd-lambda-name kwd-lambda]) (arity-checking-wrapper val blame neg-party - basic-lambda-name #f #f #f + basic-lambda-name #f #f #f #f kwd-lambda-name #,min-method-arity #,max-method-arity @@ -449,7 +449,9 @@ ;; can't be chosen (because there are keywords involved) (define (arity-checking-wrapper val blame neg-party basic-lambda basic-unsafe-lambda - basic-unsafe-lambda/result-values-assumed contract-result-val-count + basic-unsafe-lambda/result-values-assumed + basic-unsafe-lambda/result-values-assumed/no-tail + contract-result-val-count kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd) @@ -462,7 +464,9 @@ basic-unsafe-lambda/result-values-assumed (equal? contract-result-val-count (procedure-result-arity val))) - (values basic-unsafe-lambda/result-values-assumed #t)] + (if (simple-enough? val) + (values basic-unsafe-lambda/result-values-assumed/no-tail #t) + (values basic-unsafe-lambda/result-values-assumed #t))] [basic-unsafe-lambda (values basic-unsafe-lambda #t)] [else basic-lambda]) @@ -528,6 +532,12 @@ (values proc #f) proc)])) +(define (simple-enough? f) + (or (struct-accessor-procedure? f) + (struct-constructor-procedure? f) + (struct-predicate-procedure? f) + (struct-mutator-procedure? f))) + (define (raise-wrong-number-of-args-error blame #:missing-party [missing-party #f] val args-len max-arity min-method-arity max-method-arity)