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

Apply the inherit-field projections appropriately.

Browse Source 
svn: r18204
This commit is contained in:
Stevie Strickland 2010-02-20 04:18:49 +00:00
parent fcee6788d7
commit aaf9a5aeac
2 changed files with 77 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2518,6 +2518,12 @@
(make-vector method-width))]
[field-pub-width (class-field-pub-width cls)]
[field-ht (class-field-ht cls)]
[int-field-refs (if (null? (class/c-inherits ctc))
(class-int-field-refs cls)
(make-vector field-pub-width))]
[int-field-sets (if (null? (class/c-inherits ctc))
(class-int-field-sets cls)
(make-vector field-pub-width))]
[ext-field-refs (if (null? (class/c-fields ctc))
(class-ext-field-refs cls)
(make-vector field-pub-width))]
@ -2552,8 +2558,8 @@
field-ht
(class-field-ids cls)
(class-int-field-refs cls)
(class-int-field-sets cls)
int-field-refs
int-field-sets
ext-field-refs
ext-field-sets
@ -2647,6 +2653,27 @@
(λ (o v)
(old-set o ((pre-p bset) v))))))))
;; Handle internal field contracts
(unless (null? (class/c-inherits ctc))
(let ([old-refs (class-int-field-refs cls)]
[old-sets (class-int-field-sets cls)])
(for ([n (in-range field-pub-width)])
(vector-set! int-field-refs n (vector-ref old-refs n))
(vector-set! int-field-sets n (vector-ref old-sets n))))
(let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-inherits ctc))]
[c (in-list (class/c-inherit-contracts ctc))])
(let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)]
[old-ref (vector-ref int-field-refs i)]
[old-set (vector-ref int-field-sets i)])
(vector-set! int-field-refs i
(λ (o)
((pre-p blame) (old-ref o))))
(vector-set! int-field-sets i
(λ (o v)
(old-set o ((pre-p bset) v))))))))
c))))
(define-struct class/c

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

@ -4546,6 +4546,54 @@
[o (new c%)])
(set-field! f o #f)))
(test/spec-passed/result
'class/c-higher-order-inherit-1
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f 10]))
'pos
'neg)]
[d% (class c% (super-new)
(inherit-field f)
(define/public (m) f))])
(send (new d%) m))
10)
(test/spec-passed/result
'class/c-higher-order-inherit-2
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f 10]))
'pos
'neg)]
[d% (class c% (super-new)
(inherit-field f)
(define/public (m) (set! f 12)))]
[o (new d%)])
(send o m)
(get-field f o))
12)
(test/pos-blame
'class/c-higher-order-inherit-3
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f #f]))
'pos
'neg)]
[d% (class c% (super-new)
(inherit-field f)
(define/public (m) f))])
(send (new d%) m)))
(test/neg-blame
'class/c-higher-order-inherit-4
'(let* ([c% (contract (class/c (inherit-field [f number?]))
(class object% (super-new) (field [f 10]))
'pos
'neg)]
[d% (class c% (super-new)
(inherit-field f)
(define/public (m) (set! f #f)))])
(send (new d%) m)))
;
;
; ;; ;; ; ;;