Okay, updates to all this crapola. Going to try and see what happens if I
only attach prop:unwrap to wrapped objects. svn: r18313
This commit is contained in:
Stevie Strickland
parent
7e6b4757fa
commit
60b6c81f9f
|
|
@ -78,9 +78,9 @@
|
|||
(syntax
|
||||
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
|
||||
(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!
|
||||
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
|
||||
'print-name super (list intf ...) 'args
|
||||
'(old ...)
|
||||
|
|
|
|||
|
|
@ -211,7 +211,7 @@
|
|||
|
||||
(define-values (prop:unwrap object-unwrapper)
|
||||
(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
|
||||
|
|
@ -1184,7 +1184,7 @@
|
|||
(make-field-map trace-flag
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(quote-syntax (λ (o) ((object-unwrapper o) o)))
|
||||
(quote-syntax object-unwrapper)
|
||||
(quote-syntax inherit-field-name)
|
||||
(quote-syntax inherit-field-name-localized)
|
||||
(quote-syntax inherit-field-accessor)
|
||||
|
|
@ -1194,7 +1194,7 @@
|
|||
(make-field-map trace-flag
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(quote-syntax (λ (o) ((object-unwrapper o) o)))
|
||||
(quote-syntax object-unwrapper)
|
||||
(quote-syntax local-field)
|
||||
(quote-syntax local-field-localized)
|
||||
(quote-syntax local-field-accessor)
|
||||
|
|
@ -2125,7 +2125,7 @@
|
|||
(if make-struct:prim
|
||||
(make-struct:prim c prop:object
|
||||
preparer dispatcher
|
||||
prop:unwrap values
|
||||
prop:unwrap
|
||||
(get-properties interfaces))
|
||||
(values #f #f #f))]
|
||||
[(struct:object object-make object? object-field-ref object-field-set!)
|
||||
|
|
@ -2141,7 +2141,6 @@
|
|||
;; Map object property to class:
|
||||
(append
|
||||
(list (cons prop:object c))
|
||||
(list (cons prop:unwrap values))
|
||||
(if deserialize-id
|
||||
(list
|
||||
(cons prop:serializable
|
||||
|
|
@ -2683,8 +2682,7 @@
|
|||
0 ;; No new fields in this class replacement
|
||||
undefined
|
||||
;; Map object property to class:
|
||||
(list (cons prop:object c)
|
||||
(cons prop:unwrap values)))])
|
||||
(list (cons prop:object c)))])
|
||||
(set-class-struct:object! c struct:object)
|
||||
(set-class-object?! c object?)
|
||||
(set-class-make-object! c object-make)
|
||||
|
|
@ -3310,8 +3308,7 @@
|
|||
(vector-set! (class-supers object%) 0 object%)
|
||||
(set-class-orig-cls! object% object%)
|
||||
(let*-values ([(struct:obj make-obj obj? -get -set!)
|
||||
(make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)
|
||||
(cons prop:unwrap values)) #f)])
|
||||
(make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
|
||||
(set-class-struct:object! object% struct: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
|
||||
|
|
@ -3603,7 +3600,6 @@
|
|||
traced?
|
||||
stx
|
||||
(syntax/loc stx receiver)
|
||||
(syntax/loc stx (λ (o) ((object-unwrapper o) o)))
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
args
|
||||
|
|
@ -3766,7 +3762,6 @@
|
|||
traced?
|
||||
stx
|
||||
(syntax obj)
|
||||
(syntax/loc stx (λ (o) ((object-unwrapper o) o)))
|
||||
(syntax/loc stx ((generic-applicable gen) obj))
|
||||
(syntax/loc stx (generic-name gen))
|
||||
flat-stx
|
||||
|
|
@ -3848,7 +3843,7 @@
|
|||
[field-ht (class-field-ht cls)]
|
||||
[index (hash-ref field-ht id #f)])
|
||||
(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
|
||||
'get-field
|
||||
(format "expected an object that has a field named ~s, got " id)
|
||||
|
|
@ -3884,7 +3879,7 @@
|
|||
[field-ht (class-field-ht cls)]
|
||||
[index (hash-ref field-ht id #f)])
|
||||
(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
|
||||
'get-field
|
||||
(format "expected an object that has a field named ~s, got " id)
|
||||
|
|
@ -3969,8 +3964,7 @@
|
|||
(quote-syntax set!)
|
||||
(quote-syntax id)
|
||||
(quote-syntax method)
|
||||
(quote-syntax method-obj)
|
||||
(syntax (λ (o) ((object-unwrapper o) o))))]
|
||||
(quote-syntax method-obj))]
|
||||
...)
|
||||
()
|
||||
body0 body1 ...)))))]
|
||||
|
|
@ -4023,10 +4017,10 @@
|
|||
(trace (when (object? v) (inspect-event v)))
|
||||
(cond
|
||||
[(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)
|
||||
(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)])))
|
||||
|
||||
(define (subclass? v c)
|
||||
|
|
@ -4044,7 +4038,7 @@
|
|||
(raise-type-error 'object-interface "object" o))
|
||||
(trace-begin
|
||||
(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)
|
||||
(unless (object? o)
|
||||
|
|
@ -4103,7 +4097,7 @@
|
|||
(raise-type-error 'object-info "object" o))
|
||||
(trace-begin
|
||||
(trace (inspect-event o))
|
||||
(let loop ([c (object-ref ((object-unwrapper o) o))]
|
||||
(let loop ([c (object-ref (object-unwrapper o))]
|
||||
[skipped? #f])
|
||||
(if (struct? ((class-insp-mk c)))
|
||||
;; current inspector can inspect this object
|
||||
|
|
@ -4143,7 +4137,7 @@
|
|||
(raise-type-error 'object->vector "object" in-o))
|
||||
(trace-begin
|
||||
(trace (inspect-event in-o))
|
||||
(let ([o ((object-unwrapper in-o) in-o)])
|
||||
(let ([o (object-unwrapper in-o)])
|
||||
(list->vector
|
||||
(cons
|
||||
(string->symbol (format "object:~a" (class-name (object-ref o))))
|
||||
|
|
@ -4170,8 +4164,8 @@
|
|||
(raise-type-error 'object=? "object" o1))
|
||||
(unless (object? o2)
|
||||
(raise-type-error 'object=? "object" o2))
|
||||
(eq? ((object-unwrapper o1) o1)
|
||||
((object-unwrapper o2) o2)))
|
||||
(eq? (object-unwrapper o1)
|
||||
(object-unwrapper o2)))
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; primitive classes
|
||||
|
|
@ -4388,7 +4382,7 @@
|
|||
(define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
|
||||
(check-object-contract obj blame methods fields)
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -270,7 +270,7 @@
|
|||
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
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -287,7 +287,6 @@
|
|||
trace-flag
|
||||
stx
|
||||
method-obj-stx
|
||||
unwrap-stx
|
||||
method-stx
|
||||
(syntax (quote id))
|
||||
flat-args-stx
|
||||
|
|
@ -346,7 +345,7 @@
|
|||
(and (pair? 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?)
|
||||
|
||||
(define-syntax (qstx stx)
|
||||
|
|
@ -360,7 +359,6 @@
|
|||
(if traced?
|
||||
(with-syntax ([(mth obj) (generate-temporaries
|
||||
(list object-stx method-proc-stx))]
|
||||
[unwrap unwrap-stx]
|
||||
[name method-name-stx]
|
||||
[(arg ...) (qstx args)]
|
||||
[(var ...) (generate-temporaries (qstx args))])
|
||||
|
|
@ -368,7 +366,7 @@
|
|||
[obj object]
|
||||
[var arg] ...)
|
||||
(initialize-call-event
|
||||
(unwrap obj) name (app list var ...))
|
||||
obj name (app list var ...))
|
||||
(call-with-values (lambda () (app mth obj var ...))
|
||||
finalize-call-event))))
|
||||
(qstx (app method object . args)))))
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
arguments v...
|
||||
|
||||
(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
|
||||
constructor, predicate, and a struct:type for derived classes.
|
||||
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 procedure.
|
||||
|
||||
The unwrapper takes a possibly wrapped object and returns the
|
||||
unwrapped version (or the object if not wrapped).
|
||||
The unwrap-prop takes a property that, if found on an object,
|
||||
is paired with a function that unwraps the object.
|
||||
|
||||
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);
|
||||
if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type)
|
||||
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)) {
|
||||
name = SCHEME_CAR(props);
|
||||
if (!SCHEME_PAIRP(name))
|
||||
|
|
@ -190,8 +189,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
|
|||
props = SCHEME_CDR(props);
|
||||
}
|
||||
if (!SCHEME_NULLP(props))
|
||||
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 7, argc, argv);
|
||||
props = argv[7];
|
||||
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
|
||||
props = argv[6];
|
||||
|
||||
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: */
|
||||
|
||||
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(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_make_prim_w_arity(class_prepare_struct_type,
|
||||
"primitive-class-prepare-struct-type!",
|
||||
8, 8),
|
||||
7, 7),
|
||||
env);
|
||||
|
||||
scheme_install_xc_global("primitive-class-find-method",
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user