suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Okay, that does it for augment, which means I'm done with coding. Now just

Browse Source 
documentation and benchmarking, then this can go on trunk.

svn: r18217
This commit is contained in:
Stevie Strickland 2010-02-20 10:09:37 +00:00
parent 37e1cd2e2c
commit 7830d55b42
2 changed files with 54 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/scheme/private/class-internal.ss
View File

@ -2342,7 +2342,8 @@
(append override-methods augride-methods) (append override-methods augride-methods)
(append override-names augride-names)) (append override-names augride-names))
;; Update all int dyn disp methods which have had contracts added since ;; 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)]) (let ([super-int-methods (class-int-methods super)])
(for ([n (in-list dynamic-ctc-idxs)]) (for ([n (in-list dynamic-ctc-idxs)])
(let ([super-vec (vector-ref super-int-methods n)] (let ([super-vec (vector-ref super-int-methods n)]
@ -2352,15 +2353,25 @@
(when (eq? super-vec old-vec) (when (eq? super-vec old-vec)
(let* ([dyn-idx (vector-ref dynamic-idxs n)] (let* ([dyn-idx (vector-ref dynamic-idxs n)]
[new-vec (make-vector (add1 dyn-idx))] [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))]) [last-proj (vector-ref proj-vec (sub1 dyn-idx))])
;; Take the last updated set of projections and apply them to (if (zero? (vector-length (vector-ref beta-methods n)))
;; each location. (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)]) (for ([i (in-range dyn-idx)])
(vector-set! new-vec i (last-proj (vector-ref old-vec i)))) (vector-set! new-vec i (last-proj (vector-ref old-vec i))))
;; Copy the last (unprotected) version of the method ;; Then copy the last (unprotected) version of the method
(vector-set! new-vec dyn-idx clean-method) ;; into the last slot.
(vector-set! int-methods n new-vec)))))) (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: ;; Update 'augmentable flags:
(unless no-method-changes? (unless no-method-changes?
(for-each (lambda (id) (for-each (lambda (id)
@ -2722,24 +2733,38 @@
(old-set o ((pre-p bset) v)))))))) (old-set o ((pre-p bset) v))))))))
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
(unless (null? (class/c-overrides ctc)) (unless (and (null? (class/c-overrides ctc))
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) (null? (class/c-augments ctc)))
(let ()
(define (add-projections methods ctcs swap-blame?)
(let ([dynamic-projs (class-dynamic-projs cls)]) (let ([dynamic-projs (class-dynamic-projs cls)])
(for ([m (in-list (class/c-overrides ctc))] (for ([m (in-list methods)]
[c (in-list (class/c-override-contracts ctc))]) [c (in-list ctcs)])
(let* ([i (hash-ref method-ht m)] (let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) (blame-swap blame))] [p ((contract-projection c)
(if swap-blame? (blame-swap blame) blame))]
[old-idx (vector-ref dynamic-idxs i)] [old-idx (vector-ref dynamic-idxs i)]
[proj-vec (vector-ref dynamic-projs i)]) [proj-vec (vector-ref dynamic-projs i)])
(if (= old-idx (vector-length proj-vec)) (if (= old-idx (vector-length proj-vec))
(let* ([last-idx (sub1 old-idx)] (let* ([last-idx (sub1 old-idx)]
[old-proj (vector-ref proj-vec last-idx)]) [old-proj (vector-ref proj-vec last-idx)])
(vector-set! proj-vec last-idx (vector-set! proj-vec last-idx
(compose old-proj p))) (if swap-blame?
(compose old-proj p)
(compose p old-proj))))
(let ([old-proj (vector-ref proj-vec old-idx)]) (let ([old-proj (vector-ref proj-vec old-idx)])
(vector-set! dynamic-idxs i (add1 old-idx)) (vector-set! dynamic-idxs i (add1 old-idx))
(vector-set! proj-vec old-idx (vector-set! proj-vec old-idx
(compose old-proj p)))))))) (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)))) c))))

4
collects/tests/mzscheme/contract-test.ss
View File

@ -4728,7 +4728,7 @@
(send (new e%) g 3))) (send (new e%) g 3)))
(test/neg-blame (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?)])) '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)]))
(class object% (super-new) (define/pubment (m x) (floor x))) (class object% (super-new) (define/pubment (m x) (floor x)))
'pos 'pos
@ -4741,7 +4741,7 @@
(send (new e%) g 3.5))) (send (new e%) g 3.5)))
(test/spec-passed (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?)])) '(let* ([c% (contract (class/c (augment [m (-> any/c number? integer?)]))
(class object% (super-new) (define/pubment (m x) (floor x))) (class object% (super-new) (define/pubment (m x) (floor x)))
'pos 'pos