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

Propagate object inspectors in class/c wrappers

Browse Source 
This makes reflection work on an instance of a contracted
class in the same way that it does on the original class.
This commit is contained in:
Asumu Takikawa 2015-09-07 14:08:55 -04:00
parent 81ee1b39c7
commit 52aa11c407
3 changed files with 65 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
pkgs/racket-test/tests/racket/contract/class.rkt
View File

@ -2566,4 +2566,53 @@
(class object%
(super-new)
(define/public (callback f) (f 1))))
promised-produced?)))
promised-produced?))
;; Tests for reflection and class contracts
(test/spec-passed/result
'reflection-1
'(format "~a"
(new (contract (class/c)
(let ([x%
(class object%
(super-new)
(inspect #f)
(init-field [x 0]))])
x%)
'pos 'neg)))
"#(struct:object:x% 0)")
(test/spec-passed/result
'reflection-2
'(format "~a"
(new (contract (class/c)
(let ([x%
(class object%
(super-new)
(init-field [x 0]))])
x%)
'pos 'neg)))
"#(struct:object:x% ...)")
(test/spec-passed/result
'equality-1
'(let ([c%
(contract (class/c)
(class object%
(super-new)
(inspect #f)
(init-field [x 0]))
'pos 'neg)])
(equal? (new c%) (new c%)))
#t)
(test/spec-passed/result
'equality-2
'(let ([c%
(contract (class/c)
(class object%
(super-new)
(init-field [x 0]))
'pos 'neg)])
(equal? (new c%) (new c%)))
#f))

12
racket/collects/racket/private/class-c-old.rkt
View File

@ -213,6 +213,7 @@
supers
(class-self-interface cls)
void ;; No inspecting
(class-obj-inspector cls) ; inherit object inspector
method-width
method-ht
@ -273,7 +274,8 @@
0 ;; No new fields in this class replacement
undefined
;; Map object property to class:
(list (cons prop:object c)))])
(list (cons prop:object c))
(class-obj-inspector cls))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
@ -480,6 +482,7 @@
supers
(class-self-interface cls)
void ;; No inspecting
(class-obj-inspector cls)
method-width
method-ht
@ -542,7 +545,8 @@
0 ;; No new fields in this class replacement
undefined
;; Map object property to class:
(list (cons prop:object c)))])
(list (cons prop:object c))
(class-obj-inspector cls))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
@ -1544,6 +1548,7 @@
(list->vector (vector->list (class-supers cls)))
(class-self-interface cls)
void ;; No inspecting
(class-obj-inspector cls)
method-width
method-ht
@ -1603,7 +1608,8 @@
0 ;; No new fields in this class replacement
undefined
;; Map object property to class:
(list (cons prop:object c)))])
(list (cons prop:object c))
(class-obj-inspector cls))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)

7
racket/collects/racket/private/class-internal.rkt
View File

@ -1996,6 +1996,7 @@
pos supers ; pos is subclass depth, supers is vector
self-interface ; self interface
insp-mk ; dummy struct maker to control inspection access
obj-inspector ; the inspector used for instances of this class
method-width ; total number of methods
method-ht ; maps public names to vector positions
@ -2371,6 +2372,7 @@ last few projections.
i
(let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
make-)
inspector
method-width method-ht method-names remaining-abstract-names
(interfaces->contracted-methods (list i))
#f
@ -3261,6 +3263,7 @@ An example
0 (vector #f)
object<%>
void ; never inspectable
#f ; this is for the inspector on the object
0 (make-hasheq) null null null
#f
@ -3411,6 +3414,7 @@ An example
(list->vector (vector->list (class-supers cls)))
(class-self-interface cls)
void ;; No inspecting
(class-obj-inspector cls)
method-width
method-ht
@ -3462,7 +3466,8 @@ An example
0 ;; No new fields in this class replacement
unsafe-undefined
;; Map object property to class:
(list (cons prop:object c)))])
(list (cons prop:object c))
(class-obj-inspector cls))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)