diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index fdc45acd51..e3b28c6333 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -1190,6 +1190,25 @@ The @racket[#:pre-cond] and @racket[#:post-cond] keywords are aliases for access to a single shared integer. } +@defproc[(dynamic->* + [#:mandatory-domain-contracts mandatory-domain-contracts (listof contract?) '()] + [#:optional-domain-contracts optional-domain-contracts (listof contract?) '()] + [#:mandatory-keywords mandatory-keywords (listof keyword?) '()] + [#:mandatory-keyword-contracts mandatory-keyword-contracts (listof contract?) '()] + [#:optional-keywords optional-keywords (listof keyword?) '()] + [#:optional-keyword-contracts optional-keyword-contracts (listof contract?) '()] + [#:rest-contract rest-contract (or/c #f contract?) #f] + [#:range-contracts range-contracts (or/c #f (listof contract?))]) + contract?]{ + Like @racket[->*], except the number of arguments and results can be computed + at runtime, instead of being fixed at compile-time. Passing @racket[#f] as the + @racket[#:range-contracts] argument produces a contract like one where @racket[any] + is used with @racket[->] or @racket[->*]. + + For many uses, @racket[dynamic->*]'s result is slower than @racket[->*] (or @racket[->]), + but for some it has comparable speed. The name of the contract returned by + @racket[dynamic->*] uses the @racket[->] or @racket[->*] syntax. +} @defform[(unconstrained-domain-> range-expr ...)]{ diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index e8b8b57e65..44a7400c33 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -356,5 +356,58 @@ (struct x (a)) (eq? (contract predicate/c x? 'pos 'neg) x?)) #t) + + + (test/spec-passed/result + 'dynamic->*1 + '((contract (dynamic->* #:mandatory-domain-contracts (list any/c any/c) + #:range-contracts (list any/c)) + (λ (x z) (+ x z)) 'pos 'neg) + 2 3) + 5) + + (test/pos-blame + 'dynamic->*2 + '((contract (dynamic->* #:mandatory-domain-contracts (list any/c any/c) + #:range-contracts (list any/c any/c)) + (λ (x z) (+ x z)) 'pos 'neg) + 2 3)) + + (test/neg-blame + 'dynamic->*3 + '((contract (dynamic->* #:mandatory-domain-contracts (list integer? integer?) + #:range-contracts (list integer?)) + (λ (x z) (+ x z)) 'pos 'neg) + #f #f)) + + (test/spec-passed/result + 'dynamic->*5 + '((contract (dynamic->* #:mandatory-keywords '(#:x) + #:mandatory-keyword-contracts (list integer?) + #:mandatory-domain-contracts (list any/c any/c) + #:range-contracts (list any/c)) + (λ (#:x x y z) (+ x z)) 'pos 'neg) + #:x 1 2 3) + 4) + + (test/spec-passed + 'dynamic->*6 + '((contract (dynamic->* #:mandatory-domain-contracts (build-list 11 (λ (x) any/c)) + #:range-contracts (build-list 11 (λ (x) any/c))) + values 'pos 'neg) + 1 2 3 4 5 6 7 8 9 10 11)) + + (test/spec-passed/result + 'dynamic->*7 + '((contract (dynamic->* #:rest-contract (listof any/c) + #:range-contracts #f) + (λ whatever whatever) 'pos 'neg) + 1 2 3 4 5 6 7) + '(1 2 3 4 5 6 7)) + + (test/spec-passed/result + 'dynamic->*8 + '((contract (dynamic->* #:range-contracts #f) (λ () 1) 'pos 'neg)) + 1) ) diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt index ed61b58e28..be152fc06a 100644 --- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt +++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt @@ -960,6 +960,43 @@ ((dynamic-require ''provide/contract49-m2 'go)))) "f:") + (test/spec-passed/result + 'provide/contract50 + '(let () + (eval '(module provide/contract50-m1 racket/base + (require racket/contract/base) + (provide (contract-out + [f (dynamic->* #:mandatory-domain-contracts (list any/c) + #:range-contracts (list any/c))])) + (define (f x) x))) + (eval '(module provide/contract50-m2 racket/base + (require 'provide/contract50-m1) + (define x (f 1)) + (provide x))) + (eval '(dynamic-require ''provide/contract50-m2 'x))) + 1) + + ;; make sure the dynamic->* doesn't go thru the "fast" path when there is a direct call + ;; because that path isn't actually implemented in the combinator (so contract-out + ;; doesn't try to use it) + (test/spec-passed/result + 'provide/contract51 + '(let () + (eval '(module provide/contract51-m1 racket/base + (require racket/contract/base) + (provide (contract-out + [f (dynamic->* #:mandatory-keywords '(#:x #:y #:z #:w) + #:mandatory-keyword-contracts (list any/c any/c any/c any/c) + #:range-contracts (list any/c any/c any/c any/c))])) + (define (f #:x x #:y y #:z z #:w w) (values x y z w)))) + (eval '(module provide/contract51-m2 racket/base + (require 'provide/contract51-m1) + (define-values (x y z w) (f #:x 1 #:y 2 #:z 3 #:w 4)) + (define a (list x y z w)) + (provide a))) + (eval '(dynamic-require ''provide/contract51-m2 'a))) + '(1 2 3 4)) + (contract-error-test 'contract-error-test8 #'(begin diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index 15a416b041..e32d5c96ec 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -38,6 +38,8 @@ -> ->*) (rename-out [->2 ->] [->*2 ->*]) + dynamic->* + (all-from-out "private/arr-i.rkt" "private/box.rkt" "private/hash.rkt" diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index ac32d7bc17..53a47da3e3 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -286,7 +286,7 @@ #,(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 diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 919e939ab9..7b90abe863 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -14,6 +14,7 @@ (prefix-in arrow: "arrow.rkt")) (provide ->2 ->*2 + dynamic->* (for-syntax ->2-handled? ->*2-handled? ->-valid-app-shapes @@ -56,13 +57,15 @@ (5 0 () () #f 1))) ; 74 (define-syntax (generate-popular-key-ids stx) - #`(define-for-syntax #,(datum->syntax stx 'popular-key-ids) - (list #,@(map (λ (x y) #`(list (quote-syntax #,x) (quote-syntax #,y))) - (generate-temporaries (for/list ([e (in-list popular-keys)]) - 'popular-plus-one-key-id)) - (generate-temporaries (for/list ([e (in-list popular-keys)]) - 'popular-chaperone-key-id)))))) -(generate-popular-key-ids) + (syntax-case stx () + [(_ popular-key-ids) + #`(define-for-syntax popular-key-ids + (list #,@(map (λ (x y) #`(list (quote-syntax #,x) (quote-syntax #,y))) + (generate-temporaries (for/list ([e (in-list popular-keys)]) + 'popular-plus-one-key-id)) + (generate-temporaries (for/list ([e (in-list popular-keys)]) + 'popular-chaperone-key-id)))))])) +(generate-popular-key-ids popular-key-ids) (define-for-syntax (build-plus-one-arity-function+chaperone-constructor stx @@ -113,44 +116,51 @@ post))])) (define-syntax (build-populars stx) - #`(begin - #,@(for/list ([ids (in-list popular-key-ids)] - [key (in-list popular-keys)]) - (define plus-one-id (list-ref ids 0)) - (define chaperone-id (list-ref ids 1)) - (define-values (regular-arg-count - optional-arg-count - mandatory-kwds - optional-kwds - rest - rngs) - (apply values key)) - (define mans (for/list ([x (in-range regular-arg-count)]) - (string->symbol (format "man~a" x)))) - (define opts (for/list ([x (in-range optional-arg-count)]) - (string->symbol (format "opt~a" x)))) - (define rng-vars (and rngs (for/list ([x (in-range rngs)]) - (string->symbol (format "rng~a" x))))) - #`(begin - (define #,(syntax-local-introduce plus-one-id) - #,(build-plus-one-arity-function/real - mans opts - mandatory-kwds - optional-kwds - #f - rest - rng-vars - #f)) - (define #,(syntax-local-introduce chaperone-id) - #,(build-chaperone-constructor/real - '() ;; this arg - mans opts - mandatory-kwds - optional-kwds - #f - rest - rng-vars - #f)))))) + (syntax-case stx () + [(_ popular-chaperone-key-table) + #`(begin + #,@(for/list ([ids (in-list popular-key-ids)] + [key (in-list popular-keys)]) + (define plus-one-id (list-ref ids 0)) + (define chaperone-id (list-ref ids 1)) + (define-values (regular-arg-count + optional-arg-count + mandatory-kwds + optional-kwds + rest + rngs) + (apply values key)) + (define mans (for/list ([x (in-range regular-arg-count)]) + (string->symbol (format "man~a" x)))) + (define opts (for/list ([x (in-range optional-arg-count)]) + (string->symbol (format "opt~a" x)))) + (define rng-vars (and rngs (for/list ([x (in-range rngs)]) + (string->symbol (format "rng~a" x))))) + #`(begin + (define #,(syntax-local-introduce plus-one-id) + #,(build-plus-one-arity-function/real + mans opts + mandatory-kwds + optional-kwds + #f + rest + rng-vars + #f)) + (define #,(syntax-local-introduce chaperone-id) + #,(build-chaperone-constructor/real + '() ;; this arg + mans opts + mandatory-kwds + optional-kwds + #f + rest + rng-vars + #f)))) + (define popular-chaperone-key-table + (make-hash + (list #,@(for/list ([id (in-list popular-key-ids)] + [key (in-list popular-keys)]) + #`(cons '#,key #,(list-ref id 1)))))))])) (define-for-syntax (build-plus-one-arity-function/real regular-args @@ -271,7 +281,7 @@ minimum-arg-count rbs rest-ctc) (make-keyword-procedure (λ (actual-kwds actual-kwd-args neg-party . regular-args) - (check-arg-count minimum-arg-count rbs regular-args f blame neg-party rest-ctc) + (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 @@ -323,25 +333,38 @@ (cons (((car rbs) (car regular-args)) neg-party) (loop (cdr regular-args) (cdr rbs)))])))))) -(build-populars) +(build-populars popular-chaperone-key-table) +(define (lookup-popular-chaperone-key regular-arg-count + optional-arg-count + mandatory-kwds + optional-kwds + rest + rngs) + (define key (list regular-arg-count + optional-arg-count + mandatory-kwds + optional-kwds + rest + rngs)) + (hash-ref popular-chaperone-key-table key #f)) -(define (check-arg-count minimum-arg-count rbs regular-args val blame neg-party rest-ctc) +(define (check-arg-count minimum-arg-count len-rbs regular-args val blame neg-party rest-ctc) (define actual-count (length regular-args)) (cond [(< actual-count minimum-arg-count) (raise-blame-error (blame-swap blame) #:missing-party neg-party val '(expected: "~a~a arguments") - (if (= (length rbs) minimum-arg-count) + (if (= len-rbs minimum-arg-count) "" "at least ") minimum-arg-count)] - [(and (not rest-ctc) (< (length rbs) actual-count)) + [(and (not rest-ctc) (< len-rbs actual-count)) (raise-blame-error (blame-swap blame) #:missing-party neg-party val '(expected: "~a~a arguments") - (if (= (length rbs) minimum-arg-count) + (if (= len-rbs minimum-arg-count) "" "at most ") - (+ minimum-arg-count (length rbs)))])) + len-rbs)])) (define (check-keywords mandatory-kwds optional-kwds kwds val blame neg-party) (let loop ([mandatory-kwds mandatory-kwds] @@ -711,6 +734,164 @@ plus-one-arity-function chaperone-constructor))) +(define (dynamic->* #:mandatory-domain-contracts [mandatory-domain-contracts '()] + #:optional-domain-contracts [optional-domain-contracts '()] + #:mandatory-keywords [unsorted-mandatory-keywords '()] + #:mandatory-keyword-contracts [unsorted-mandatory-keyword-contracts '()] + #:optional-keywords [unsorted-optional-keywords '()] + #:optional-keyword-contracts [unsorted-optional-keyword-contracts '()] + #:rest-contract [rest-contract #f] + #:range-contracts range-contracts) + + ;; leave these out for now + (define pre-cond #f) + (define post-cond #f) + + (define-syntax-rule (check-list e) (check-list/proc e 'e)) + (define (check-list/proc e name) + (unless (list? e) + (raise-argument-error + 'dynamic->* + (format "list? in the #:~a argument" name) + e))) + (define (check-list/kwds e name) + (unless (andmap keyword? e) + (raise-argument-error + 'dynamic->* + (format "(listof keyword?) in the #:~a argument" name) + e))) + (define (check-same-length l1 l2 name) + (unless (= (length l1) (length l2)) + (error 'dynamic->* + (string-append + "expected the length of the #:~a-keywords argument" + " to be the same as the length of the #:~a-keyword-contracts argument") + name name))) + (check-list mandatory-domain-contracts) + (check-list optional-domain-contracts) + (check-list unsorted-mandatory-keywords) + (check-list/kwds unsorted-mandatory-keywords 'mandatory-keywords) + (check-list unsorted-mandatory-keyword-contracts) + (check-same-length unsorted-mandatory-keywords unsorted-mandatory-keyword-contracts 'mandatory) + (check-list unsorted-optional-keywords) + (check-list/kwds unsorted-optional-keywords 'optional-keywords) + (check-list unsorted-optional-keyword-contracts) + (check-same-length unsorted-optional-keywords unsorted-optional-keyword-contracts 'optional) + (unless (or (not range-contracts) + (list? range-contracts)) + (raise-argument-error 'dynamic->* + "(or/c (listof contract?) #f) in the #:range-contracts argument" + range-contracts)) + + (define (sort-kwds unsorted-keywords unsorted-keyword-contracts) + (define sorted + (sort (map cons unsorted-keywords unsorted-keyword-contracts) + keyword* "internal error")] + [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 min-arity (length mandatory-domain-contracts)) + (define optionals (length optional-domain-contracts)) + (define rng-len (and range-contracts (length range-contracts))) + (define max-arity (if rest-contract #f (+ min-arity optionals))) + + (define build-chaperone-constructor + (or (lookup-popular-chaperone-key min-arity + optionals + mandatory-keywords + optional-keywords + (and rest-contract #t) + rng-len) + (λ (blame f neg-party . args) + (define-next next args) + (define mandatory-dom-projs (next min-arity)) + (define optional-dom-projs (next optionals)) + (define rest-proj (if rest-contract + (car (next 1)) + #f)) + (define mandatory-dom-kwd-projs (next (length mandatory-keyword-contracts))) + (define optional-dom-kwd-projs (next (length optional-keyword-contracts))) + (define rng-projs (and rng-len (next rng-len))) + (define mandatory+optional-dom-projs (append mandatory-dom-projs optional-dom-projs)) + (define kwd-table + (make-hash + (for/list ([kwd (in-list (append mandatory-keywords optional-keywords))] + [kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))]) + (cons kwd kwd-proj)))) + (define complete-blame (blame-add-missing-party blame neg-party)) + + (define interposition-proc + (make-keyword-procedure + (λ (kwds kwd-args . args) + + (check-arg-count min-arity max-arity args f blame neg-party rest-contract) + (check-keywords mandatory-keywords optional-keywords kwds f blame neg-party) + + (define kwd-results + (for/list ([kwd (in-list kwds)] + [kwd-arg (in-list kwd-args)]) + (((hash-ref kwd-table kwd) kwd-arg) neg-party))) + (define regular-arg-results + (let loop ([args args] + [projs mandatory+optional-dom-projs]) + (cond + [(and (null? projs) (null? args)) '()] + [(null? projs) + ((rest-proj args) neg-party)] + [(null? args) (error 'cant-happen::dynamic->*)] + [else (cons (((car projs) (car args)) neg-party) + (loop (cdr args) (cdr projs)))]))) + (define (result-checker . results) + (unless (= rng-len (length results)) + (arrow:bad-number-of-results complete-blame f rng-len results)) + (apply + values + (for/list ([res (in-list results)] + [neg-party-proj (in-list rng-projs)]) + ((neg-party-proj res) neg-party)))) + (define args-dealt-with + (if (null? kwds) + regular-arg-results + (cons kwd-results regular-arg-results))) + (apply + values + (if range-contracts + (cons result-checker args-dealt-with) + args-dealt-with))))) + + (arrow:arity-checking-wrapper f complete-blame + interposition-proc interposition-proc + min-arity max-arity + min-arity max-arity + mandatory-keywords optional-keywords)))) + + (build--> 'dynamic->* + mandatory-domain-contracts optional-domain-contracts + mandatory-keywords mandatory-keyword-contracts + optional-keywords optional-keyword-contracts + rest-contract + pre-cond range-contracts post-cond + plus-one-arity-function + build-chaperone-constructor)) + ;; min-arity : nat ;; doms : (listof contract?)[len >= min-arity] ;; includes optional arguments in list @ end