Add better first-order checking for ->d and ->i.

Closes PR 11247.

collects/racket/contract/private/arr-i.rkt

@@ -34,7 +34,7 @@
 (struct ->i (arg-ctcs arg-dep-ctcs indy-arg-ctcs
                       rng-ctcs rng-dep-ctcs indy-rng-ctcs
                       pre/post-procs
-                      mandatory-args opt-args mandatory-kwds opt-kwds rest?
+                      mandatory-args opt-args mandatory-kwds opt-kwds rest? mtd?
                       here
                       mk-wrapper
                       name-info)
@@ -149,7 +149,18 @@
                           ,@(if post-info
                                 `(#:post ,post-info ...)
                                 '()))))
-         #:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
+         #:first-order
+         (λ (ctc)
+             (let ([has-rest? (->i-rest? ctc)]
+                   [mtd? (->i-mtd? ctc)]
+                   [mand-args (->i-mandatory-args ctc)]
+                   [opt-args (->i-opt-args ctc)]
+                   [mand-kwds (->i-mandatory-kwds ctc)]
+                   [opt-kwds (->i-opt-kwds ctc)])
+               (λ (val)
+                 (if has-rest?
+                     (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f)
+                     (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f)))))
          #:stronger (λ (this that) (eq? this that)))) ;; WRONG
 
 ;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) 
@@ -731,6 +742,7 @@
                                              (istx-args an-istx))) 
                          keyword<?)
                 #,(and (istx-rst an-istx) #t)
+                #,(and (syntax-parameter-value #'making-a-method) #t)
                 (quote-module-path)
                 #,wrapper-func
                 '#(#,(for/list ([an-arg (in-list (istx-args an-istx))])

collects/racket/contract/private/arrow.rkt

@@ -965,13 +965,20 @@ v4 todo:
     (λ (blame)
       (let ([this->d-id (gensym '->d-tail-key)])
         (λ (val)
+          (if (->d-rest-ctc ->d-stct)
+              (check-procedure/more val
+                                    (->d-mtd? ->d-stct)
+                                    (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
+                                    (->d-mandatory-keywords ->d-stct)
+                                    (->d-optional-keywords ->d-stct)
+                                    blame)
               (check-procedure val
                                (->d-mtd? ->d-stct)
                                (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
                                (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
                                (->d-mandatory-keywords ->d-stct)
                                (->d-optional-keywords ->d-stct)
-                           blame)
+                               blame))
           (let ([kwd-proc
                  (λ (kwd-args kwd-arg-vals . raw-orig-args)
                    (let* ([orig-args (if (->d-mtd? ->d-stct)
@@ -1246,7 +1253,16 @@ v4 todo:
                   (list '#:post '...)
                   (list)))))
 
-   #:first-order (λ (ctc) (λ (x) #f))
+   #:first-order (λ (ctc)
+                   (λ (val)
+                     (let* ([mtd? (->d-mtd? ctc)]
+                            [dom-length (length (->d-mandatory-dom-ctcs ctc))]
+                            [optionals (length (->d-optional-dom-ctcs ctc))]
+                            [mandatory-kwds (->d-mandatory-keywords ctc)]
+                            [optional-kwds (->d-optional-keywords ctc)])
+                       (if (->d-rest-ctc ctc)
+                           (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f)
+                           (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f)))))
    #:stronger (λ (this that) (eq? this that))))
 
 
@@ -1555,9 +1571,10 @@ v4 todo:
     (null? mandatory)))
 
 (define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
-  (unless (and (procedure? val)
+  (or (and (procedure? val)
            (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
            (keywords-match mandatory-kwds optional-keywords val))
+      (and blame
            (raise-blame-error
             blame
             val
@@ -1570,7 +1587,7 @@ v4 todo:
             (if (zero? optionals) ""
                 (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
             (keyword-error-text mandatory-kwds optional-keywords)
-     val)))
+            val))))
 
 (define (procedure-arity-includes?/optionals f base optionals)
   (cond
@@ -1620,9 +1637,10 @@ v4 todo:
                     (format-keywords-error 'optional optional-keywords))]))
      
 (define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
-  (unless (and (procedure? val)
+  (or (and (procedure? val)
            (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
            (keywords-match mandatory-kwds optional-kwds val))
+      (and blame
            (raise-blame-error
             blame
             val
@@ -1633,7 +1651,7 @@ v4 todo:
               [else dom-length])
             (if (= 1 dom-length) "" "s")
             (keyword-error-text mandatory-kwds optional-kwds)
-     val)))
+            val))))
 
 ;; timing & size tests
 

collects/tests/racket/contract-test.rktl

@@ -9553,6 +9553,12 @@ so that propagation occurs.
   (ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x) #f))
   (ctest #t contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ x #f))
   
+  (ctest #t contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x) x))
+  (ctest #f contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x y) x))
+
+  (ctest #t contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x) x))
+  (ctest #f contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x y) x))
+
   (ctest #t contract-first-order-passes? (listof integer?) (list 1))
   (ctest #f contract-first-order-passes? (listof integer?) #f)