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

It was a good thing I decided to add some super/inner mixed examples here,

Browse Source 
because it pointed out a bug in my implementation where we weren't getting
the right version of the super method (which gets the projection).

svn: r18180
This commit is contained in:
Stevie Strickland 2010-02-19 04:40:10 +00:00
parent 5cc68fdd0f
commit 55d39b0035
2 changed files with 41 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2144,7 +2144,12 @@
(let ([rename-supers (map (lambda (index mname)
(let ([vec (vector-ref (class-beta-methods super) index)])
(if (positive? (vector-length vec))
(or (vector-ref vec (sub1 (vector-length vec)))
;; While the last part of the vector is indeed the right
;; method, if there have been super contracts placed since,
;; they won't be reflected there, only in the super-methods
;; vector of the superclass.
(if (vector-ref vec (sub1 (vector-length vec)))
(vector-ref (class-super-methods super) index)
(obj-error 'class*
(string-append
"superclass ~e method for override, overment, inherit/super, "
@ -2261,6 +2266,7 @@
(vector-set! int-methods index method))
;; Under final mode - set extended vtable entry
(let ([v (list->vector (vector->list v))])
(vector-set! super-methods index method)
(vector-set! v (sub1 (vector-length v))
;; Apply current inner contract projection
((vector-ref inner-projs index) method))

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

@ -4460,6 +4460,40 @@
[e% (class d% (super-new) (define/override (m x) (zero? (super m x))))])
(send (new e%) m 3)))
;; Show both inner and super contracts.
(test/spec-passed
'class/c-higher-order-inner-10
'(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))]
[d% (contract (class/c (inner [m (-> any/c number? number?)])
(super [m (-> any/c number? number?)]))
(class c% (super-new) (define/augride (m x) (add1 x)))
'pos
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
(send (new e%) m 3)))
(test/pos-blame
'class/c-higher-order-inner-11
'(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m #f))))]
[d% (contract (class/c (inner [m (-> any/c number? number?)])
(super [m (-> any/c number? number?)]))
(class c% (super-new) (define/augride (m x) (add1 x)))
'pos
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m x))))])
(send (new e%) m 3)))
(test/neg-blame
'class/c-higher-order-inner-10
'(let* ([c% (class object% (super-new) (define/pubment (m x) (+ x (inner x m 3))))]
[d% (contract (class/c (inner [m (-> any/c number? number?)])
(super [m (-> any/c number? number?)]))
(class c% (super-new) (define/augride (m x) (add1 x)))
'pos
'neg)]
[e% (class d% (super-new) (define/override (m x) (+ x (super m #f))))])
(send (new e%) m 3)))
;
;
; ;; ;; ; ;;