From d2a3cbf6d04a6f50d9e73320e1ad96e7d88d36a1 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 23 Sep 2010 14:29:30 -0400 Subject: [PATCH] Add better first-order checking for ->d and ->i. Closes PR 11247. --- collects/racket/contract/private/arr-i.rkt | 16 +++- collects/racket/contract/private/arrow.rkt | 94 +++++++++++++--------- collects/tests/racket/contract-test.rktl | 6 ++ 3 files changed, 76 insertions(+), 40 deletions(-) diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 62947cd9a9..d26d566c1b 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/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))) keywordd-id (gensym '->d-tail-key)]) (λ (val) - (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) + (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)) (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,22 +1571,23 @@ v4 todo: (null? mandatory))) (define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) - (unless (and (procedure? val) - (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) - (keywords-match mandatory-kwds optional-keywords val)) - (raise-blame-error - blame - val - "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" - (if mtd? "method" "procedure") - (if (zero? dom-length) "no" dom-length) - (if (null? optionals) "" " mandatory") - (if (null? mandatory-kwds) "" " ordinary") - (if (= 1 dom-length) "" "s") - (if (zero? optionals) "" - (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s"))) - (keyword-error-text mandatory-kwds optional-keywords) - 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 + "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" + (if mtd? "method" "procedure") + (if (zero? dom-length) "no" dom-length) + (if (null? optionals) "" " mandatory") + (if (null? mandatory-kwds) "" " ordinary") + (if (= 1 dom-length) "" "s") + (if (zero? optionals) "" + (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s"))) + (keyword-error-text mandatory-kwds optional-keywords) + val)))) (define (procedure-arity-includes?/optionals f base optionals) (cond @@ -1620,20 +1637,21 @@ 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) - (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) - (keywords-match mandatory-kwds optional-kwds val)) - (raise-blame-error - blame - val - "expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e" - (if mtd? "method" "procedure") - (cond - [(zero? dom-length) "no"] - [else dom-length]) - (if (= 1 dom-length) "" "s") - (keyword-error-text mandatory-kwds optional-kwds) - 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 + "expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e" + (if mtd? "method" "procedure") + (cond + [(zero? dom-length) "no"] + [else dom-length]) + (if (= 1 dom-length) "" "s") + (keyword-error-text mandatory-kwds optional-kwds) + val)))) ;; timing & size tests diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 81a0c97b80..a3a2d691a9 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9552,6 +9552,12 @@ so that propagation occurs. (ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x y . z) #f)) (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)