Back to index

plt-scheme  4.2.1
tree.cxx
Go to the documentation of this file.
00001 /* Example demonstrating how to inject a C++ class into the class
00002    world of MzLib's class.ss library.
00003 
00004    Since it uses C++, this example can be slightly tricky to compile.
00005    Specifying a C++ linker (e.g., g++) ensures that the right C++
00006    libraries get included:
00007      mzc --cc tree.cxx
00008      mzc --linker /usr/bin/g++ --ld tree.so tree.o
00009 
00010   The C++ class Tree defines the following:
00011 
00012     Tree(int init_leaves);                       constructor
00013 
00014     int leaves;                                  \ fields
00015     Tree *left_branch, *right_branch;            /
00016 
00017     void Graft(Tree *left, Tree *right);         method
00018 
00019     virtual void Grow(int n);                    \ overloaded and
00020     virtual void Grow(char *cmd, char *&result); / with ref param
00021 
00022   The Scheme version of the class has the following methods:
00023 
00024     "get-leaves", "get-left", "get-rght" -- gets field values
00025     "grow" -- override to replace C++ methods
00026     "graft" -- takes Scheme tree% objects
00027 
00028   Example use in Scheme:
00029 
00030     (load-extension "tree.so") ; defines tree-primitive-class and
00031                                ; other things not to be used directly
00032     (load "tree-finish.ss") ; defines tree%
00033 
00034     (define o (make-object tree% 10))
00035     (send o get-leaves) ; => 10
00036     (send o get-left) ; => #f
00037 
00038     (send o grow 2) ; grows new branches on the frontier
00039     (send o get-left) ; => #<object:tree%>
00040     (send (send o get-left) get-leaves) ; => 2
00041     
00042     (define b (box "sunshine"))
00043     (send o grow "sunshine" b)
00044     (unbox b) ; => "sprouted left"
00045 
00046     (define apple-tree%
00047       (class tree%
00048         (inherit graft)
00049         (override grow)
00050         
00051         (define grow
00052           ;; This `grow' drops branches and grows new ones.
00053           ;; For the command-string form, it does nothing.
00054           (case-lambda 
00055            [(n)
00056             (let ([l (make-object apple-tree%)]
00057                   [r (make-object apple-tree%)])
00058               (graft l r))]
00059            [(cmd result)
00060             (set-box! result (format "ignoring ~a" cmd))]))
00061 
00062         (super-instantiate () (leaves 1))))
00063 
00064     (define a (make-object apple-tree%))
00065     (send a get-leaves) ; => 1
00066     (send a grow 1)
00067     (send a get-left) ; => #<struct:object:apple-tree%>
00068 
00069     (define o (make-object tree% 10))
00070     (define a (make-object apple-tree%))
00071     (send o graft a #f)
00072     (send o grow 1)   ; C++ calls apple-tree%'s `grow' for `a'
00073     (send a get-left) ; -> #<struct:object:apple-tree>
00074 
00075     (send a grow "sunshine" b)
00076     (unbox b) ; => "ignoring sunshine"
00077 
00078  How it Works
00079 
00080    The class.ss library cooperates with primitive classes through a
00081    `make-primitive-class' function. The glue code in this file
00082    essentially builds up the necessary arguments to
00083    `make-primitive-class', and tree-finish.ss actually makes the
00084    call. In fact, tree.cxx knows nothing about the class
00085    implementation, and the class implementation knows nothing about
00086    the glue; they "just happen" to be compatible, but this glue could
00087    work with a variety of class implementation.
00088 
00089    The glue, furthermore, is split into two parts. The first part is
00090    specific to the Tree class. The second part is more generic,
00091    providing a fairly simple objscheme_ interface to class-specific
00092    glue, such the Tree glue. The second part can be shared for any
00093    number of C++ classes, and it is similar to code used by MrEd.
00094 */
00095 
00096 #include "escheme.h"
00097 
00098 /**********************************************************/
00099 /* The original C++ class: Tree                           */
00100 /**********************************************************/
00101 
00102 /* This kind of tree never grows or loses leaves. It only changes when
00103    it grows subtrees, or when subtrees are grafted onto it. We can
00104    derive new classes (in Scheme) for trees that can grow leaves and
00105    fruit. */
00106 
00107 class Tree {
00108 private:
00109 
00110   int refcount; /* Suppose the C++ class uses reference counting. */
00111 
00112 public:
00113 
00114   /* Public fields: */
00115   Tree *left_branch, *right_branch;
00116   int leaves;
00117 
00118   void *user_data; /* Field that we use for pointing back to the
00119                     Scheme view of the objects. The original class
00120                     might not be this friendly, but for simplicity
00121                     we assume that it is. The alternative is to use
00122                     a hash table. */
00123 
00124   Tree(int init_leaves) {
00125     left_branch = right_branch = NULL;
00126     leaves = init_leaves;
00127     refcount = 1;
00128     user_data = NULL;
00129   }
00130 
00131   /* The Grow method is overloaded... */
00132 
00133   virtual void Grow(int n) {
00134     if (left_branch)
00135       left_branch->Grow(n);
00136     else
00137       left_branch = new Tree(n);
00138     if (right_branch)
00139       right_branch->Grow(n);
00140     else
00141       right_branch = new Tree(n);
00142   }
00143 
00144   virtual void Grow(char *command, char *&result) {
00145     if (!strcmp(command, "sunshine")) {
00146       if (left_branch)
00147        left_branch->Grow(command, result);
00148       else {
00149        left_branch = new Tree(1);
00150        result = "sprouted left";
00151       }
00152     } else if (!strcmp(command, "water")) {
00153       if (right_branch)
00154        right_branch->Grow(command, result);
00155       else {
00156        right_branch = new Tree(1);
00157        result = "sprouted left";
00158       }
00159     } else {
00160       result = "unrecognized command for growing";
00161     }
00162   }
00163 
00164   void Graft(Tree *left, Tree *right) {
00165     Drop(left_branch);
00166     Drop(right_branch);
00167 
00168     left_branch = left;
00169     right_branch = right;
00170 
00171     Add(left_branch);
00172     Add(right_branch);
00173   }
00174 
00175   /* Note that Graft is not overrideable in C++.
00176      In Scheme, we might override this method, but
00177      the C++ code never has to know since it never
00178      calls the Graft method itself. */
00179 
00180   /* Reference counting utils: */
00181 
00182   static void Add(Tree *t) {
00183     if (t)
00184       t->refcount++;
00185   }
00186   static void Drop(Tree *t) {
00187     if (t) {
00188       t->refcount--;
00189       if (!t->refcount)
00190        delete t;
00191     }
00192   }
00193 };
00194 
00195 /**********************************************************/
00196 /* The glue class: mzTree (C++ calls to Scheme)           */
00197 /**********************************************************/
00198 
00199 /* Forward declarations (documented further below) */
00200 void objscheme_init();
00201 void objscheme_add_procedures(Scheme_Env *);
00202 Scheme_Object *objscheme_make_class(const char *name, Scheme_Object *sup, 
00203                                 Scheme_Prim *initf, int num_methods);
00204 Scheme_Object *objscheme_add_method_w_arity(Scheme_Object *c, const char *name, 
00205                                        Scheme_Prim *f, int mina, int maxa);
00206 Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass);
00207 Scheme_Object *objscheme_find_method(Scheme_Object *obj, char *name, void **cache);
00208 int objscheme_is_a(Scheme_Object *o, Scheme_Object *c);
00209 
00210 
00211 /* The #<primitive-class> value: */
00212 static Scheme_Object *tree_class;
00213 /* Cache for lookup of overrideable method: */
00214 static void *grow_method_cache= NULL;
00215 /* To recognize original overrideable method: */
00216 Scheme_Object *grow_prim;
00217 
00218 /* We keep a pointer to the Scheme object, and override the
00219    Grow method to (potentially) dispatch to Scheme. */
00220 
00221 class mzTree : public Tree {
00222 public:
00223   mzTree(int c) : Tree(c) { }
00224 
00225   virtual void Grow(int n) {
00226     /* Check whether the Scheme class for user_data is 
00227        actually a derived class that overrides `grow': */
00228     Scheme_Object *scmobj;
00229     Scheme_Object *overriding;
00230 
00231     /* Pointer to Scheme instance kept in user_data: */
00232     scmobj = (Scheme_Object *)user_data;
00233 
00234     /* Look for an overriding `grow' method in scmobj: */
00235     overriding = objscheme_find_method(scmobj,
00236                                    "grow",
00237                                    &grow_method_cache);
00238 
00239     if (overriding != grow_prim) {
00240       /* Call Scheme-based overriding implementation: */
00241       Scheme_Object *argv[2];
00242 
00243       argv[0] = scmobj;
00244       argv[1] = scheme_make_integer(n);
00245       _scheme_apply(overriding, 2, argv);
00246     } else {
00247       /* Grow is not overridden in Scheme: */
00248       Tree::Grow(n);
00249     }
00250   }
00251 
00252   /* Same strategy for other form of Grow, but we have to
00253      deal with the "result" parameter: */
00254   virtual void Grow(char *cmd, char *&result) {
00255     Scheme_Object *scmobj;
00256     Scheme_Object *overriding;
00257 
00258     scmobj = (Scheme_Object *)user_data;
00259 
00260     /* Look for an overriding `grow' method in scmobj: */
00261     overriding = objscheme_find_method(scmobj,
00262                                    "grow",
00263                                    &grow_method_cache);
00264 
00265     if (overriding != grow_prim) {
00266       /* When calling the Scheme-based overriding implementation,
00267         we implement the `result' parameter as a boxed string.
00268         The Scheme code mutates the box content to return a 
00269         result. */
00270       Scheme_Object *argv[2], *res;
00271 
00272       argv[0] = scmobj;
00273       argv[1] = scheme_make_utf8_string(cmd);
00274       argv[2] = scheme_box(scheme_make_utf8_string(""));
00275 
00276       _scheme_apply(overriding, 3, argv);
00277 
00278       res = scheme_unbox(argv[2]);
00279       if (!SCHEME_CHAR_STRINGP(res)) {
00280        scheme_wrong_type("result for tree%'s grow method",
00281                        "string", -1, 0, &res);
00282       } else
00283        result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[2]), -1, NULL, 0);
00284     } else {
00285       Tree::Grow(cmd, result);
00286     }
00287   }
00288 };
00289 
00290 /**********************************************************/
00291 /* The glue functions (Scheme calls to C++)               */
00292 /**********************************************************/
00293 
00294 /* Macro for accessing C++ object pointer from a Scheme object: */
00295 #define OBJSCHEME_GET_CPP_OBJ(obj) scheme_struct_ref(obj, 0)
00296 #define OBJSCHEME_SET_CPP_OBJ(obj, v) scheme_struct_set(obj, 0, v)
00297 
00298 /* Used for finalizing: */
00299 void FreeTree(void *scmobj, void *t)
00300 {
00301   Tree::Drop((Tree *)t);
00302 }
00303 
00304 Scheme_Object *Make_Tree(int argc, Scheme_Object **argv)
00305 {
00306   Scheme_Object *obj;
00307 
00308   /* Unfortunately, init arity is not automatically checked: */
00309   if (argc != 2)
00310     scheme_wrong_count("tree% initialization", 2, 2, argc, argv);
00311 
00312   /* Assuming the initializer is only called through
00313      the class interface, argv[0] is always ok: */
00314   obj = argv[0];
00315 
00316   if (!SCHEME_INTP(argv[1]))
00317     scheme_wrong_type("tree% initialization", 
00318                     "fixnum", 
00319                     1, argc, argv);
00320 
00321   /* Create C++ instance, and remember pointer back to Scheme instance: */
00322   Tree *t = new mzTree(SCHEME_INT_VAL(argv[1]));
00323   t->user_data = obj;
00324 
00325   /* Store C++ pointer in Scheme object: */
00326   OBJSCHEME_SET_CPP_OBJ(obj, (Scheme_Object *)t);
00327 
00328   /* Free C++ instance when the Scheme object is no longer referenced: */
00329   scheme_add_finalizer(obj, FreeTree, t);
00330 
00331   return obj;
00332 }
00333 
00334 Scheme_Object *Grow(int argc, Scheme_Object **argv)
00335 {
00336   Scheme_Object *obj = argv[0];
00337 
00338   if (argc == 2) {
00339     Tree *t;
00340     int n;
00341 
00342     if (!SCHEME_INTP(argv[1]))
00343       scheme_wrong_type("tree%'s grow", 
00344                      "fixnum", 
00345                      1, argc, argv);
00346     n = SCHEME_INT_VAL(argv[1]);
00347     
00348     /* Extract the C++ pointer: */
00349     t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
00350     
00351     /* Call method (without override check): */
00352     t->Tree::Grow(n);
00353   } else {
00354     Tree *t;
00355     char *cmd, *result;
00356 
00357     if (!SCHEME_CHAR_STRINGP(argv[1]))
00358       scheme_wrong_type("tree%'s grow", 
00359                      "string", 
00360                      1, argc, argv);
00361     if (!SCHEME_BOXP(argv[2])
00362        || !SCHEME_CHAR_STRINGP(SCHEME_BOX_VAL(argv[2])))
00363       scheme_wrong_type("tree%'s grow", 
00364                      "boxed string", 
00365                      2, argc, argv);
00366 
00367     cmd = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[1]), -1, NULL, 0);
00368     result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(SCHEME_BOX_VAL(argv[2])), 1, NULL, 0);
00369 
00370     /* Extract the C++ pointer: */
00371     t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
00372     
00373     /* Call method (without override check): */
00374     t->Tree::Grow(cmd, result);
00375 
00376     /* Put result back in box: */
00377     SCHEME_BOX_VAL(argv[2]) = scheme_make_utf8_string(result);
00378   }
00379   
00380   return scheme_void;
00381 }
00382 
00383 Scheme_Object *Graft(int argc, Scheme_Object **argv)
00384 {
00385   Scheme_Object *obj = argv[0];
00386   Tree *t, *l, *r;
00387 
00388   if (!SCHEME_FALSEP(argv[1]) && !objscheme_is_a(argv[1], tree_class))
00389     scheme_wrong_type("tree%'s graft", 
00390                     "tree% object or #f", 
00391                     1, argc, argv);
00392   if (!SCHEME_FALSEP(argv[2]) && !objscheme_is_a(argv[2], tree_class))
00393     scheme_wrong_type("tree%'s graft", 
00394                     "tree% object or #f", 
00395                     2, argc, argv);
00396 
00397   /* Extract the C++ pointer for `this': */
00398   t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
00399 
00400   /* Extract the C++ pointers for the args: */
00401   l = (SCHEME_FALSEP(argv[1])
00402        ? (Tree *)NULL
00403        : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[1]));
00404   r = (SCHEME_FALSEP(argv[2])
00405        ? (Tree *)NULL
00406        : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[2]));
00407   
00408   /* Call method: */
00409   t->Graft(l, r);
00410   
00411   return scheme_void;
00412 }
00413 
00414 Scheme_Object *MarshalTree(Tree *t)
00415 {
00416   if (!t)
00417     return scheme_false;
00418   else if (!t->user_data) {
00419     /* Object created in C++, not seen by Scheme, yet.
00420        Create a Scheme version of this object. */
00421     Scheme_Object *scmobj;
00422 
00423     /* Make Scheme object: */
00424     scmobj = objscheme_make_uninited_object(tree_class);
00425 
00426     /* Link C++ and Scheme objects: */
00427     t->user_data = scmobj;
00428     OBJSCHEME_SET_CPP_OBJ(scmobj, (Scheme_Object *)t);
00429     
00430     return scmobj;
00431   } else
00432     /* Get pointer back to Scheme: */
00433     return (Scheme_Object *)t->user_data;
00434 }
00435 
00436 Scheme_Object *Get_Left(int argc, Scheme_Object **argv)
00437 {
00438   Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
00439   
00440   return MarshalTree(t->left_branch);
00441 }
00442 
00443 Scheme_Object *Get_Right(int argc, Scheme_Object **argv)
00444 { 
00445   Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
00446  
00447   return MarshalTree(t->right_branch);
00448 }
00449 
00450 Scheme_Object *Get_Leaves(int argc, Scheme_Object **argv)
00451 {
00452   Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
00453  
00454   return scheme_make_integer(t->leaves);
00455 }
00456 
00457 /**********************************************************/
00458 /* Extension initialization: create the Scheme class      */
00459 /**********************************************************/
00460 
00461 Scheme_Object *scheme_reload(Scheme_Env *env)
00462 {
00463   scheme_add_global("tree-primitive-class", tree_class, env);
00464 
00465   objscheme_add_procedures(env);
00466 
00467   return scheme_void;
00468 }
00469 
00470 Scheme_Object *scheme_initialize(Scheme_Env *env)
00471 {
00472   objscheme_init();
00473 
00474   scheme_register_extension_global(&tree_class, sizeof(tree_class));
00475 
00476   tree_class = objscheme_make_class("tree%",    /* name */
00477                                 NULL,       /* superclass */
00478                                 Make_Tree,  /* init func */
00479                                 5);         /* num methods */
00480 
00481   scheme_register_extension_global(&grow_prim, sizeof(grow_prim));
00482 
00483   grow_prim = objscheme_add_method_w_arity(tree_class, "grow",
00484                                       Grow, 1, 2);
00485   (void)objscheme_add_method_w_arity(tree_class, "graft", 
00486                                  Graft, 2, 2);
00487   
00488   (void)objscheme_add_method_w_arity(tree_class, "get-left",
00489                                  Get_Left, 0, 0);
00490   (void)objscheme_add_method_w_arity(tree_class, "get-right",
00491                                  Get_Right, 0, 0);
00492   (void)objscheme_add_method_w_arity(tree_class, "get-leaves",
00493                                  Get_Leaves, 0, 0);
00494 
00495   return scheme_reload(env);
00496 }
00497 
00498 
00499 Scheme_Object *scheme_module_name()
00500 {
00501   /* This extension doesn't define a module: */
00502   return scheme_false;
00503 }
00504 
00505 /**********************************************************/
00506 /* The generic (class-independent) C++--Scheme glue       */
00507 /**********************************************************/
00508 
00509 /* 
00510    (This code is mostly the same as code used by MrEd, and duplicating
00511    it is certainly a bad idea in principle, but putting the code in a
00512    shareable place seems like more work than is worthwhile for now.)
00513 
00514    Scheme side:
00515    ------------
00516 
00517    This glue provides a new type, #<primitive-class>, and several
00518    procedures:
00519 
00520       (initialize-primitive-object prim-obj v ...) -
00521         initializes the primitive object, given initialization
00522         arguments v ...
00523 
00524       (primitive-class-prepare-struct-type! prim-class gen-property
00525         gen-value preparer dispatcher) - prepares a class's struct-type for
00526         objects generated C-side; returns a constructor, predicate,
00527         and a struct:type for derived classes. The constructor and
00528         struct:type map the given dispatcher to the class.
00529 
00530         The preparer takes a symbol naming the method. It returns a
00531         value to be used in future calls to the dispatcher.
00532 
00533         The dispatcher takes two arguments: an object and a
00534         method-specific value produced by the prepaper. It returns a
00535         method procedure.
00536 
00537       (primitive-class-find-method prim-class sym) - gets the method
00538         procedure for the given symbol from the class. The procedure
00539         consumes "self" and then the rest of the arguments.
00540 
00541    C side:
00542    -------
00543 
00544      void objscheme_init() - initializes the glue; call this first.
00545 
00546      void objscheme_add_procedures(Scheme_Env *) - installs the
00547         Scheme-side procedure listed above into the environment.
00548 
00549      Scheme_Object *objscheme_make_class(const char *name,
00550         Scheme_Object *sup, Scheme_Prim *initf, int num_methods) -
00551         creates a #<primitive-class> representing a C++ class. The
00552         initf function is called to create and initialize the C++-side
00553         when the class is instantiated from Scheme; the first argument
00554         is the Scheme-side `self' object. The Scheme-side object is a
00555         struct, and the first field should be set to point to the C++
00556         object.
00557 
00558         The sup argument is a #<primitive-class> for a superclass, or
00559         scheme_false. The num_methods argument specifies the number of
00560         methods that will be added to the class.
00561 
00562      void objscheme_add_method_w_arity(Scheme_Object *c, const char
00563        *name, Scheme_Prim *f, int mina, int maxa) - adds a method to
00564        a #<primitive-class>, specifying the method's arity as with
00565        scheme_make_prim_w_arity().
00566 
00567      Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass)
00568         - creates a Scheme-side object for an existing C++ obj. The
00569         Scheme-side object is a struct, and the first field should be
00570         set to point to the C++ object.
00571 
00572      Scheme_Object *objscheme_find_method(Scheme_Object *obj, char
00573         *name, void **cache) - finds a method by name in a Scheme-side
00574         object. It is a Scheme procedure for the method (which takes
00575         the Scheme-side `self' as its first argument). The cache
00576         pointer should point to static, class-specific space for
00577         caching lookup information.
00578 
00579      int objscheme_is_a(Scheme_Object *o, Scheme_Object *c) - returns 1
00580         if the given Scheme-side object is an instance of the given
00581         #<primitive-class>, 0 otherwise.
00582 
00583 */
00584 
00585 typedef struct Objscheme_Class {
00586   Scheme_Type type;
00587   const char *name;
00588   Scheme_Object *sup;
00589   Scheme_Object *initf;
00590   int num_methods, num_installed;
00591   Scheme_Object **names;
00592   Scheme_Object **methods;
00593   Scheme_Object *base_struct_type;
00594   Scheme_Object *struct_type;
00595 } Objscheme_Class;
00596 
00597 Scheme_Type objscheme_class_type;
00598 
00599 static Scheme_Object *object_struct;
00600 static Scheme_Object *object_property;
00601 static Scheme_Object *preparer_property;
00602 static Scheme_Object *dispatcher_property;
00603 
00604 #define CONS(a, b) scheme_make_pair(a, b)
00605 
00606 /***************************************************************************/
00607 /* Scheme-side implementation: */
00608 
00609 static Scheme_Object *init_prim_obj(int argc, Scheme_Object **argv)
00610 {
00611   Objscheme_Class *c;
00612   Scheme_Object *obj = argv[0];
00613 
00614   if (!SCHEME_STRUCTP(argv[0])
00615       || !scheme_is_struct_instance(object_struct, argv[0]))
00616     scheme_wrong_type("initialize-primitive-object", "primitive-object", 0, argc, argv);
00617   
00618   c = (Objscheme_Class *)scheme_struct_type_property_ref(object_property, obj);
00619 
00620   return _scheme_apply(c->initf, argc, argv);
00621 }
00622 
00623 static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
00624 {
00625   Scheme_Object *name, *base_stype, *stype, *derive_stype;
00626   Scheme_Object **names, **vals, *a[3], *props;
00627   Objscheme_Class *c;
00628   int flags, count;
00629 
00630   if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
00631     scheme_wrong_type("primitive-class-prepare-struct-type!", "primitive-class", 0, argc, argv);
00632   if (SCHEME_TYPE(argv[1]) != scheme_struct_property_type)
00633     scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
00634   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
00635   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
00636 
00637   c = ((Objscheme_Class *)argv[0]);
00638   
00639   stype = c->struct_type;
00640 
00641   name = scheme_intern_symbol(c->name);
00642 
00643   if (stype) {
00644     scheme_arg_mismatch("primitive-class-prepare-struct-type!",
00645                      "struct-type already prepared for primitive-class: ",
00646                      name);
00647     return NULL;
00648   }
00649 
00650   if (SCHEME_TRUEP(c->sup) && !((Objscheme_Class *)c->sup)->base_struct_type) {
00651     scheme_arg_mismatch("primitive-class-prepare-struct-type!",
00652                      "super struct-type not yet prepared for primitive-class: ",
00653                      name);
00654     return NULL;
00655   }
00656 
00657   /* Root for this class.  */
00658 
00659   base_stype = scheme_make_struct_type(name, 
00660                                    (SCHEME_TRUEP(c->sup) 
00661                                    ? ((Objscheme_Class *)c->sup)->base_struct_type 
00662                                    : object_struct),
00663                                    NULL,
00664                                    0, 0, NULL,
00665                                    NULL, NULL);
00666   c->base_struct_type = base_stype;
00667 
00668   /* Type to use when instantiating from C: */
00669 
00670   props = CONS(CONS(object_property, 
00671                   argv[0]),
00672               scheme_null);
00673 
00674   stype = scheme_make_struct_type(name,
00675                               base_stype, 
00676                               NULL,
00677                               0, 0, NULL,
00678                               CONS(CONS(argv[1], argv[2]),
00679                                    props),
00680                               NULL);
00681   
00682   c->struct_type = stype;
00683   
00684   /* Type to derive from Scheme: */
00685   
00686   props = CONS(CONS(preparer_property, argv[3]),
00687               CONS(CONS(dispatcher_property, argv[4]),
00688                   props));
00689 
00690   derive_stype = scheme_make_struct_type(name,
00691                                     base_stype, 
00692                                     NULL,
00693                                     0, 0, NULL,
00694                                     props, 
00695                                     NULL);
00696   
00697   /* Type to instantiate from Scheme: */
00698   
00699   stype = scheme_make_struct_type(name,
00700                               base_stype, 
00701                               NULL,
00702                               0, 0, NULL,
00703                               CONS(CONS(argv[1], argv[2]), props),
00704                               NULL);
00705   
00706   /* Need constructor from instantiate type: */
00707   flags = (SCHEME_STRUCT_NO_TYPE
00708           | SCHEME_STRUCT_NO_PRED
00709           | SCHEME_STRUCT_NO_GET
00710           | SCHEME_STRUCT_NO_SET);
00711   names = scheme_make_struct_names(name, NULL, flags, &count);
00712   vals = scheme_make_struct_values(stype, names, count, flags);
00713   a[0] = vals[0];
00714 
00715   /* Need predicate from base type: */
00716   flags = (SCHEME_STRUCT_NO_TYPE
00717           | SCHEME_STRUCT_NO_CONSTR
00718           | SCHEME_STRUCT_NO_GET
00719           | SCHEME_STRUCT_NO_SET);
00720   names = scheme_make_struct_names(name, NULL, flags, &count);
00721   vals = scheme_make_struct_values(base_stype, names, count, flags);
00722   a[1] = vals[0];
00723 
00724   /* Need derive type: */
00725   a[2] = derive_stype;
00726 
00727   return scheme_values(3, a);
00728 }
00729 
00730 static Scheme_Object *class_find_meth(int argc, Scheme_Object **argv)
00731 {
00732   Objscheme_Class *sclass = (Objscheme_Class *)argv[0];
00733   Scheme_Object *s;
00734   int i;
00735 
00736   if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
00737     scheme_wrong_type("primitive-class-find-method", "primitive-class", 0, argc, argv);
00738   if (!SCHEME_SYMBOLP(argv[1]))
00739     scheme_wrong_type("primitive-class-find-method", "symbol", 1, argc, argv);
00740 
00741   s = argv[1];
00742 
00743   for (i = sclass->num_installed; i--; ) {
00744     if (SAME_OBJ(sclass->names[i], s))
00745       return sclass->methods[i];
00746   }
00747 
00748   return scheme_false;
00749 }
00750 
00751 Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass)
00752 {
00753   Scheme_Object *obj;
00754   Scheme_Object *stype;
00755 
00756   stype = ((Objscheme_Class *)sclass)->struct_type;
00757   if (!stype) {
00758     scheme_arg_mismatch("make-primitive-object",
00759                      "struct-type not yet prepared: ",
00760                      sclass);
00761     return NULL;
00762   }
00763 
00764   obj = scheme_make_struct_instance(stype, 0, NULL);
00765 
00766   return obj;  
00767 }
00768 
00769 /***************************************************************************/
00770 /* C-side implementation: */
00771 
00772 Scheme_Object *objscheme_make_class(const char *name, Scheme_Object *sup, 
00773                                 Scheme_Prim *initf, int num_methods)
00774 {
00775   Objscheme_Class *sclass;
00776   Scheme_Object *f, **methods, **names;
00777 
00778   sclass = (Objscheme_Class *)scheme_malloc_tagged(sizeof(Objscheme_Class));
00779   sclass->type = objscheme_class_type;
00780 
00781   if (!sup)
00782     sup = scheme_false;
00783 
00784   sclass->name = name;
00785   sclass->sup = sup;
00786 
00787   f = scheme_make_prim(initf);
00788   sclass->initf = f;
00789 
00790   sclass->num_methods = num_methods;
00791   sclass->num_installed = 0;
00792 
00793   methods = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
00794   names = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
00795 
00796   sclass->methods = methods;
00797   sclass->names = names;
00798 
00799   return (Scheme_Object *)sclass;
00800 }
00801 
00802 Scheme_Object *objscheme_add_method_w_arity(Scheme_Object *c, const char *name,
00803                                        Scheme_Prim *f, int mina, int maxa)
00804 {
00805   Scheme_Object *s;
00806   Objscheme_Class *sclass;
00807 
00808   sclass = (Objscheme_Class *)c;
00809 
00810   s = scheme_make_prim_w_arity(f, name, mina + 1, (maxa < 0) ? -1 : (maxa + 1));
00811 
00812   sclass->methods[sclass->num_installed] = s;
00813 
00814   s = scheme_intern_symbol(name);
00815 
00816   sclass->names[sclass->num_installed] = s;
00817 
00818   sclass->num_installed++;
00819 
00820   return s;
00821 }
00822 
00823 int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
00824 {
00825   Scheme_Object *a;
00826 
00827   if (!SCHEME_STRUCTP(o) || !scheme_is_struct_instance(object_struct, o))
00828     return 0;
00829 
00830   a = scheme_struct_type_property_ref(object_property, o);
00831   
00832   while (a && (a != c)) {
00833     a = ((Objscheme_Class *)a)->sup;
00834   }
00835 
00836   return !!a;
00837 }
00838 
00839 void objscheme_init()
00840 {
00841   objscheme_class_type = scheme_make_type("<primitive-class>");
00842 
00843   /* Attaches a primitive class to an object: */
00844   scheme_register_extension_global(&object_property, sizeof(object_property));
00845   object_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-object"));
00846   
00847   /* Attaches a preparer function to a derived class: */
00848   scheme_register_extension_global(&preparer_property, sizeof(preparer_property));
00849   preparer_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-preparer"));
00850 
00851   /* Attaches a dispatcher function to a derived class: */
00852   scheme_register_extension_global(&dispatcher_property, sizeof(dispatcher_property));
00853   dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
00854 
00855   /* The base struct type for the Scheme view of a primitive object: */
00856   scheme_register_extension_global(&object_struct, sizeof(object_struct));
00857   object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
00858                                      NULL, NULL,
00859                                      0, 2, NULL,
00860                                      NULL, NULL);
00861 }
00862 
00863 void objscheme_add_procedures(Scheme_Env *env)
00864 {
00865   scheme_add_global("initialize-primitive-object",
00866                   scheme_make_prim_w_arity(init_prim_obj,
00867                                         "initialize-primitive-object",
00868                                         1, -1),
00869                   env);
00870 
00871   scheme_add_global("primitive-class-prepare-struct-type!",
00872                   scheme_make_prim_w_arity(class_prepare_struct_type,
00873                                         "primitive-class-prepare-struct-type!",
00874                                         5, 5),
00875                   env);
00876   
00877   scheme_add_global("primitive-class-find-method",
00878                   scheme_make_prim_w_arity(class_find_meth,
00879                                         "primitive-class-find-method",
00880                                         2, 2),
00881                   env);
00882 }
00883 
00884 Scheme_Object *objscheme_find_method(Scheme_Object *obj, char *name, void **cache)
00885 {
00886   Scheme_Object *s, *p[2], *dispatcher;
00887 
00888   if (!obj)
00889     return NULL;
00890 
00891   dispatcher = scheme_struct_type_property_ref(dispatcher_property, (Scheme_Object *)obj);
00892   if (!dispatcher)
00893     return NULL;
00894 
00895   if (*cache)
00896     s = (Scheme_Object *)*cache;
00897   else {
00898     s = scheme_intern_symbol(name);
00899     p[0] = s;
00900     s = scheme_struct_type_property_ref(preparer_property, (Scheme_Object *)obj);
00901     if (!s)
00902       return NULL;
00903     s = scheme_apply(s, 1, p);
00904     scheme_register_extension_global((void *)cache, sizeof(Scheme_Object*));
00905     *cache = s;
00906   }
00907 
00908   p[0] = obj;
00909   p[1] = s;
00910   return _scheme_apply(dispatcher, 2, p);
00911 }