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

Have external field accessors/mutators just redirect to the old object

Browse Source 
themselves.  Also, have all objects carry the prop:unwrap property.

svn: r18330
This commit is contained in:
Stevie Strickland 2010-02-24 23:32:44 +00:00
parent 3955ef69b4
commit 1f10c4e422
4 changed files with 69 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/kernel.ss
View File

@ -78,9 +78,9 @@
(syntax (syntax
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) (define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(make-primitive-class (make-primitive-class
(lambda (class prop:object preparer dispatcher prop:unwrap more-props) (lambda (class prop:object preparer dispatcher prop:unwrap unwrapper more-props)
(kernel:primitive-class-prepare-struct-type! (kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher prop:unwrap more-props)) c prop:object class preparer dispatcher prop:unwrap unwrapper more-props))
kernel:initialize-primitive-object kernel:initialize-primitive-object
'print-name super (list intf ...) 'args 'print-name super (list intf ...) 'args
'(old ...) '(old ...)

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

@ -211,10 +211,7 @@
(define-values (prop:unwrap object-unwrapper) (define-values (prop:unwrap object-unwrapper)
(let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)]) (let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)])
;; Instead of using the accessor if it has prop:unwrap, just use the unwrapper (values prop:unwrap acc)))
;; from wrapper-object directly, since we know it must be a wrapped object.
;; (The accessor will just give us that anyway.)
(values prop:unwrap (λ (o) (if (pred o) (wrapper-object-wrapped o) o)))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; class macros ;; class macros
@ -2128,7 +2125,7 @@
(if make-struct:prim (if make-struct:prim
(make-struct:prim c prop:object (make-struct:prim c prop:object
preparer dispatcher preparer dispatcher
prop:unwrap prop:unwrap values
(get-properties interfaces)) (get-properties interfaces))
(values #f #f #f))] (values #f #f #f))]
[(struct:object object-make object? object-field-ref object-field-set!) [(struct:object object-make object? object-field-ref object-field-set!)
@ -2143,7 +2140,8 @@
num-fields undefined num-fields undefined
;; Map object property to class: ;; Map object property to class:
(append (append
(list (cons prop:object c)) (list (cons prop:object c)
(cons prop:unwrap values))
(if deserialize-id (if deserialize-id
(list (list
(cons prop:serializable (cons prop:serializable
@ -2685,7 +2683,8 @@
0 ;; No new fields in this class replacement 0 ;; No new fields in this class replacement
undefined undefined
;; Map object property to class: ;; Map object property to class:
(list (cons prop:object c)))]) (list (cons prop:object c)
(cons prop:unwrap values)))])
(set-class-struct:object! c struct:object) (set-class-struct:object! c struct:object)
(set-class-object?! c object?) (set-class-object?! c object?)
(set-class-make-object! c object-make) (set-class-make-object! c object-make)
@ -2737,13 +2736,14 @@
[c (in-list (class/c-field-contracts ctc))]) [c (in-list (class/c-field-contracts ctc))])
(when c (when c
(let* ([i (hash-ref field-ht f)] (let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)] [p-pos ((contract-projection c) blame)]
[p-neg ((contract-projection c) bset)]
[old-ref (vector-ref ext-field-refs i)] [old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)]) [old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i (vector-set! ext-field-refs i
(λ (o) ((pre-p blame) (old-ref o)))) (λ (o) (p-pos (old-ref o))))
(vector-set! ext-field-sets i (vector-set! ext-field-sets i
(λ (o v) (old-set o ((pre-p bset) v))))))))) (λ (o v) (old-set o (p-neg v)))))))))
;; Handle internal field contracts ;; Handle internal field contracts
(unless (null? (class/c-inherit-fields ctc)) (unless (null? (class/c-inherit-fields ctc))
@ -2754,13 +2754,14 @@
[c (in-list (class/c-inherit-field-contracts ctc))]) [c (in-list (class/c-inherit-field-contracts ctc))])
(when c (when c
(let* ([i (hash-ref field-ht f)] (let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)] [p-pos ((contract-projection c) blame)]
[p-neg ((contract-projection c) bset)]
[old-ref (vector-ref int-field-refs i)] [old-ref (vector-ref int-field-refs i)]
[old-set (vector-ref int-field-sets i)]) [old-set (vector-ref int-field-sets i)])
(vector-set! int-field-refs i (vector-set! int-field-refs i
(λ (o) ((pre-p blame) (old-ref o)))) (λ (o) (p-pos (old-ref o))))
(vector-set! int-field-sets i (vector-set! int-field-sets i
(λ (o v) (old-set o ((pre-p bset) v))))))))) (λ (o v) (old-set o (p-neg v)))))))))
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
;; First we update any dynamic indexes, as applicable. ;; First we update any dynamic indexes, as applicable.
@ -3311,7 +3312,7 @@
(vector-set! (class-supers object%) 0 object%) (vector-set! (class-supers object%) 0 object%)
(set-class-orig-cls! object% object%) (set-class-orig-cls! object% object%)
(let*-values ([(struct:obj make-obj obj? -get -set!) (let*-values ([(struct:obj make-obj obj? -get -set!)
(make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)]) (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%) (cons prop:unwrap values)) #f)])
(set-class-struct:object! object% struct:obj) (set-class-struct:object! object% struct:obj)
(set-class-make-object! object% make-obj)) (set-class-make-object! object% make-obj))
(set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
@ -3846,7 +3847,7 @@
[field-ht (class-field-ht cls)] [field-ht (class-field-ht cls)]
[index (hash-ref field-ht id #f)]) [index (hash-ref field-ht id #f)])
(if index (if index
((vector-ref (class-ext-field-sets cls) index) (object-unwrapper obj) val) ((vector-ref (class-ext-field-sets cls) index) obj val)
(raise-mismatch-error (raise-mismatch-error
'get-field 'get-field
(format "expected an object that has a field named ~s, got " id) (format "expected an object that has a field named ~s, got " id)
@ -3882,7 +3883,7 @@
[field-ht (class-field-ht cls)] [field-ht (class-field-ht cls)]
[index (hash-ref field-ht id #f)]) [index (hash-ref field-ht id #f)])
(if index (if index
((vector-ref (class-ext-field-refs cls) index) (object-unwrapper obj)) ((vector-ref (class-ext-field-refs cls) index) obj)
(raise-mismatch-error (raise-mismatch-error
'get-field 'get-field
(format "expected an object that has a field named ~s, got " id) (format "expected an object that has a field named ~s, got " id)
@ -4020,10 +4021,10 @@
(trace (when (object? v) (inspect-event v))) (trace (when (object? v) (inspect-event v)))
(cond (cond
[(not (object? v)) #f] [(not (object? v)) #f]
[(class? c) ((class-object? (class-orig-cls c)) (object-unwrapper v))] [(class? c) ((class-object? (class-orig-cls c)) ((object-unwrapper v) v))]
[(interface? c) [(interface? c)
(and (object? v) (and (object? v)
(implementation? (object-ref (object-unwrapper v)) c))] (implementation? (object-ref ((object-unwrapper v) v)) c))]
[else (raise-type-error 'is-a? "class or interface" 1 v c)]))) [else (raise-type-error 'is-a? "class or interface" 1 v c)])))
(define (subclass? v c) (define (subclass? v c)
@ -4041,7 +4042,7 @@
(raise-type-error 'object-interface "object" o)) (raise-type-error 'object-interface "object" o))
(trace-begin (trace-begin
(trace (inspect-event o)) (trace (inspect-event o))
(class-self-interface (object-ref (object-unwrapper o))))) (class-self-interface (object-ref ((object-unwrapper o) o)))))
(define-traced (object-method-arity-includes? o name cnt) (define-traced (object-method-arity-includes? o name cnt)
(unless (object? o) (unless (object? o)
@ -4100,7 +4101,7 @@
(raise-type-error 'object-info "object" o)) (raise-type-error 'object-info "object" o))
(trace-begin (trace-begin
(trace (inspect-event o)) (trace (inspect-event o))
(let loop ([c (object-ref (object-unwrapper o))] (let loop ([c (object-ref ((object-unwrapper o) o))]
[skipped? #f]) [skipped? #f])
(if (struct? ((class-insp-mk c))) (if (struct? ((class-insp-mk c)))
;; current inspector can inspect this object ;; current inspector can inspect this object
@ -4140,7 +4141,7 @@
(raise-type-error 'object->vector "object" in-o)) (raise-type-error 'object->vector "object" in-o))
(trace-begin (trace-begin
(trace (inspect-event in-o)) (trace (inspect-event in-o))
(let ([o (object-unwrapper in-o)]) (let ([o ((object-unwrapper in-o) in-o)])
(list->vector (list->vector
(cons (cons
(string->symbol (format "object:~a" (class-name (object-ref o)))) (string->symbol (format "object:~a" (class-name (object-ref o))))
@ -4167,8 +4168,8 @@
(raise-type-error 'object=? "object" o1)) (raise-type-error 'object=? "object" o1))
(unless (object? o2) (unless (object? o2)
(raise-type-error 'object=? "object" o2)) (raise-type-error 'object=? "object" o2))
(eq? (object-unwrapper o1) (eq? ((object-unwrapper o1) o1)
(object-unwrapper o2))) ((object-unwrapper o2) o2)))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; primitive classes ;; primitive classes
@ -4186,8 +4187,9 @@
override-methods ; list of methods override-methods ; list of methods
new-methods) ; list of methods new-methods) ; list of methods
; The `make-struct:prim' function takes prop:object, a ; The `make-struct:prim' function takes prop:object, a class,
; class, a preparer, a dispatcher function, an unwrapper, and a property assoc list, and produces: ; a preparer, a dispatcher function, an unwrap property,
; an unwrapper, and a property assoc list, and produces:
; * a struct constructor (must have prop:object) ; * a struct constructor (must have prop:object)
; * a struct predicate ; * a struct predicate
; * a struct type for derived classes (mustn't have prop:object) ; * a struct type for derived classes (mustn't have prop:object)
@ -4196,7 +4198,11 @@
; ;
; The supplied dispatcher takes an object and a num and returns a method. ; The supplied dispatcher takes an object and a num and returns a method.
; ;
; The supplied unwrapper takes an object and returns the unwrapped version (or the original object). ; The supplied unwrap property is used for adding the unwrapper
; as a property value on new objects.
;
; The supplied unwrapper takes an object and returns the unwrapped
; version (or the original object).
; ;
; When a primitive class has a superclass, the struct:prim maker ; When a primitive class has a superclass, the struct:prim maker
; is responsible for ensuring that the returned struct items match ; is responsible for ensuring that the returned struct items match
@ -4264,7 +4270,7 @@
;; wrapper for contracts ;; wrapper for contracts
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define (make-wrapper-class cls blame methods method-contracts fields field-contracts) (define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts)
(let* ([name (class-name cls)] (let* ([name (class-name cls)]
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
[method-ht (class-method-ht cls)] [method-ht (class-method-ht cls)]
@ -4356,13 +4362,20 @@
[p ((contract-projection c) blame)]) [p ((contract-projection c) blame)])
(vector-set! meths i (p (vector-ref meths i))))))) (vector-set! meths i (p (vector-ref meths i)))))))
;; Fix up internal/external field accessors/mutators ;; Redirect internal/external field accessors/mutators to old object
;; Normally we'd redirect these, but since make-field-map now unwraps (let ([old-int-refs (class-int-field-refs cls)]
;; on all accesses, we just copy over the old vectors. [old-int-sets (class-int-field-sets cls)]
(vector-copy! int-field-refs 0 (class-int-field-refs cls)) [old-ext-refs (class-ext-field-refs cls)]
(vector-copy! int-field-sets 0 (class-int-field-sets cls)) [old-ext-sets (class-ext-field-sets cls)])
(vector-copy! ext-field-refs 0 (class-ext-field-refs cls)) (for ([n (in-range (class-field-pub-width cls))])
(vector-copy! ext-field-sets 0 (class-ext-field-sets cls)) (let ([int-field-ref (vector-ref old-int-refs n)]
[int-field-set (vector-ref old-int-sets n)]
[ext-field-ref (vector-ref old-ext-refs 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-sets n (λ (o) (int-field-set obj)))
(vector-set! ext-field-refs n (λ (o) (ext-field-ref obj)))
(vector-set! ext-field-sets n (λ (o) (ext-field-set obj))))))
;; Handle external field contracts ;; Handle external field contracts
(unless (null? fields) (unless (null? fields)
@ -4371,21 +4384,23 @@
[c (in-list field-contracts)]) [c (in-list field-contracts)])
(when c (when c
(let* ([i (hash-ref field-ht f)] (let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)] [p-pos ((contract-projection c) blame)]
[p-neg ((contract-projection c) bset)]
[old-ref (vector-ref ext-field-refs i)] [old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)]) [old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i (vector-set! ext-field-refs i
(λ (o) ((pre-p blame) (old-ref o)))) (λ (o) (p-pos (old-ref o))))
(vector-set! ext-field-sets i (vector-set! ext-field-sets i
(λ (o v) (old-set o ((pre-p bset) v))))))))) (λ (o v) (old-set o (p-neg v)))))))))
c)) c))
;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?) ;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?)
(define (make-wrapper-object obj blame methods method-contracts fields field-contracts) (define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
(check-object-contract obj blame methods fields) (check-object-contract obj blame methods fields)
(let ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) (let* ([orig-obj ((object-unwrapper obj) obj)]
((class-make-object new-cls) (object-unwrapper obj)))) [new-cls (make-wrapper-class orig-obj (object-ref obj) blame methods method-contracts fields field-contracts)])
((class-make-object new-cls) orig-obj)))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; misc utils ;; misc utils

8
collects/scheme/private/classidmap.ss
View File

@ -59,7 +59,7 @@
[(f . args) [(f . args)
(quasisyntax/loc stx (#,replace-stx . args))]))))) (quasisyntax/loc stx (#,replace-stx . args))])))))
(define (make-field-map trace-flag the-finder the-obj unwrapper the-binder the-binder-localized (define (make-field-map trace-flag the-finder the-obj the-unwrapper-access the-binder the-binder-localized
field-accessor field-mutator field-pos/null) field-accessor field-mutator field-pos/null)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
@ -73,7 +73,7 @@
[trace (syntax/loc stx (set-event obj (quote id) id))] [trace (syntax/loc stx (set-event obj (quote id) id))]
[set (quasisyntax/loc stx [set (quasisyntax/loc stx
((unsyntax field-mutator) ((unsyntax field-mutator)
((unsyntax unwrapper) obj) (((unsyntax the-unwrapper-access) obj) obj)
(unsyntax-splicing field-pos/null) id))]) (unsyntax-splicing field-pos/null) id))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace set)) (syntax/loc stx (let* bindings trace set))
@ -83,7 +83,7 @@
[trace (syntax/loc stx (get-event obj (quote id)))] [trace (syntax/loc stx (get-event obj (quote id)))]
[call (quasisyntax/loc stx [call (quasisyntax/loc stx
(((unsyntax field-accessor) (((unsyntax field-accessor)
((unsyntax unwrapper) obj-expr) (((unsyntax the-unwrapper-access) obj) obj)
(unsyntax-splicing field-pos/null)) . args))]) (unsyntax-splicing field-pos/null)) . args))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace call)) (syntax/loc stx (let* bindings trace call))
@ -93,7 +93,7 @@
[trace (syntax/loc stx (get-event obj (quote id)))] [trace (syntax/loc stx (get-event obj (quote id)))]
[get (quasisyntax/loc stx [get (quasisyntax/loc stx
((unsyntax field-accessor) ((unsyntax field-accessor)
((unsyntax unwrapper) obj-expr) (((unsyntax the-unwrapper-access) obj) obj)
(unsyntax-splicing field-pos/null)))]) (unsyntax-splicing field-pos/null)))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings trace get))

15
src/mzscheme/utils/xcglue.c
View File

@ -178,8 +178,9 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv); scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type) if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type)
scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 5, argc, argv); scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 5, argc, argv);
scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 6, argc, argv);
props = argv[6]; props = argv[7];
while (SCHEME_PAIRP(props)) { while (SCHEME_PAIRP(props)) {
name = SCHEME_CAR(props); name = SCHEME_CAR(props);
if (!SCHEME_PAIRP(name)) if (!SCHEME_PAIRP(name))
@ -189,8 +190,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
props = SCHEME_CDR(props); props = SCHEME_CDR(props);
} }
if (!SCHEME_NULLP(props)) if (!SCHEME_NULLP(props))
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv); scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 7, argc, argv);
props = argv[6]; props = argv[7];
objscheme_something_prepared = 1; objscheme_something_prepared = 1;
@ -225,9 +226,9 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
/* Type to use when instantiating from C: */ /* Type to use when instantiating from C: */
props = scheme_make_pair(scheme_make_pair(object_property, props = scheme_null;
argv[0]), props = scheme_make_pair(scheme_make_pair(object_property, argv[0]), props);
scheme_null); props = scheme_make_pair(scheme_make_pair(argv[5], argv[6]), props);
stype = scheme_make_struct_type(name, stype = scheme_make_struct_type(name,
base_stype, base_stype,
@ -567,7 +568,7 @@ void objscheme_init(Scheme_Env *env)
scheme_install_xc_global("primitive-class-prepare-struct-type!", scheme_install_xc_global("primitive-class-prepare-struct-type!",
scheme_make_prim_w_arity(class_prepare_struct_type, scheme_make_prim_w_arity(class_prepare_struct_type,
"primitive-class-prepare-struct-type!", "primitive-class-prepare-struct-type!",
7, 7), 8, 8),
env); env);
scheme_install_xc_global("primitive-class-find-method", scheme_install_xc_global("primitive-class-find-method",