From 7830d55b426efe305db0d50e7ee6bd87c0c267b5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 20 Feb 2010 10:09:37 +0000 Subject: [PATCH] Okay, that does it for augment, which means I'm done with coding. Now just documentation and benchmarking, then this can go on trunk. svn: r18217 --- collects/scheme/private/class-internal.ss | 79 +++++++++++++++-------- collects/tests/mzscheme/contract-test.ss | 4 +- 2 files changed, 54 insertions(+), 29 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 77dc1ab0a7..8429af6eb6 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2342,7 +2342,8 @@ (append override-methods augride-methods) (append override-names augride-names)) ;; Update all int dyn disp methods which have had contracts added since - ;; the superclass, but were not overridden. + ;; the superclass, but were not overridden. This includes methods that + ;; have ever been augmentable. (let ([super-int-methods (class-int-methods super)]) (for ([n (in-list dynamic-ctc-idxs)]) (let ([super-vec (vector-ref super-int-methods n)] @@ -2352,15 +2353,25 @@ (when (eq? super-vec old-vec) (let* ([dyn-idx (vector-ref dynamic-idxs n)] [new-vec (make-vector (add1 dyn-idx))] - [clean-method (vector-ref old-vec (sub1 dyn-idx))] + [last-method (vector-ref old-vec (sub1 dyn-idx))] [last-proj (vector-ref proj-vec (sub1 dyn-idx))]) - ;; Take the last updated set of projections and apply them to - ;; each location. - (for ([i (in-range dyn-idx)]) - (vector-set! new-vec i (last-proj (vector-ref old-vec i)))) - ;; Copy the last (unprotected) version of the method - (vector-set! new-vec dyn-idx clean-method) - (vector-set! int-methods n new-vec)))))) + (if (zero? (vector-length (vector-ref beta-methods n))) + (begin + ;; This method has never been augmentable, so take the last + ;; updated set of projections and apply them to each location. + (for ([i (in-range dyn-idx)]) + (vector-set! new-vec i (last-proj (vector-ref old-vec i)))) + ;; Then copy the last (unprotected) version of the method + ;; into the last slot. + (vector-set! new-vec dyn-idx last-method) + (vector-set! int-methods n new-vec)) + (begin + ;; This method has been augmentable, so we can just copy the + ;; old vector over wholesale, and then apply the last projection + ;; to the last slot. + (vector-copy! new-vec 0 old-vec) + (vector-set! new-vec dyn-idx (last-proj last-method)) + (vector-set! int-methods n new-vec)))))))) ;; Update 'augmentable flags: (unless no-method-changes? (for-each (lambda (id) @@ -2722,24 +2733,38 @@ (old-set o ((pre-p bset) v)))))))) ;; Now the trickiest of them all, internal dynamic dispatch. - (unless (null? (class/c-overrides ctc)) - (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) - (let ([dynamic-projs (class-dynamic-projs cls)]) - (for ([m (in-list (class/c-overrides ctc))] - [c (in-list (class/c-override-contracts ctc))]) - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) (blame-swap blame))] - [old-idx (vector-ref dynamic-idxs i)] - [proj-vec (vector-ref dynamic-projs i)]) - (if (= old-idx (vector-length proj-vec)) - (let* ([last-idx (sub1 old-idx)] - [old-proj (vector-ref proj-vec last-idx)]) - (vector-set! proj-vec last-idx - (compose old-proj p))) - (let ([old-proj (vector-ref proj-vec old-idx)]) - (vector-set! dynamic-idxs i (add1 old-idx)) - (vector-set! proj-vec old-idx - (compose old-proj p)))))))) + (unless (and (null? (class/c-overrides ctc)) + (null? (class/c-augments ctc))) + (let () + (define (add-projections methods ctcs swap-blame?) + (let ([dynamic-projs (class-dynamic-projs cls)]) + (for ([m (in-list methods)] + [c (in-list ctcs)]) + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) + (if swap-blame? (blame-swap blame) blame))] + [old-idx (vector-ref dynamic-idxs i)] + [proj-vec (vector-ref dynamic-projs i)]) + (if (= old-idx (vector-length proj-vec)) + (let* ([last-idx (sub1 old-idx)] + [old-proj (vector-ref proj-vec last-idx)]) + (vector-set! proj-vec last-idx + (if swap-blame? + (compose old-proj p) + (compose p old-proj)))) + (let ([old-proj (vector-ref proj-vec old-idx)]) + (vector-set! dynamic-idxs i (add1 old-idx)) + (vector-set! proj-vec old-idx + (if swap-blame? + (compose old-proj p) + (compose p old-proj))))))))) + (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) + (add-projections (class/c-overrides ctc) + (class/c-override-contracts ctc) + #t) + (add-projections (class/c-augments ctc) + (class/c-augment-contracts ctc) + #f))) c)))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 049252f990..c895f6ba18 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4728,7 +4728,7 @@ (send (new e%) g 3))) (test/neg-blame - 'class/c-higher-order-augment-4 + 'class/c-higher-order-augment-5 '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) (class object% (super-new) (define/pubment (m x) (floor x))) 'pos @@ -4741,7 +4741,7 @@ (send (new e%) g 3.5))) (test/spec-passed - 'class/c-higher-order-augment-4 + 'class/c-higher-order-augment-6 '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)])) (class object% (super-new) (define/pubment (m x) (floor x))) 'pos