From 60b6c81f9f08c0b5c9598ade16b46060588fee02 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 23 Feb 2010 23:56:08 +0000 Subject: [PATCH] Okay, updates to all this crapola. Going to try and see what happens if I only attach prop:unwrap to wrapped objects. svn: r18313 --- collects/mred/private/kernel.ss | 4 +-- collects/scheme/private/class-internal.ss | 40 ++++++++++------------- collects/scheme/private/classidmap.ss | 8 ++--- src/mzscheme/utils/xcglue.c | 16 ++++----- 4 files changed, 29 insertions(+), 39 deletions(-) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 7b5042e6a5..552a2856c7 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -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 ...) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 66293218c0..26611adb16 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -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 diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss index 26aa28c34f..3aa5eac5ed 100644 --- a/collects/scheme/private/classidmap.ss +++ b/collects/scheme/private/classidmap.ss @@ -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))))) diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c index 1acd8c9884..2454fe7777 100644 --- a/src/mzscheme/utils/xcglue.c +++ b/src/mzscheme/utils/xcglue.c @@ -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",