My first foray into the C side of things.

svn: r18299

collects/scheme/private/class-internal.ss

@@ -2124,7 +2124,7 @@
             ;; --- Make the new object struct ---
             (let*-values ([(prim-object-make prim-object? struct:prim-object)
                            (if make-struct:prim
-                               (make-struct:prim c prop:object preparer dispatcher (get-properties interfaces))
+                               (make-struct:prim c prop:object preparer dispatcher unwrap-object (get-properties interfaces))
                                (values #f #f #f))]
                           [(struct:object object-make object? object-field-ref object-field-set!)
                            (if make-struct:prim
@@ -4189,7 +4189,7 @@
          new-methods)         ; list of methods
   
   ; The `make-struct:prim' function takes prop:object, a
-  ;  class, a preparer, a dispatcher function, and a property assoc list, and produces:
+  ;  class, a preparer, a dispatcher function, an unwrapper, and a property assoc list, and produces:
   ;    * a struct constructor (must have prop:object)
   ;    * a struct predicate
   ;    * a struct type for derived classes (mustn't have prop:object)
@@ -4198,6 +4198,8 @@
   ; 
   ; 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).
+  ;
   ; When a primitive class has a superclass, the struct:prim maker
   ;  is responsible for ensuring that the returned struct items match
   ;  the supertype predicate.

src/mzscheme/utils/xcglue.c

@@ -18,10 +18,10 @@
         arguments v...
 
       (primitive-class-prepare-struct-type! prim-class gen-property
-        gen-value preparer dispatcher extra-props) - prepares a class's 
+        gen-value preparer dispatcher unwrapper extra-props) - prepares a
-        struct-type for objects generated C-side; returns a constructor, 
+        class's  struct-type for objects generated C-side; returns a
-        predicate, and a struct:type for derived classes. The constructor and
+        constructor,  predicate, and a struct:type for derived classes.
-        struct:type map the given dispatcher to the class.
+        The constructor and struct:type map the given dispatcher to the class.
 
         The preparer takes a symbol naming the method. It returns a
         value to be used in future calls to the dispatcher.
@@ -30,6 +30,9 @@
         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 extra-props argument is a list of property--value pairs.
 
       (primitive-class-find-method prim-class sym) - gets the method
@@ -96,6 +99,7 @@ static Scheme_Object *object_struct;
 static Scheme_Object *object_property;
 static Scheme_Object *dispatcher_property;
 static Scheme_Object *preparer_property;
+static Scheme_Object *unwrapper_property;
 
 #ifdef MZ_PRECISE_GC
 # include "../gc2/gc2.h"
@@ -170,8 +174,9 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
     scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
+  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 5, argc, argv);
 
-  props = argv[5];
+  props = argv[6];
   while (SCHEME_PAIRP(props)) {
     name = SCHEME_CAR(props);
     if (!SCHEME_PAIRP(name))
@@ -181,8 +186,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", 5, argc, argv);
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
-  props = argv[5];
+  props = argv[6];
 
   objscheme_something_prepared = 1;
 
@@ -235,7 +240,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
 
   props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]),
 			   scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]),
-					    props));
+					    scheme_make_pair(scheme_make_pair(unwrapper_property, argv[5]),
+							     props)));
   
   stype = scheme_make_struct_type(name,
 				  base_stype, 
@@ -453,7 +459,18 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
 
 Scheme_Object *objscheme_unwrap(Scheme_Object *o)
 {
-  return o;
+  Scheme_Object *s[1], *unwrapper;
+
+  if (!o)
+    return NULL;
+
+  unwrapper = scheme_struct_type_property_ref(unwrapper_property, (Scheme_Object *)o);
+  if (!unwrapper)
+    return NULL;
+
+  s[0] = o;
+
+  return _scheme_apply(unwrapper, 1, s);
 }
 
 /***************************************************************************/
@@ -523,6 +540,9 @@ void objscheme_init(Scheme_Env *env)
   wxREGGLOB(dispatcher_property);
   dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
 
+  wxREGGLOB(unwrapper_property);
+  unwrapper_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-unwrapper"));
+
   wxREGGLOB(object_struct);
   object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
 					  NULL, NULL,