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

Fixes in override ctcs and test suite. I thought I ran it, so I find it

Browse Source 
weird that I found these on a subsequent run when adding some quick augment
tests to start the next batch.  (Oh, those are included also.)

svn: r18215
This commit is contained in:
Stevie Strickland 2010-02-20 09:40:41 +00:00
parent b5e2d5f93e
commit 67d47e0a1d
2 changed files with 31 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2346,13 +2346,14 @@
(let ([super-int-methods (class-int-methods super)])
(for ([n (in-list dynamic-ctc-idxs)])
(let ([super-vec (vector-ref super-int-methods n)]
[old-vec (vector-ref int-methods n)])
[old-vec (vector-ref int-methods n)]
[proj-vec (vector-ref dynamic-projs n)])
;; If we didn't already update this in the override block above...
(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-proj (vector-ref dynamic-projs (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)])

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

@ -4596,14 +4596,16 @@
(test/spec-passed
'class/c-higher-order-override-1
'(let* ([c% (contract (class/c (override [m (-> any/c number? number?)]))
'(let* ([c% (contract (class/c (override [m (-> any/c integer? integer?)]))
(class object% (super-new)
(define/public (m x) x)
(define/public (f x) (m x)))
'pos
'neg)]
[d% (class c% (super-new) (define/override (m x) (add1 (super m x))))])
(send (new d%) f 3)))
[d% (class c% (super-new)
(define/public (g x) (m x))
(define/override (m x) (add1 (super m x))))])
(send (new d%) g 3.5)))
(test/neg-blame
'class/c-higher-order-override-2
@ -4662,7 +4664,7 @@
'pos
'neg1)]
[d% (contract (class/c (override [m (-> any/c integer? integer?)]))
(class c% (super-new) (define/public (g x) (add1 (m 3))))
(class c% (super-new) (inherit m) (define/public (g x) (add1 (m 3))))
'pos1
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
@ -4683,6 +4685,28 @@
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
(send (new e%) f 3)))
(test/spec-passed
'class/c-higher-order-augment-1
'(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)]))
(class object% (super-new)
(define/pubment (m x) x)
(define/public (f x) (m (zero? x))))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))])
(send (new d%) f 3)))
(test/neg-blame
'class/c-higher-order-augment-2
'(let* ([c% (contract (class/c (augment [m (-> any/c integer? integer?)]))
(class object% (super-new)
(define/pubment (m x) x)
(define/public (f x) (m (zero? x))))
'pos
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (g x) (m x)))])
(send (new d%) g 3.5)))
;
;
; ;; ;; ; ;;