From 9d5aa5eec56c09e9a98968057c1ee4769ce6aaa5 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 17 May 2012 22:10:50 -0400 Subject: [PATCH] Fix a bug with class/c & interface ctc interaction Method concretization did not occur properly when particular class contracts were applied along with interface contracts. --- collects/racket/private/class-internal.rkt | 28 ++++++------ collects/tests/racket/contract-test.rktl | 50 ++++++++++++++++++++++ 2 files changed, 66 insertions(+), 12 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 383614397f..517a86d26e 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2761,6 +2761,8 @@ An example (class-pos cls))] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] + [method-ictcs (class-method-ictcs cls)] + [ctc-methods (class/c-methods ctc)] [dynamic-features (append (class/c-overrides ctc) (class/c-augments ctc) @@ -2771,7 +2773,7 @@ An example (class/c-augment-contracts ctc) (class/c-augride-contracts ctc) (class/c-inherit-contracts ctc))] - [methods (if (null? (class/c-methods ctc)) + [methods (if (null? ctc-methods) (class-methods cls) (make-vector method-width))] [super-methods (if (null? (class/c-supers ctc)) @@ -2810,7 +2812,7 @@ An example method-width method-ht (class-method-ids cls) - null + (remq* ctc-methods method-ictcs) (make-weak-hasheq) @@ -2870,21 +2872,23 @@ An example (set-class-field-set!! c object-field-set!)) ;; Handle public method contracts - (unless (null? (class/c-methods ctc)) + (unless (null? ctc-methods) ;; First, fill in from old methods (vector-copy! methods 0 (class-methods cls)) - ;; Concretize any interface contracts first + ;; Concretize any interface contracts handled by this ctc (unless (null? (class-method-ictcs cls)) (for ([m (in-list (class-method-ictcs cls))]) - (define i (hash-ref method-ht m)) - (define entry (vector-ref methods i)) - ;; we're passing through a contract boundary, so the positive blame (aka - ;; value server) is taking responsibility for any interface-contracted - ;; methods) - (define info (replace-ictc-blame (cadr entry) #f (blame-positive blame))) - (vector-set! methods i (concretize-ictc-method (car entry) info)))) + ;; only concretize if class/c takes responsibility for it + (when (memq m ctc-methods) + (define i (hash-ref method-ht m)) + (define entry (vector-ref methods i)) + ;; we're passing through a contract boundary, so the positive blame (aka + ;; value server) is taking responsibility for any interface-contracted + ;; methods) + (define info (replace-ictc-blame (cadr entry) #f (blame-positive blame))) + (vector-set! methods i (concretize-ictc-method (car entry) info))))) ;; Now apply projections - (for ([m (in-list (class/c-methods ctc))] + (for ([m (in-list ctc-methods)] [c (in-list (class/c-method-contracts ctc))]) (when c (define i (hash-ref method-ht m)) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index bb231314f5..f0cd00468e 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -8523,6 +8523,56 @@ (send (new c%) m 3)) "(class c%)") + (test/spec-passed + 'interface-higher-order-8 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))] + [c2% (class c% (super-new))]) + (send (new c2%) m 3))) + + (test/spec-passed + 'interface-higher-order-10 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 3))) + + (test/neg-blame + 'interface-higher-order-11 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c [m (->m integer? integer?)]) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 5.14))) + + (test/spec-failed + 'interface-higher-order-11 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c m) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 5.14)) + "pos") + + (test/spec-failed + 'interface-higher-order-12 + '(let* ([i1<%> (interface () [m (->m integer? integer?)])] + [i2<%> (interface (i1<%>) [m (->m integer? integer?)])] + [c% (contract (class/c) + (class* object% (i2<%>) (super-new) (define/public (m x) x)) + 'pos + 'neg)]) + (send (new c%) m 5.14)) + "top-level") + ; ; ;