From 2d76c3bcabb6e9033018af5b585bf1bae4e91ac3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 18 Feb 2012 16:32:57 -0600 Subject: [PATCH] adjust -> contract so that (-> any/c ... any) contracts are now flat contracts and using (-> any/c boolean?) uses predicate/c without special intervention. also, fix a bug in the opter contracts --- collects/racket/contract/private/arrow.rkt | 41 +++++++++++++++------ collects/racket/contract/private/opters.rkt | 32 +++++++++++----- collects/tests/racket/contract-test.rktl | 14 +++++++ 3 files changed, 66 insertions(+), 21 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index be5525e983..968572317e 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -363,7 +363,7 @@ v4 todo: ;; should we pass both the basic-lambda and the kwd-lambda? (define (arity-checking-wrapper val blame basic-lambda kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd) - ;; should not build this unless we are in the 'else' case (and maybe not at all + ;; should not build this unless we are in the 'else' case (and maybe not at all) (cond [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) (if (and (null? req-kwd) (null? opt-kwd)) @@ -438,7 +438,13 @@ v4 todo: ;; func : the wrapper function maker. It accepts a procedure for ;; checking the first-order properties and the contracts ;; and it produces a wrapper-making function. -(define-struct base-> (pre post doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? mtd? func)) +(define-struct base-> (pre post + doms/c optional-doms/c dom-rest/c + mandatory-kwds/c mandatory-kwds + optional-kwds/c optional-kwds + rngs/c rng-any? + mtd? + func)) (define ((->-proj wrapper) ctc) (let* ([doms-proj (map contract-projection @@ -561,8 +567,6 @@ v4 todo: ((contract-struct-exercise c) v new-fuel)))]) (andmap gen-if-fun (base->-doms/c ctc) args)))) - - (define-struct (chaperone-> base->) () #:property prop:chaperone-contract (build-chaperone-contract-property @@ -751,10 +755,6 @@ v4 todo: ;; the -> in the original input to this guy (list (car (syntax-e stx))) '())))))) - -(define-syntax (-> stx) - #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))) - ; @@ -2000,9 +2000,15 @@ v4 todo: (λ (x) (send o m x))))) -(define predicate/c-private->ctc - (let ([predicate/c (-> any/c boolean?)]) - predicate/c)) +(define predicate/c-private->ctc + (let-syntax ([m (λ (stx) + ;; we don't use -> directly here to avoid a circularity, since + ;; (-> any/c boolean?) expands into the identifier -predicate/c + (syntax-case stx () + [(_ arg) + #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main #'arg))]))]) + (let ([predicate/c (m (-> any/c boolean?))]) + predicate/c))) (struct predicate/c () #:property prop:chaperone-contract @@ -2020,3 +2026,16 @@ v4 todo: #:stronger (λ (this that) (contract-struct-stronger? predicate/c-private->ctc that)))) (define -predicate/c (predicate/c)) + +(define-syntax (-> stx) + (syntax-case stx (any any/c boolean?) + [(_ any/c ... any) + ;; special case the (-> any/c ... any) contracts to be first-order checks only + (with-syntax ([dom-len (- (length (syntax->list stx)) 2)] + [name (syntax->datum stx)]) + #'(flat-named-contract 'name (λ (x) (and (procedure? x) (procedure-arity-includes? x dom-len #t)))))] + [(_ any/c boolean?) + ;; special case (-> any/c boolean?) to use predicate/c + #'-predicate/c] + [_ + #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))])) diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt index a1d4ee8c8e..cfb735dbcd 100644 --- a/collects/racket/contract/private/opters.rkt +++ b/collects/racket/contract/private/opters.rkt @@ -382,14 +382,17 @@ (check-procedure val #f dom-len 0 '() '() #| keywords |# blame) (chaperone-procedure val - (λ (dom-arg ...) - (values - (case-lambda - [(rng-arg ...) - (values next-rng ...)] - [args - (bad-number-of-results blame val rng-len args)]) - next-dom ...)))))) + (case-lambda + [(dom-arg ...) + (values + (case-lambda + [(rng-arg ...) + (values next-rng ...)] + [args + (bad-number-of-results blame val rng-len args)]) + next-dom ...)] + [args + (bad-number-of-arguments blame val args dom-len)]))))) (append lifts-doms lifts-rngs) (append superlifts-doms superlifts-rngs) (append partials-doms partials-rngs) @@ -439,8 +442,10 @@ (check-procedure val #f dom-len 0 '() '() #|keywords|# blame) (chaperone-procedure val - (λ (dom-arg ...) - (values next-dom ...)))))) + (case-lambda + [(dom-arg ...) (values next-dom ...)] + [args + (bad-number-of-arguments blame val args dom-len)]))))) lifts-doms superlifts-doms partials-doms @@ -477,3 +482,10 @@ (values next lift superlift partial flat _ stronger-ribs chaperone?) (opt/unknown opt/i opt/info stx))))])) + +(define (bad-number-of-arguments blame val args dom-len) + (define num-values (length args)) + (raise-blame-error (blame-swap blame) val + "expected ~a argument~a, got ~a argument~a" + dom-len (if (= dom-len 1) "" "s") + num-values (if (= num-values 1) "" "s"))) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 2e5ab7ec0d..2024e77ede 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -1131,6 +1131,18 @@ 'contract-arrow-any3 '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)) + (test/spec-passed + 'contract-arrow-all-anys1 + '((contract (-> any) (lambda () #f) 'pos 'neg))) + + (test/pos-blame + 'contract-arrow-all-anys2 + '((contract (-> any) (lambda (x) #f) 'pos 'neg))) + + (test/spec-passed + 'contract-arrow-all-anys3 + '((contract (-> any) (lambda ([x #f]) #f) 'pos 'neg))) + (test/spec-passed 'contract-arrow-all-kwds '(contract (-> #:a string? string?) @@ -9572,6 +9584,8 @@ so that propagation occurs. (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t) (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t) + (ctest #t flat-contract? (-> any/c any/c any)) + (ctest #t flat-contract? (and/c)) (ctest #t flat-contract? (and/c number? integer?)) (ctest #t flat-contract? (and/c (flat-contract number?)