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

Okay, updates to all this crapola. Going to try and see what happens if I

Browse Source 
only attach prop:unwrap to wrapped objects.

svn: r18313
This commit is contained in:
Stevie Strickland 2010-02-23 23:56:08 +00:00
parent 7e6b4757fa
commit 60b6c81f9f
4 changed files with 29 additions and 39 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 unwrapper more-props) (lambda (class prop:object preparer dispatcher prop:unwrap more-props)
(kernel:primitive-class-prepare-struct-type! (kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher prop:unwrap unwrapper more-props)) c prop:object class preparer dispatcher prop:unwrap more-props))
kernel:initialize-primitive-object kernel:initialize-primitive-object
'print-name super (list intf ...) 'args 'print-name super (list intf ...) 'args
'(old ...) '(old ...)

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

@ -211,7 +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)])
(values prop:unwrap acc))) (values prop:unwrap (λ (o) (if (pred o) (wrapper-object-wrapped o) o)))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; class macros ;; class macros
@ -1184,7 +1184,7 @@
(make-field-map trace-flag (make-field-map trace-flag
(quote-syntax the-finder) (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax (λ (o) ((object-unwrapper o) o))) (quote-syntax object-unwrapper)
(quote-syntax inherit-field-name) (quote-syntax inherit-field-name)
(quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-name-localized)
(quote-syntax inherit-field-accessor) (quote-syntax inherit-field-accessor)
@ -1194,7 +1194,7 @@
(make-field-map trace-flag (make-field-map trace-flag
(quote-syntax the-finder) (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax (λ (o) ((object-unwrapper o) o))) (quote-syntax object-unwrapper)
(quote-syntax local-field) (quote-syntax local-field)
(quote-syntax local-field-localized) (quote-syntax local-field-localized)
(quote-syntax local-field-accessor) (quote-syntax local-field-accessor)
@ -2125,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 values prop:unwrap
(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!)
@ -2141,7 +2141,6 @@
;; Map object property to class: ;; Map object property to class:
(append (append
(list (cons prop:object c)) (list (cons prop:object c))
(list (cons prop:unwrap values))
(if deserialize-id (if deserialize-id
(list (list
(cons prop:serializable (cons prop:serializable
@ -2683,8 +2682,7 @@
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)
@ -3310,8 +3308,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%) (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
(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
@ -3603,7 +3600,6 @@
traced? traced?
stx stx
(syntax/loc stx receiver) (syntax/loc stx receiver)
(syntax/loc stx (λ (o) ((object-unwrapper o) o)))
(syntax/loc stx method) (syntax/loc stx method)
(syntax/loc stx sym) (syntax/loc stx sym)
args args
@ -3766,7 +3762,6 @@
traced? traced?
stx stx
(syntax obj) (syntax obj)
(syntax/loc stx (λ (o) ((object-unwrapper o) o)))
(syntax/loc stx ((generic-applicable gen) obj)) (syntax/loc stx ((generic-applicable gen) obj))
(syntax/loc stx (generic-name gen)) (syntax/loc stx (generic-name gen))
flat-stx flat-stx
@ -3848,7 +3843,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) obj) val) ((vector-ref (class-ext-field-sets cls) index) (object-unwrapper 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)
@ -3884,7 +3879,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) obj)) ((vector-ref (class-ext-field-refs cls) index) (object-unwrapper 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)
@ -3969,8 +3964,7 @@
(quote-syntax set!) (quote-syntax set!)
(quote-syntax id) (quote-syntax id)
(quote-syntax method) (quote-syntax method)
(quote-syntax method-obj) (quote-syntax method-obj))]
(syntax (λ (o) ((object-unwrapper o) o))))]
...) ...)
() ()
body0 body1 ...)))))] body0 body1 ...)))))]
@ -4023,10 +4017,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) v))] [(class? c) ((class-object? (class-orig-cls c)) (object-unwrapper v))]
[(interface? c) [(interface? c)
(and (object? v) (and (object? v)
(implementation? (object-ref ((object-unwrapper v) v)) c))] (implementation? (object-ref (object-unwrapper 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)
@ -4044,7 +4038,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) o))))) (class-self-interface (object-ref (object-unwrapper 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)
@ -4103,7 +4097,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) o))] (let loop ([c (object-ref (object-unwrapper 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
@ -4143,7 +4137,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) in-o)]) (let ([o (object-unwrapper 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))))
@ -4170,8 +4164,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) o1) (eq? (object-unwrapper o1)
((object-unwrapper o2) o2))) (object-unwrapper o2)))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; primitive classes ;; primitive classes
@ -4388,7 +4382,7 @@
(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 ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)])
((class-make-object new-cls) ((object-unwrapper obj) obj)))) ((class-make-object new-cls) (object-unwrapper obj))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; misc utils ;; misc utils

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

@ -270,7 +270,7 @@
stx))) stx)))
(define (make-with-method-map trace-flag set!-stx id-stx (define (make-with-method-map trace-flag set!-stx id-stx
method-stx method-obj-stx unwrap-stx) method-stx method-obj-stx)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -287,7 +287,6 @@
trace-flag trace-flag
stx stx
method-obj-stx method-obj-stx
unwrap-stx
method-stx method-stx
(syntax (quote id)) (syntax (quote id))
flat-args-stx flat-args-stx
@ -346,7 +345,7 @@
(and (pair? ctx) (and (pair? ctx)
(class-context? (car ctx)))) (class-context? (car ctx))))
(define (make-method-call traced? source-stx object-stx unwrap-stx (define (make-method-call traced? source-stx object-stx
method-proc-stx method-name-stx args-stx rest-arg?) method-proc-stx method-name-stx args-stx rest-arg?)
(define-syntax (qstx stx) (define-syntax (qstx stx)
@ -360,7 +359,6 @@
(if traced? (if traced?
(with-syntax ([(mth obj) (generate-temporaries (with-syntax ([(mth obj) (generate-temporaries
(list object-stx method-proc-stx))] (list object-stx method-proc-stx))]
[unwrap unwrap-stx]
[name method-name-stx] [name method-name-stx]
[(arg ...) (qstx args)] [(arg ...) (qstx args)]
[(var ...) (generate-temporaries (qstx args))]) [(var ...) (generate-temporaries (qstx args))])
@ -368,7 +366,7 @@
[obj object] [obj object]
[var arg] ...) [var arg] ...)
(initialize-call-event (initialize-call-event
(unwrap obj) name (app list var ...)) obj name (app list var ...))
(call-with-values (lambda () (app mth obj var ...)) (call-with-values (lambda () (app mth obj var ...))
finalize-call-event)))) finalize-call-event))))
(qstx (app method object . args))))) (qstx (app method object . args)))))

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

@ -18,7 +18,7 @@
arguments v... arguments v...
(primitive-class-prepare-struct-type! prim-class gen-property (primitive-class-prepare-struct-type! prim-class gen-property
gen-value preparer dispatcher unwrapper extra-props) - prepares a gen-value preparer dispatcher unwrap-prop extra-props) - prepares a
class's struct-type for objects generated C-side; returns a class's struct-type for objects generated C-side; returns a
constructor, predicate, and a struct:type for derived classes. constructor, predicate, and a struct:type for derived classes.
The constructor and struct:type map the given dispatcher to the class. The constructor and struct:type map the given dispatcher to the class.
@ -30,8 +30,8 @@
method-specific value produced by the prepaper. It returns a method-specific value produced by the prepaper. It returns a
method procedure. method procedure.
The unwrapper takes a possibly wrapped object and returns the The unwrap-prop takes a property that, if found on an object,
unwrapped version (or the object if not wrapped). is paired with a function that unwraps the object.
The extra-props argument is a list of property--value pairs. The extra-props argument is a list of property--value pairs.
@ -178,9 +178,8 @@ 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[7]; props = argv[6];
while (SCHEME_PAIRP(props)) { while (SCHEME_PAIRP(props)) {
name = SCHEME_CAR(props); name = SCHEME_CAR(props);
if (!SCHEME_PAIRP(name)) if (!SCHEME_PAIRP(name))
@ -190,8 +189,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", 7, argc, argv); scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
props = argv[7]; props = argv[6];
objscheme_something_prepared = 1; objscheme_something_prepared = 1;
@ -243,7 +242,6 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
/* Type to derive/instantiate from Scheme: */ /* Type to derive/instantiate from Scheme: */
c->unwrap_property = argv[5]; c->unwrap_property = argv[5];
props = scheme_make_pair(scheme_make_pair(argv[5], argv[6]), props);
props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props); props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props);
props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props); props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props);
@ -568,7 +566,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!",
8, 8), 7, 7),
env); env);
scheme_install_xc_global("primitive-class-find-method", scheme_install_xc_global("primitive-class-find-method",