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

External field contracts FTW!

Browse Source 
svn: r18202
This commit is contained in:
Stevie Strickland 2010-02-20 03:52:47 +00:00
parent 1688a6c3f7
commit d87794a8d2
2 changed files with 71 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2513,6 +2513,14 @@
[inner-projs (if (null? (class/c-inners ctc)) [inner-projs (if (null? (class/c-inners ctc))
(class-inner-projs cls) (class-inner-projs cls)
(make-vector method-width))] (make-vector method-width))]
[field-pub-width (class-field-pub-width cls)]
[field-ht (class-field-ht cls)]
[ext-field-refs (if (null? (class/c-fields ctc))
(class-ext-field-refs cls)
(make-vector field-pub-width))]
[ext-field-sets (if (null? (class/c-fields ctc))
(class-ext-field-sets cls)
(make-vector field-pub-width))]
[class-make (if name [class-make (if name
(make-naming-constructor (make-naming-constructor
struct:class struct:class
@ -2537,14 +2545,14 @@
inner-projs inner-projs
(class-field-width cls) (class-field-width cls)
(class-field-pub-width cls) field-pub-width
(class-field-ht cls) field-ht
(class-field-ids cls) (class-field-ids cls)
(class-int-field-refs cls) (class-int-field-refs cls)
(class-int-field-sets cls) (class-int-field-sets cls)
(class-ext-field-refs cls) ext-field-refs
(class-ext-field-sets cls) ext-field-sets
'struct:object 'object? 'make-object 'struct:object 'object? 'make-object
'field-ref 'field-set! 'field-ref 'field-set!
@ -2615,6 +2623,27 @@
(vector-set! inner-projs i (vector-set! inner-projs i
(compose (vector-ref inner-projs i) p)))))) (compose (vector-ref inner-projs i) p))))))
;; Handle external field contracts
(unless (null? (class/c-fields ctc))
(let ([old-refs (class-ext-field-refs cls)]
[old-sets (class-ext-field-sets cls)])
(for ([n (in-range field-pub-width)])
(vector-set! ext-field-refs n (vector-ref old-refs n))
(vector-set! ext-field-sets n (vector-ref old-sets n))))
(let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-fields ctc))]
[c (in-list (class/c-field-contracts ctc))])
(let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)]
[old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i
(λ (o)
((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i
(λ (o v)
(old-set o ((pre-p bset) v))))))))
c)))) c))))
(define-struct class/c (define-struct class/c

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

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