diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index bc8fa3c772..532bab8cd0 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -3141,22 +3141,37 @@ (syntax/loc stx (make-base-object/c methods method-ctcs fields field-ctcs))))])) -(define-struct (base-instanceof/c base-object/c) (class-ctc) +(define (instanceof/c-proj ctc) + (let ([proj (contract-projection (base-instanceof/c-class-ctc ctc))]) + (λ (blame) + (let ([p (proj blame)]) + (λ (val) + (unless (object? val) + (raise-blame-error blame val "expected an object, got ~v" val)) + (let ([original-obj (if (has-original-object? val) (original-object val) val)] + [new-cls (p (object-ref val))]) + (impersonate-struct val object-ref (λ (o c) new-cls) + impersonator-prop:contracted ctc + impersonator-prop:original-object original-obj))))))) + +(define (instanceof/c-first-order ctc) + (let ([cls-ctc (base-instanceof/c-class-ctc ctc)]) + (λ (val) + (and (object? val) + (contract-first-order-passes? cls-ctc (object-ref val)))))) + +(define-struct base-instanceof/c (class-ctc) #:property prop:contract (build-contract-property - #:projection object/c-proj + #:projection instanceof/c-proj #:name (λ (ctc) (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc))) - #:first-order object/c-first-order)) + #:first-order instanceof/c-first-order)) (define (instanceof/c cctc) (let ([ctc (coerce-contract 'instanceof/c cctc)]) - (unless (class/c? ctc) - (error "expected class contract, got ~v" ctc)) - (make-base-instanceof/c (class/c-methods ctc) (class/c-method-contracts ctc) - (class/c-fields ctc) (class/c-field-contracts ctc) - ctc))) + (make-base-instanceof/c ctc))) ;;-------------------------------------------------------------------- ;; interfaces diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 19802b1b9b..2e0ab466dd 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1627,11 +1627,8 @@ behaves as if its class had been wrapped with the equivalent } @defproc[(instanceof/c [class-contract contract?]) contract?]{ -Produces a contract for an instance of a class that conforms -to @scheme[class-contract]. - -The resulting contract checks only the external field and method -contracts listed in @scheme[class-contract]. +Produces a contract for an object, where the object is an +instance of a class that conforms to @scheme[class-contract]. } @defform/subs[ diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 4611db5c21..cdf55e547f 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -7539,6 +7539,27 @@ [c%/c (class/c [m (->m number? number?)])]) (contract (instanceof/c c%/c) (new c%) 'pos 'neg))) + (test/spec-passed + 'instanceof/c-first-order-6 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-7 + '(let* ([d% (class object% (super-new) (define/public (n x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (or/c c%/c d%/c)) (new d%) 'pos 'neg))) + + (test/pos-blame + 'instanceof/c-first-order-8 + '(let* ([e% (class object% (super-new) (define/public (p x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (or/c c%/c d%/c)) (new e%) 'pos 'neg))) + (test/spec-passed/result 'instanceof/c-higher-order-1 '(let* ([c% (class object% (super-new) (field [f 3]))] @@ -7560,6 +7581,30 @@ [c%/c (class/c [m (->m number? number?)])] [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)]) (send o m 3))) + + (test/spec-passed + 'instanceof/c-higher-order-4 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/pos-blame + 'instanceof/c-higher-order-4 + '(let* ([c% (class object% (super-new) (define/public (m x) #t))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/neg-blame + 'instanceof/c-higher-order-4 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m #t))) ; ;