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

Fix bug in field mutation on contracted objects.

Browse Source 
svn: r18390
This commit is contained in:
Stevie Strickland 2010-02-27 20:59:40 +00:00
parent cd076ae512
commit 16dbb0edc1
2 changed files with 81 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4378,9 +4378,9 @@
[ext-field-ref (vector-ref old-ext-refs n)] [ext-field-ref (vector-ref old-ext-refs n)]
[ext-field-set (vector-ref old-ext-sets n)]) [ext-field-set (vector-ref old-ext-sets n)])
(vector-set! int-field-refs n (λ (o) (int-field-ref obj))) (vector-set! int-field-refs n (λ (o) (int-field-ref obj)))
(vector-set! int-field-sets n (λ (o) (int-field-set obj))) (vector-set! int-field-sets n (λ (o v) (int-field-set obj v)))
(vector-set! ext-field-refs n (λ (o) (ext-field-ref obj))) (vector-set! ext-field-refs n (λ (o) (ext-field-ref obj)))
(vector-set! ext-field-sets n (λ (o) (ext-field-set obj)))))) (vector-set! ext-field-sets n (λ (o v) (ext-field-set obj v))))))
;; Handle external field contracts ;; Handle external field contracts
(unless (null? fields) (unless (null? fields)

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

@ -5142,7 +5142,6 @@
; ;;;; ; ;;;;
; ;;; ; ;;;
#|
(test/pos-blame (test/pos-blame
'object/c-first-order-object-1 'object/c-first-order-object-1
'(contract (object/c) '(contract (object/c)
@ -5184,7 +5183,85 @@
(new (class object% (super-new) (field [n 3]))) (new (class object% (super-new) (field [n 3])))
'pos 'pos
'neg)) 'neg))
|#
(test/spec-passed/result
'object/c-higher-order-field-1
'(get-field
n
(contract (object/c (field [n number?]))
(new (class object% (super-new) (field [n 3])))
'pos
'neg))
3)
(test/pos-blame
'object/c-higher-order-field-2
'(get-field
n
(contract (object/c (field [n number?]))
(new (class object% (super-new) (field [n #t])))
'pos
'neg)))
(test/spec-passed/result
'object/c-higher-order-field-3
'(let ([o (contract (object/c (field [n number?]))
(new (class object% (super-new) (field [n 3])))
'pos
'neg)])
(set-field! n o 5)
(get-field n o))
5)
(test/neg-blame
'object/c-higher-order-field-4
'(let ([o (contract (object/c (field [n number?]))
(new (class object% (super-new) (field [n 3])))
'pos
'neg)])
(set-field! n o #t)))
(test/spec-passed/result
'object/c-higher-order-field-5
'(let* ([pre-o (new (class object% (super-new) (field [n 3])))]
[o (contract (object/c (field [n number?]))
pre-o
'pos
'neg)])
(set-field! n pre-o 5)
(get-field n o))
5)
(test/spec-passed/result
'object/c-higher-order-field-6
'(let* ([pre-o (new (class object% (super-new) (field [n 3])))]
[o (contract (object/c (field [n number?]))
pre-o
'pos
'neg)])
(set-field! n o 5)
(get-field n pre-o))
5)
(test/neg-blame
'object/c-higher-order-field-7
'(let* ([pre-o (new (class object% (super-new) (field [n 3])))]
[o (contract (object/c (field [n number?]))
pre-o
'pos
'neg)])
(set-field! n o #t)
(get-field n pre-o)))
(test/pos-blame
'object/c-higher-order-field-8
'(let* ([pre-o (new (class object% (super-new) (field [n 3])))]
[o (contract (object/c (field [n number?]))
pre-o
'pos
'neg)])
(set-field! n pre-o #t)
(get-field n o)))
; ;
; ;