From 3d31d86bf541ba76e85329c22559b455e44f279f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 10 Nov 2015 08:56:45 -0600 Subject: [PATCH] fix (-> any/c boolean?) for the case of an impersonated struct predicate closes #1129 --- pkgs/racket-test/tests/racket/contract/arrow.rkt | 7 +++++++ .../collects/racket/contract/private/arrow-val-first.rkt | 4 +++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index 7d822464b7..9d436e3bcc 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -386,6 +386,13 @@ (test/pos-blame 'predicate/c13 '(contract (-> any/c boolean?) (λ (x #:y y) #t) 'pos 'neg)) + (test/pos-blame + 'predicate/c14 + '(contract (-> any/c boolean?) + (let () + (struct s ()) + ((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11)) + 'pos 'neg)) ;; this test ensures that no contract wrappers ;; are created for struct predicates diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 84bf657b79..931eeee516 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -1289,7 +1289,9 @@ given: "~e") f)) (cond - [(struct-predicate-procedure? f) #f] + [(and (struct-predicate-procedure? f) + (not (impersonator? f))) + #f] [(and (equal? (procedure-arity f) 1) (let-values ([(required mandatory) (procedure-keywords f)]) (and (null? required)