diff --git a/collects/scheme/private/contract-ds.ss b/collects/scheme/private/contract-ds.ss index 0056d9a9aa..a3659cc3ce 100644 --- a/collects/scheme/private/contract-ds.ss +++ b/collects/scheme/private/contract-ds.ss @@ -467,12 +467,12 @@ it around flattened out. (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) (cond - [(and (andmap contract? list-of-subcontracts) (not attrs)) + [(and (andmap name-pred? list-of-subcontracts) (not attrs)) (apply build-compound-type-name name/c list-of-subcontracts)] [else (let ([fields (map (λ (field ctc) - (if (contract? ctc) + (if (name-pred? ctc) (build-compound-type-name field ctc) (build-compound-type-name field '...))) fields diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 621761c6d4..bbfae76e1d 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -142,7 +142,7 @@ ;; returns #f if the argument could not be coerced to a contract (define (coerce-contract/f x) (cond - [(contract? x) x] + [(proj-pred? x) x] [(and (procedure? x) (procedure-arity-includes? x 1)) (make-predicate-contract (or (object-name x) '???) x)] [(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)] @@ -349,7 +349,7 @@ (let ([ctc (coerce-contract 'contract-name ctc)]) ((name-get ctc) ctc))) -(define (contract? x) (proj-pred? x)) +(define (contract? x) (and (coerce-contract/f x) #t)) (define (contract-proc ctc) ((proj-get ctc) ctc)) (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) @@ -367,7 +367,7 @@ '()] [else (let ([sub (car subs)]) (cond - [(contract? sub) + [(name-pred? sub) (let ([mk-sub-name (contract-name sub)]) `(,mk-sub-name ,@(loop (cdr subs))))] [else `(,sub ,@(loop (cdr subs)))]))]))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 3ab590aaa6..c1ba0f5c48 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -765,17 +765,12 @@ improve method arity mismatch contract violation error messages? (syntax (make-proj-contract '(recursive-contract arg) (λ (pos-blame neg-blame src str) - (let ([proc (contract-proc arg)]) - (λ (val) - ((proc pos-blame neg-blame src str) val)))) + (let ([ctc (coerce-contract 'recursive-contract arg)]) + (let ([proc (contract-proc ctc)]) + (λ (val) + ((proc pos-blame neg-blame src str) val))))) #f))])) -(define (check-contract ctc) - (unless (contract? ctc) - (error 'recursive-contract "expected a contract, got ~e" ctc)) - ctc) - - ; ; ; diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 1c7dbef738..22f9a040be 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -3698,6 +3698,13 @@ f))]) ((((contract ctc f 'pos 'neg) 1) 2) 3)))) + (test/spec-passed + 'recursive-contract5 + '(contract (recursive-contract #f) + #f + 'pos + 'neg)) + ; @@ -4510,6 +4517,9 @@ so that propagation occurs. (define-struct s (a b)) (struct/c s any/c any/c))) + (ctest #t contract? 1) + (ctest #t contract? (-> 1 1)) + (test-flat-contract '(and/c number? integer?) 1 3/2) (test-flat-contract '(not/c integer?) #t 1)