added dynamic->*

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 ...)]{
 

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)
   
   )

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

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"

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

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)
+  (syntax-case stx ()
-      (list #,@(map (λ (x y) #`(list (quote-syntax #,x) (quote-syntax #,y)))
+    [(_ popular-key-ids)
-                    (generate-temporaries (for/list ([e (in-list popular-keys)])
+     #`(define-for-syntax popular-key-ids
-                                            'popular-plus-one-key-id))
+         (list #,@(map (λ (x y) #`(list (quote-syntax #,x) (quote-syntax #,y)))
-                    (generate-temporaries (for/list ([e (in-list popular-keys)])
+                       (generate-temporaries (for/list ([e (in-list popular-keys)])
-                                            'popular-chaperone-key-id))))))
+                                               'popular-plus-one-key-id))
-(generate-popular-key-ids)
+                       (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
+  (syntax-case stx ()
-      #,@(for/list ([ids (in-list popular-key-ids)]
+    [(_ popular-chaperone-key-table)
-                    [key (in-list popular-keys)])
+     #`(begin
-           (define plus-one-id (list-ref ids 0))
+         #,@(for/list ([ids (in-list popular-key-ids)]
-           (define chaperone-id (list-ref ids 1))
+                       [key (in-list popular-keys)])
-           (define-values (regular-arg-count
+              (define plus-one-id (list-ref ids 0))
-                           optional-arg-count
+              (define chaperone-id (list-ref ids 1))
-                           mandatory-kwds
+              (define-values (regular-arg-count
-                           optional-kwds
+                              optional-arg-count
-                           rest
+                              mandatory-kwds
-                           rngs)
+                              optional-kwds
-             (apply values key))
+                              rest
-           (define mans (for/list ([x (in-range regular-arg-count)])
+                              rngs)
-                          (string->symbol (format "man~a" x))))
+                (apply values key))
-           (define opts (for/list ([x (in-range optional-arg-count)])
+              (define mans (for/list ([x (in-range regular-arg-count)])
-                          (string->symbol (format "opt~a" x))))
+                             (string->symbol (format "man~a" x))))
-           (define rng-vars (and rngs (for/list ([x (in-range rngs)])
+              (define opts (for/list ([x (in-range optional-arg-count)])
-                                        (string->symbol (format "rng~a" x)))))
+                             (string->symbol (format "opt~a" x))))
-           #`(begin
+              (define rng-vars (and rngs (for/list ([x (in-range rngs)])
-               (define #,(syntax-local-introduce plus-one-id)
+                                           (string->symbol (format "rng~a" x)))))
-                 #,(build-plus-one-arity-function/real
+              #`(begin
-                    mans opts
+                  (define #,(syntax-local-introduce plus-one-id)
-                    mandatory-kwds
+                    #,(build-plus-one-arity-function/real
-                    optional-kwds
+                       mans opts
-                    #f
+                       mandatory-kwds
-                    rest
+                       optional-kwds
-                    rng-vars
+                       #f
-                    #f))
+                       rest
-               (define #,(syntax-local-introduce chaperone-id)
+                       rng-vars
-                 #,(build-chaperone-constructor/real
+                       #f))
-                    '() ;; this arg
+                  (define #,(syntax-local-introduce chaperone-id)
-                    mans opts
+                    #,(build-chaperone-constructor/real
-                    mandatory-kwds
+                       '() ;; this arg
-                    optional-kwds
+                       mans opts
-                    #f
+                       mandatory-kwds
-                    rest
+                       optional-kwds
-                    rng-vars
+                       #f
-                    #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<?
+            #:key car))
+    (values (map car sorted) (map cdr sorted)))
+  (define-values (mandatory-keywords mandatory-keyword-contracts)
+    (sort-kwds unsorted-mandatory-keywords unsorted-mandatory-keyword-contracts))
+  (define-values (optional-keywords optional-keyword-contracts)
+    (sort-kwds unsorted-optional-keywords unsorted-optional-keyword-contracts))
+  
+  (define-syntax-rule 
+    (define-next next args)
+    (define (next n) 
+      (let loop ([n n][_args args])
+        (cond
+          [(zero? n) (set! args _args) '()]
+          [(null? _args) (error 'plug-one-arity-function-dynamic->* "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