Back to index

plt-scheme  4.2.1
xcglue.c
Go to the documentation of this file.
00001 #include "xcglue.h"
00002 #include "gc.h"
00003 
00004 /* Set to 1 for experiments needing an extra field: */
00005 #define EXTRA_PRIM_OBJECT_FIELD 0
00006 
00007 /* 
00008    Glue for the C<->Scheme object interface.
00009 
00010    Scheme side:
00011    ------------
00012 
00013    This glue provides a new type, #<primitive-class>, and several
00014    procedures:
00015 
00016       (initialize-primitive-object prim-obj v ...) -
00017         initializes the primitive object, given initialization
00018         arguments v...
00019 
00020       (primitive-class-prepare-struct-type! prim-class gen-property
00021         gen-value preparer dispatcher extra-props) - prepares a class's 
00022         struct-type for objects generated C-side; returns a constructor, 
00023         predicate, and a struct:type for derived classes. The constructor and
00024         struct:type map the given dispatcher to the class.
00025 
00026         The preparer takes a symbol naming the method. It returns a
00027         value to be used in future calls to the dispatcher.
00028 
00029         The dispatcher takes two arguments: an object and a
00030         method-specific value produced by the prepaper. It returns a
00031         method procedure.
00032 
00033         The extra-props argument is a list of property--value pairs.
00034 
00035       (primitive-class-find-method prim-class sym) - gets the method
00036         for the given symbol.
00037 
00038       (primitive-class->superclass prim-class) - gets the superclass.
00039 
00040       (primitive-class? v) - returns #t if v is a primitive class.
00041 
00042    In addition, the C code generates definitions of classes.
00043 
00044 
00045    If EXTRA_PRIM_OBJECT_FIELD:
00046 
00047       (primitive-object-extra-field-get prim-obj) - obvious
00048       (primitive-object-extra-field-set! prim-obj v) - obvious
00049       
00050 
00051    C side:
00052    -------
00053 
00054    The C interface is mostly for the output of xctocc. In addition,
00055    there is
00056 
00057      void objscheme_init(Scheme_Env *);
00058 
00059    The argument doesn't really have to be a Scheme_Env* value; see
00060    below.
00061 
00062    The embedding C program must provide
00063 
00064      void scheme_install_xc_global(const char *name,
00065                                    Scheme_Object *v, 
00066                                    Scheme_Env *env);
00067      void scheme_lookup_xc_global(const char *name,
00068                                   Scheme_Env *env);
00069 
00070    The Scheme_Env* value doesn't actually have to be an Scheme
00071    environment; it is the value the embedding code provides to
00072    the objscheme_setup_XXX() functions generated by xctocc, and to
00073    objscheme_init().
00074 
00075 */
00076 
00077 /***************************************************************************/
00078 
00079 int objscheme_something_prepared = 0;
00080 
00081 typedef struct Scheme_Class {
00082   Scheme_Object so;
00083   const char *name;
00084   Scheme_Object *sup;
00085   Scheme_Object *initf;
00086   int num_methods, num_installed;
00087   Scheme_Object **names;
00088   Scheme_Object **methods;
00089   Scheme_Object *base_struct_type;
00090   Scheme_Object *struct_type;
00091 } Scheme_Class;
00092 
00093 Scheme_Type objscheme_class_type;
00094 
00095 static Scheme_Object *object_struct;
00096 static Scheme_Object *object_property;
00097 static Scheme_Object *dispatcher_property;
00098 static Scheme_Object *preparer_property;
00099 
00100 #ifdef MZ_PRECISE_GC
00101 # include "../gc2/gc2.h"
00102 
00103 START_XFORM_SKIP;
00104 
00105 int gc_class_size(void *_c)
00106 {
00107   return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
00108 }
00109 
00110 int gc_class_mark(void *_c)
00111 {
00112   Scheme_Class *c = (Scheme_Class *)_c;
00113 
00114   gcMARK(c->name);
00115   gcMARK(c->sup);
00116   gcMARK(c->initf);
00117   gcMARK(c->names);
00118   gcMARK(c->methods);
00119   gcMARK(c->base_struct_type);
00120   gcMARK(c->struct_type);
00121   
00122   return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
00123 }
00124 
00125 int gc_class_fixup(void *_c)
00126 {
00127   Scheme_Class *c = (Scheme_Class *)_c;
00128 
00129   gcFIXUP(c->name);
00130   gcFIXUP(c->sup);
00131   gcFIXUP(c->initf);
00132   gcFIXUP(c->names);
00133   gcFIXUP(c->methods);
00134   gcFIXUP(c->base_struct_type);
00135   gcFIXUP(c->struct_type);
00136   
00137   return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
00138 }
00139 
00140 END_XFORM_SKIP;
00141 
00142 #endif
00143 
00144 /***************************************************************************/
00145 
00146 static Scheme_Object *init_prim_obj(int argc, Scheme_Object **argv)
00147 {
00148   Scheme_Class *c;
00149   Scheme_Object *obj = argv[0];
00150 
00151   if (!SCHEME_STRUCTP(argv[0])
00152       || !scheme_is_struct_instance(object_struct, argv[0]))
00153     scheme_wrong_type("initialize-primitive-object", "primitive-object", 0, argc, argv);
00154   
00155   c = (Scheme_Class *)scheme_struct_type_property_ref(object_property, obj);
00156 
00157   return _scheme_apply(c->initf, argc, argv);
00158 }
00159 
00160 static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
00161 {
00162   Scheme_Object *name, *base_stype, *stype;
00163   Scheme_Object **names, **vals, *a[3], *props;
00164   Scheme_Class *c;
00165   int flags, count;
00166 
00167   if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
00168     scheme_wrong_type("primitive-class-prepare-struct-type!", "primitive-class", 0, argc, argv);
00169   if (SCHEME_TYPE(argv[1]) != scheme_struct_property_type)
00170     scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
00171   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
00172   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
00173 
00174   props = argv[5];
00175   while (SCHEME_PAIRP(props)) {
00176     name = SCHEME_CAR(props);
00177     if (!SCHEME_PAIRP(name))
00178       break;
00179     if (SCHEME_TYPE(SCHEME_CAR(name)) != scheme_struct_property_type)
00180       break;
00181     props = SCHEME_CDR(props);
00182   }
00183   if (!SCHEME_NULLP(props))
00184     scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 5, argc, argv);
00185   props = argv[5];
00186 
00187   objscheme_something_prepared = 1;
00188 
00189   c = ((Scheme_Class *)argv[0]);
00190   
00191   stype = c->struct_type;
00192 
00193   name = scheme_intern_symbol(c->name);
00194 
00195   if (stype) {
00196     scheme_arg_mismatch("primitive-class-prepare-struct-type!",
00197                      "struct-type already prepared for primitive-class: ",
00198                      name);
00199     return NULL;
00200   }
00201 
00202   if (c->sup && !((Scheme_Class *)c->sup)->base_struct_type) {
00203     scheme_arg_mismatch("primitive-class-prepare-struct-type!",
00204                      "super struct-type not yet prepared for primitive-class: ",
00205                      name);
00206     return NULL;
00207   }
00208 
00209   /* Root for this class.  */
00210 
00211   base_stype = scheme_make_struct_type(name, 
00212                                    (c->sup ? ((Scheme_Class *)c->sup)->base_struct_type : object_struct),
00213                                    NULL,
00214                                    0, 0, NULL,
00215                                        props, NULL);
00216   c->base_struct_type = base_stype;
00217 
00218   /* Type to use when instantiating from C: */
00219 
00220   props = scheme_make_pair(scheme_make_pair(object_property, 
00221                                        argv[0]),
00222                         scheme_null);
00223 
00224   stype = scheme_make_struct_type(name,
00225                               base_stype, 
00226                               NULL,
00227                               0, 0, NULL,
00228                               scheme_make_pair(scheme_make_pair(argv[1], argv[2]),
00229                                              props),
00230                               NULL);
00231   
00232   c->struct_type = stype;
00233   
00234   /* Type to derive/instantiate from Scheme: */
00235 
00236   props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]),
00237                         scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]),
00238                                        props));
00239   
00240   stype = scheme_make_struct_type(name,
00241                               base_stype, 
00242                               NULL,
00243                               0, 0, NULL,
00244                               scheme_make_pair(scheme_make_pair(argv[1], argv[2]), props),
00245                               NULL);
00246   
00247   /* Need constructor from instantiate type: */
00248   flags = (SCHEME_STRUCT_NO_TYPE
00249           | SCHEME_STRUCT_NO_PRED
00250           | SCHEME_STRUCT_NO_GET
00251           | SCHEME_STRUCT_NO_SET);
00252   names = scheme_make_struct_names(name, NULL, flags, &count);
00253   vals = scheme_make_struct_values(stype, names, count, flags);
00254   a[0] = vals[0];
00255 
00256   /* Need predicate from base type: */
00257   flags = (SCHEME_STRUCT_NO_TYPE
00258           | SCHEME_STRUCT_NO_CONSTR
00259           | SCHEME_STRUCT_NO_GET
00260           | SCHEME_STRUCT_NO_SET);
00261   names = scheme_make_struct_names(name, NULL, flags, &count);
00262   vals = scheme_make_struct_values(base_stype, names, count, flags);
00263   a[1] = vals[0];
00264 
00265   /* Derive type == instantiate type: */
00266   a[2] = stype;
00267 
00268   return scheme_values(3, a);
00269 }
00270 
00271 static Scheme_Object *class_sup(int argc, Scheme_Object **argv)
00272 {
00273   Scheme_Object *v;
00274 
00275   if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
00276     scheme_wrong_type("primitive-class->superclass", "primitive-class", 0, argc, argv);
00277 
00278   v = ((Scheme_Class *)argv[0])->sup;
00279   return v ? v : scheme_false;
00280 }
00281 
00282 static Scheme_Object *class_find_meth(int argc, Scheme_Object **argv)
00283 {
00284   Scheme_Class *sclass = (Scheme_Class *)argv[0];
00285   Scheme_Object *s;
00286   int i;
00287 
00288   if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
00289     scheme_wrong_type("primitive-class-find-method", "primitive-class", 0, argc, argv);
00290   if (!SCHEME_SYMBOLP(argv[1]))
00291     scheme_wrong_type("primitive-class-find-method", "symbol", 1, argc, argv);
00292 
00293   s = argv[1];
00294 
00295   for (i = sclass->num_installed; i--; ) {
00296     if (SAME_OBJ(sclass->names[i], s))
00297       return sclass->methods[i];
00298   }
00299 
00300   return scheme_false;
00301 }
00302 
00303 static Scheme_Object *class_p(int argc, Scheme_Object **argv)
00304 {
00305   return ((SCHEME_TYPE(argv[0]) == objscheme_class_type)
00306          ? scheme_true
00307          : scheme_false);
00308 }
00309 
00310 Scheme_Object *scheme_make_uninited_object(Scheme_Object *sclass)
00311 {
00312   Scheme_Object *obj;
00313   Scheme_Object *stype;
00314 
00315   stype = ((Scheme_Class *)sclass)->struct_type;
00316   if (!stype) {
00317     scheme_arg_mismatch("make-primitive-object",
00318                      "struct-type not yet prepared: ",
00319                      sclass);
00320     return NULL;
00321   }
00322 
00323   obj = scheme_make_struct_instance(stype, 0, NULL);
00324 
00325   return obj;  
00326 }
00327 
00328 #if EXTRA_PRIM_OBJECT_FIELD
00329 
00330 static Scheme_Object *extra_get(int argc, Scheme_Object **argv)
00331 {
00332   Scheme_Object *obj = argv[0];
00333 
00334   if (!SCHEME_STRUCTP(argv[0])
00335       || !scheme_is_struct_instance(object_struct, argv[0]))
00336     scheme_wrong_type("primitive-object-extra-get", "primitive-object", 0, argc, argv);
00337 
00338   return scheme_struct_ref(obj, 2);
00339 }
00340 
00341 static Scheme_Object *extra_set(int argc, Scheme_Object **argv)
00342 {
00343   Scheme_Object *obj = argv[0];
00344 
00345   if (!SCHEME_STRUCTP(argv[0])
00346       || !scheme_is_struct_instance(object_struct, argv[0]))
00347     scheme_wrong_type("primitive-object-extra-set!", "primitive-object", 0, argc, argv);
00348 
00349   scheme_struct_set(obj, 2, argv[1]);
00350 
00351   return scheme_void;
00352 }
00353 
00354 #endif
00355 
00356 /***************************************************************************/
00357 
00358 Scheme_Object *scheme_make_class(const char *name, Scheme_Object *sup, 
00359                              Scheme_Method_Prim *initf, int num_methods)
00360 {
00361   Scheme_Class *sclass;
00362   Scheme_Object *f, **methods, **names;
00363 
00364   sclass = (Scheme_Class *)scheme_malloc_tagged(sizeof(Scheme_Class));
00365   sclass->so.type = objscheme_class_type;
00366 
00367   sclass->name = name;
00368 
00369   if (sup && SCHEME_FALSEP(sup))
00370     sup = NULL;
00371   sclass->sup = sup;
00372 
00373   f = scheme_make_prim(initf);
00374   sclass->initf = f;
00375 
00376   sclass->num_methods = num_methods;
00377   sclass->num_installed = 0;
00378 
00379   methods = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
00380   names = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
00381 
00382   sclass->methods = methods;
00383   sclass->names = names;
00384 
00385   return (Scheme_Object *)sclass;
00386 }
00387 
00388 void scheme_add_method_w_arity(Scheme_Object *c, const char *name,
00389                             Scheme_Method_Prim *f, 
00390                             int mina, int maxa)
00391 {
00392   Scheme_Object *s;
00393   Scheme_Class *sclass;
00394   int count;
00395 
00396   sclass = (Scheme_Class *)c;
00397 
00398   s = scheme_make_prim_w_arity(f, name, mina + 1, (maxa < 0) ? -1 : (maxa + 1));
00399   scheme_prim_is_method(s);
00400 
00401   sclass->methods[sclass->num_installed] = s;
00402 
00403   count = strlen(name);
00404   if ((count > 7) && !strcmp(name + count - 7, " method"))
00405     count -= 7;
00406   s = scheme_intern_exact_symbol(name, count);
00407 
00408   sclass->names[sclass->num_installed] = s;
00409 
00410   sclass->num_installed++;
00411 }
00412 
00413 void scheme_add_method(Scheme_Object *c, const char *name,
00414                      Scheme_Method_Prim *f)
00415 {
00416   scheme_add_method_w_arity(c, name, f, 0, -1);
00417 }
00418 
00419 void scheme_made_class(Scheme_Object *c)
00420 {
00421   /* done */
00422 }
00423 
00424 Scheme_Object* scheme_class_to_interface(Scheme_Object *c, char *name)
00425 {
00426   return scheme_false;
00427 }
00428 
00429 int objscheme_is_subclass(Scheme_Object *a, Scheme_Object *b)
00430 {
00431   while (a && (a != b)) {
00432     a = ((Scheme_Class *)a)->sup;
00433   }
00434 
00435   return !!a;
00436 }
00437 
00438 int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
00439 {
00440   Scheme_Object *a;
00441 
00442   if (!SCHEME_STRUCTP(o) || !scheme_is_struct_instance(object_struct, o))
00443     return 0;
00444 
00445   a = scheme_struct_type_property_ref(object_property, o);
00446   
00447   while (a && (a != c)) {
00448     a = ((Scheme_Class *)a)->sup;
00449   }
00450 
00451   return !!a;
00452 }
00453 
00454 /***************************************************************************/
00455 
00456 #ifdef SUPPORT_ARBITRARY_OBJECTS
00457 
00458 typedef struct {
00459   void *realobj;
00460   Scheme_Object *obj;
00461 } ObjectHash;
00462 
00463 static ObjectHash *hash;
00464 static long hashsize = 100, hashcount = 0;
00465 
00466 #endif
00467 
00468 typedef struct {
00469   long id;
00470   Objscheme_Bundler f;
00471 } BundlerHash;
00472 
00473 static BundlerHash *bhash;
00474 static long bhashsize = 201, bhashcount = 0, bhashstep = 17;
00475 
00476 #ifndef FALSE
00477 #define FALSE 0
00478 #endif
00479 #ifndef TRUE
00480 #define TRUE 1
00481 #endif
00482 
00483 static long num_objects_allocated = 0;
00484 
00485 #if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) || defined(GC_MIGHT_USE_REGISTERED_STATICS)
00486 # define wxREGGLOB(x) scheme_register_extension_global((void *)&x, sizeof(x))
00487 #else
00488 # define wxREGGLOB(x) /* empty */
00489 #endif
00490 
00491 void objscheme_init(Scheme_Env *env)
00492 {
00493   long i;
00494 
00495 #ifdef SUPPORT_ARBITRARY_OBJECTS
00496   wxREGGLOB(hash);
00497   hash = (ObjectHash *)scheme_malloc_atomic(sizeof(ObjectHash) * hashsize);
00498   for (i = 0; i < hashsize; i++) {
00499     hash[i].realobj = NULL;
00500   }
00501 #endif
00502   
00503   wxREGGLOB(bhash);
00504   bhash = (BundlerHash *)scheme_malloc_atomic(sizeof(BundlerHash) 
00505                                          * bhashsize);
00506   for (i = 0; i < bhashsize; i++) {
00507     bhash[i].id = 0;
00508   }
00509 
00510   objscheme_class_type = scheme_make_type("<primitive-class>");
00511 
00512   wxREGGLOB(object_property);
00513   object_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-object"));
00514   
00515   wxREGGLOB(preparer_property);
00516   preparer_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-preparer"));
00517 
00518   wxREGGLOB(dispatcher_property);
00519   dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
00520 
00521   wxREGGLOB(object_struct);
00522   object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
00523                                      NULL, NULL,
00524                                      0, 2 + EXTRA_PRIM_OBJECT_FIELD, NULL,
00525                                      NULL, NULL);
00526   
00527 #ifdef MZ_PRECISE_GC
00528   GC_register_traversers(objscheme_class_type, gc_class_size, gc_class_mark, gc_class_fixup, 0, 0);
00529 #endif
00530 
00531   scheme_install_xc_global("initialize-primitive-object",
00532                         scheme_make_prim_w_arity(init_prim_obj,
00533                                               "initialize-primitive-object",
00534                                               1, -1),
00535                         env);
00536 
00537   scheme_install_xc_global("primitive-class-prepare-struct-type!",
00538                         scheme_make_prim_w_arity(class_prepare_struct_type,
00539                                               "primitive-class-prepare-struct-type!",
00540                                               6, 6),
00541                         env);
00542   
00543   scheme_install_xc_global("primitive-class-find-method",
00544                         scheme_make_prim_w_arity(class_find_meth,
00545                                               "primitive-class-find-method",
00546                                               2, 2),
00547                         env);
00548   
00549   scheme_install_xc_global("primitive-class->superclass",
00550                         scheme_make_prim_w_arity(class_sup,
00551                                               "primitive-class->superclass",
00552                                               1, 1),
00553                         env);
00554   
00555   scheme_install_xc_global("primitive-class?",
00556                         scheme_make_prim_w_arity(class_p,
00557                                               "primitive-class?",
00558                                               1, 1),
00559                         env);
00560 
00561 #if EXTRA_PRIM_OBJECT_FIELD
00562   scheme_install_xc_global("primitive-object-extra-get",
00563                         scheme_make_prim_w_arity(extra_get,
00564                                               "primitive-object-extra-get",
00565                                               1, 1),
00566                         env);
00567   
00568   scheme_install_xc_global("primitive-object-extra-set!",
00569                         scheme_make_prim_w_arity(extra_set,
00570                                               "primitive-object-extra-set!",
00571                                               2, 2),
00572                         env);  
00573 #endif
00574 }
00575 
00576 Scheme_Object *objscheme_def_prim_class(void *global_env, 
00577                                    char *name, char *superclass,
00578                                    Scheme_Method_Prim *initf,
00579                                    int nmethods)
00580 {
00581   Scheme_Object *obj;
00582   Scheme_Object *sclass;
00583 
00584   if (superclass)
00585     obj = scheme_lookup_xc_global(superclass, (Scheme_Env *) global_env);
00586   else
00587     obj = NULL;
00588 
00589   sclass = scheme_make_class(name, obj, initf, nmethods);
00590 
00591   scheme_install_xc_global(name, sclass, (Scheme_Env *) global_env);
00592 
00593   return sclass;
00594 }
00595 
00596 void objscheme_add_global_class(Scheme_Object *sclass, char *name, void *env)
00597 {
00598   scheme_install_xc_global(name, sclass, (Scheme_Env *) env);
00599 }
00600 
00601 void objscheme_add_global_interface(Scheme_Object *in, char *name, void *env)
00602 {
00603   /* do nothing */
00604 }
00605 
00606 Scheme_Object *objscheme_find_method(Scheme_Object *obj, Scheme_Object *sclass,
00607                                  char *name, void **cache)
00608 {
00609   Scheme_Object *s, *p[2], *dispatcher;
00610 
00611   if (!obj)
00612     return NULL;
00613 
00614   dispatcher = scheme_struct_type_property_ref(dispatcher_property, (Scheme_Object *)obj);
00615   if (!dispatcher)
00616     return NULL;
00617 
00618   if (*cache)
00619     s = (Scheme_Object *)*cache;
00620   else {
00621     s = scheme_intern_symbol(name);
00622     p[0] = s;
00623     s = scheme_struct_type_property_ref(preparer_property, (Scheme_Object *)obj);
00624     if (!s)
00625       return NULL;
00626     s = scheme_apply(s, 1, p);
00627     scheme_register_extension_global((void *)cache, sizeof(Scheme_Object*));
00628     *cache = s;
00629   }
00630 
00631   p[0] = obj;
00632   p[1] = s;
00633   return _scheme_apply(dispatcher, 2, p);
00634 }
00635 
00636 /***************************************************************************/
00637 
00638 int objscheme_istype_bool(Scheme_Object *obj, const char *where)
00639 {
00640   return 1; /* Anything can be a boolean */
00641 }
00642 
00643 int objscheme_istype_integer(Scheme_Object *obj, const char *stopifbad)
00644 {
00645   if (SCHEME_INTP(obj) || SCHEME_BIGNUMP(obj))
00646     return 1;
00647   else if (stopifbad) {
00648     scheme_wrong_type(stopifbad, "exact integer", -1, 0, &obj);
00649   }
00650   return 0;
00651 }
00652 
00653 int objscheme_istype_ExactLong(Scheme_Object *obj, const char *stopifbad)
00654 {
00655   return objscheme_istype_integer(obj, stopifbad);
00656 }
00657 
00658 int objscheme_istype_number(Scheme_Object *obj, const char *stopifbad)
00659 {
00660   if (SCHEME_INTP(obj) || SCHEME_DBLP(obj) || SCHEME_BIGNUMP(obj)
00661       || SCHEME_RATIONALP(obj))
00662     return 1;
00663   else if (stopifbad) {
00664     scheme_wrong_type(stopifbad, "real number", -1, 0, &obj);
00665   }
00666   return 0;
00667 }
00668 
00669 int objscheme_istype_double(Scheme_Object *obj, const char *stopifbad)
00670 {
00671   if (SCHEME_DBLP(obj))
00672     return 1;
00673   else if (stopifbad)
00674     scheme_wrong_type(stopifbad, "inexact real number", -1, 0, &obj);
00675   return 0;
00676 }
00677 
00678 int objscheme_istype_pair(Scheme_Object *obj, const char *stopifbad)
00679 {
00680   if (SCHEME_PAIRP(obj))
00681     return 1;
00682   else if (stopifbad)
00683     scheme_wrong_type(stopifbad, "pair", -1, 0, &obj);
00684   return 0;
00685 }
00686 
00687 int objscheme_istype_string(Scheme_Object *obj, const char *stopifbad)
00688 {
00689   if (SCHEME_CHAR_STRINGP(obj))
00690     return 1;
00691   else if (stopifbad)
00692     scheme_wrong_type(stopifbad, "string", -1, 0, &obj);
00693   return 0;
00694 }
00695 
00696 int objscheme_istype_bstring(Scheme_Object *obj, const char *stopifbad)
00697 {
00698   if (SCHEME_BYTE_STRINGP(obj))
00699     return 1;
00700   else if (stopifbad)
00701     scheme_wrong_type(stopifbad, "byte string", -1, 0, &obj);
00702   return 0;
00703 }
00704 
00705 int objscheme_istype_pstring(Scheme_Object *obj, const char *stopifbad)
00706 {
00707   if (SCHEME_BYTE_STRINGP(obj)
00708       || SCHEME_CHAR_STRINGP(obj))
00709     return 1;
00710   else if (stopifbad)
00711     scheme_wrong_type(stopifbad, "string or byte string", -1, 0, &obj);
00712   return 0;
00713 }
00714 
00715 int objscheme_istype_pathname(Scheme_Object *obj, const char *stopifbad)
00716 {
00717   if (SCHEME_PATHP(obj)
00718       || SCHEME_CHAR_STRINGP(obj))
00719     return 1;
00720   else if (stopifbad)
00721     scheme_wrong_type(stopifbad, "path or string", -1, 0, &obj);
00722   return 0;
00723 }
00724 
00725 int objscheme_istype_epathname(Scheme_Object *obj, const char *stopifbad)
00726 {
00727   if (SCHEME_PATHP(obj))
00728     return 1;
00729   else if (stopifbad)
00730     scheme_wrong_type(stopifbad, "path", -1, 0, &obj);
00731   return 0;
00732 }
00733 
00734 int objscheme_istype_char(Scheme_Object *obj, const char *stopifbad)
00735 {
00736   if (SCHEME_CHARP(obj))
00737     return 1;
00738   else if (stopifbad)
00739     scheme_wrong_type(stopifbad, "character", -1, 0, &obj);
00740   return 0;
00741 }
00742 
00743 int objscheme_istype_closed_prim(Scheme_Object *obj, const char *stopifbad)
00744 {
00745   if (SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type))
00746     return 1;
00747   else if (stopifbad)
00748     scheme_wrong_type(stopifbad, "procedure", -1, 0, &obj);
00749   return 0;
00750 }
00751 
00752 int objscheme_istype_proc2(Scheme_Object *obj, const char *stopifbad)
00753 {
00754   return scheme_check_proc_arity(stopifbad, 2, -1, 0, &obj);
00755 }
00756 
00757 int objscheme_istype_box(Scheme_Object *obj, const char *stopifbad)
00758 {
00759   if (SCHEME_BOXP(obj))
00760     return 1;
00761   else if (stopifbad)
00762     scheme_wrong_type(stopifbad, "box", -1, 0, &obj);
00763   return 0;
00764 }
00765 
00766 int objscheme_istype_nonnegative_symbol_integer(Scheme_Object *obj, const char *sym, const char *where)
00767 {
00768   if (SCHEME_SYMBOLP(obj)) {
00769     int l;
00770     l = strlen(sym);
00771     if (SCHEME_SYM_LEN(obj) == l) {
00772       if (!strcmp(sym, SCHEME_SYM_VAL(obj))) {
00773        return 1;
00774       }
00775     }
00776   }
00777 
00778   if (objscheme_istype_integer(obj, NULL)) {
00779     long v;
00780     v = objscheme_unbundle_integer(obj, where);
00781     if (v >= 0)
00782       return 1;
00783   }
00784 
00785   if (where) {
00786     char *b;
00787     b = (char *)scheme_malloc_atomic(50);
00788     strcpy(b, "non-negative exact integer or '");
00789     strcat(b, sym);
00790     scheme_wrong_type(where, b, -1, 0, &obj);
00791   }
00792 
00793   return 0;
00794 }
00795 
00796 int objscheme_istype_nonnegative_symbol_double(Scheme_Object *obj, const char *sym, const char *where)
00797 {
00798   if (SCHEME_SYMBOLP(obj)) {
00799     int l;
00800     l = strlen(sym);
00801     if (SCHEME_SYM_LEN(obj) == l) {
00802       if (!strcmp(sym, SCHEME_SYM_VAL(obj))) {
00803        return 1;
00804       }
00805     }
00806   }
00807 
00808   if (objscheme_istype_number(obj, NULL)) {
00809     double v;
00810     v = objscheme_unbundle_double(obj, where);
00811     if (v >= 0)
00812       return 1;
00813   }
00814 
00815   if (where) {
00816     char *b;
00817     b = (char *)scheme_malloc_atomic(50);
00818     strcpy(b, "non-negative number or '");
00819     strcat(b, sym);
00820     scheme_wrong_type(where, b, -1, 0, &obj);
00821   }
00822 
00823   return 0;
00824 }
00825 
00826 /************************************************************************/
00827 
00828 Scheme_Object *objscheme_box(Scheme_Object *v)
00829 {
00830   return scheme_box(v);
00831 }
00832 
00833 Scheme_Object *objscheme_bundle_string(char *s)
00834 {
00835   if (!s)
00836     return XC_SCHEME_NULL;
00837   else
00838     return scheme_make_utf8_string(s);
00839 }
00840 
00841 Scheme_Object *objscheme_bundle_bstring(char *s)
00842 {
00843   if (!s)
00844     return XC_SCHEME_NULL;
00845   else
00846     return scheme_make_byte_string(s);
00847 }
00848 
00849 Scheme_Object *objscheme_bundle_pathname(char *s)
00850 {
00851   if (!s)
00852     return XC_SCHEME_NULL;
00853   else
00854     return scheme_make_path(s);
00855 }
00856 
00857 Scheme_Object *objscheme_bundle_mzstring(mzchar *s)
00858 {
00859   if (!s)
00860     return XC_SCHEME_NULL;
00861   else
00862     return scheme_make_char_string(s);
00863 }
00864 
00865 Scheme_Object *objscheme_bundle_nonnegative_symbol_double(double d, const char *symname)
00866 {
00867   if (d < 0)
00868     return scheme_intern_symbol(symname);
00869   else
00870     return scheme_make_double(d);
00871 }
00872 
00873 /************************************************************************/
00874 
00875 long objscheme_unbundle_integer(Scheme_Object *obj, const char *where)
00876 {
00877   (void)objscheme_istype_integer(obj, where);
00878   if (SCHEME_BIGNUMP(obj)) {
00879     if (SCHEME_PINT_VAL(obj) < 0)
00880       return -0xfffFFFF;
00881     else
00882       return 0xfffFFFF;
00883   } else
00884     return SCHEME_INT_VAL(obj);
00885 }
00886 
00887 long objscheme_unbundle_nonnegative_integer(Scheme_Object *obj, const char *where)
00888 {
00889   if (objscheme_istype_integer(obj, NULL)) {
00890     long v;
00891     v = objscheme_unbundle_integer(obj, where);
00892     if (v >= 0)
00893       return v;
00894   }
00895 
00896   if (where)
00897     scheme_wrong_type(where, "non-negative exact integer", -1, 0, &obj);
00898 
00899   return -1;
00900 }
00901 
00902 long objscheme_unbundle_integer_in(Scheme_Object *obj, long minv, long maxv, const char *stopifbad)
00903 {
00904   if (objscheme_istype_integer(obj, NULL)) {
00905     long v;
00906     v = objscheme_unbundle_integer(obj, stopifbad);
00907     if ((v >= minv) && (v <= maxv))
00908       return v;
00909   }
00910 
00911   if (stopifbad) {
00912     char buffer[100];
00913     sprintf(buffer, "exact integer in [%ld, %ld]", minv, maxv);
00914     scheme_wrong_type(stopifbad, buffer, -1, 0, &obj);
00915   }
00916 
00917   return 0;
00918 }
00919 
00920 
00921 long objscheme_unbundle_nonnegative_symbol_integer(Scheme_Object *obj, const char *sym, const char *where)
00922 {
00923   if (SCHEME_SYMBOLP(obj)) {
00924     int l;
00925     l = strlen(sym);
00926     if (SCHEME_SYM_LEN(obj) == l) {
00927       if (!strcmp(sym, SCHEME_SYM_VAL(obj))) {
00928        return -1;
00929       }
00930     }
00931   }
00932 
00933   if (objscheme_istype_number(obj, NULL)) {
00934     long v;
00935     v = objscheme_unbundle_integer(obj, where);
00936     if (v >= 0)
00937       return v;
00938   }
00939 
00940   (void)objscheme_istype_nonnegative_symbol_integer(obj, sym, where);
00941   return -1;
00942 }
00943 
00944 ExactLong objscheme_unbundle_ExactLong(Scheme_Object *obj, const char *where)
00945 {
00946   long v;
00947 
00948   (void)objscheme_istype_integer(obj, where);
00949   if (!scheme_get_int_val(obj, &v)) {
00950     if (where)
00951       scheme_arg_mismatch(where, "argument integer is out of platform-specific bounds", obj);
00952   }
00953 
00954   return v;
00955 }
00956 
00957 
00958 double objscheme_unbundle_double(Scheme_Object *obj, const char *where)
00959 {
00960   (void)objscheme_istype_number(obj, where);
00961   if (SCHEME_DBLP(obj))
00962     return SCHEME_DBL_VAL(obj);
00963   else if (SCHEME_RATIONALP(obj))
00964     return scheme_rational_to_double(obj);
00965   else if (SCHEME_BIGNUMP(obj))
00966     return scheme_bignum_to_double(obj);
00967   else
00968     return (double)SCHEME_INT_VAL(obj);
00969 }
00970 
00971 double objscheme_unbundle_nonnegative_symbol_double(Scheme_Object *obj, const char *sym, const char *where)
00972 {
00973   if (SCHEME_SYMBOLP(obj)) {
00974     int l;
00975     l = strlen(sym);
00976     if (SCHEME_SYM_LEN(obj) == l) {
00977       if (!strcmp(sym, SCHEME_SYM_VAL(obj))) {
00978        return -1;
00979       }
00980     }
00981   }
00982 
00983   if (objscheme_istype_number(obj, NULL)) {
00984     double v;
00985     v = objscheme_unbundle_double(obj, where);
00986     if (v >= 0)
00987       return v;
00988   }
00989 
00990   (void)objscheme_istype_nonnegative_symbol_double(obj, sym, where);
00991   return -1;
00992 }
00993 
00994 double objscheme_unbundle_double_in(Scheme_Object *obj, double minv, double maxv, const char *stopifbad)
00995 {
00996   if (objscheme_istype_number(obj, NULL)) {
00997     double v;
00998     v = objscheme_unbundle_double(obj, stopifbad);
00999     if ((v >= minv) && (v <= maxv))
01000       return v;
01001   }
01002 
01003   if (stopifbad) {
01004     char buffer[100];
01005     sprintf(buffer, "real number in [%f, %f]", minv, maxv);
01006     scheme_wrong_type(stopifbad, buffer, -1, 0, &obj);
01007   }
01008 
01009   return 0;
01010 }
01011 
01012 double objscheme_unbundle_nonnegative_double(Scheme_Object *obj, const char *where)
01013 {
01014   if (objscheme_istype_number(obj, NULL)) {
01015     double v;
01016     v = objscheme_unbundle_double(obj, where);
01017     if (v >= 0)
01018       return v;
01019   }
01020 
01021   if (where)
01022     scheme_wrong_type(where, "non-negative number", -1, 0, &obj);
01023 
01024   return -1.0;
01025 }
01026 
01027 int objscheme_unbundle_bool(Scheme_Object *obj, const char *where)
01028 {  
01029   (void)objscheme_istype_bool(obj, where);
01030   return NOT_SAME_OBJ(obj, scheme_false);
01031 }
01032 
01033 char *objscheme_unbundle_string(Scheme_Object *obj, const char *where)
01034 {
01035   (void)objscheme_istype_string(obj, where);
01036   obj = scheme_char_string_to_byte_string(obj);
01037   return SCHEME_BYTE_STR_VAL(obj);
01038 }
01039 
01040 char *objscheme_unbundle_pstring(Scheme_Object *obj, const char *where)
01041 {
01042   (void)objscheme_istype_pstring(obj, where);
01043   if (SCHEME_CHAR_STRINGP(obj))
01044     obj = scheme_char_string_to_path(obj);
01045   return SCHEME_PATH_VAL(obj);
01046 }
01047 
01048 mzchar *objscheme_unbundle_mzstring(Scheme_Object *obj, const char *where)
01049 {
01050   (void)objscheme_istype_string(obj, where);
01051   return SCHEME_CHAR_STR_VAL(obj);
01052 }
01053 
01054 mzchar *objscheme_unbundle_mutable_mzstring(Scheme_Object *obj, const char *where)
01055 {
01056   if (!SCHEME_MUTABLE_CHAR_STRINGP(obj)) {
01057     scheme_wrong_type(where, "mutable string", -1, 0, &obj);
01058   }
01059   return SCHEME_CHAR_STR_VAL(obj);
01060 }
01061 
01062 char *objscheme_unbundle_bstring(Scheme_Object *obj, const char *where)
01063 {
01064   (void)objscheme_istype_bstring(obj, where);
01065   return SCHEME_BYTE_STR_VAL(obj);
01066 }
01067 
01068 char *objscheme_unbundle_mutable_bstring(Scheme_Object *obj, const char *where)
01069 {
01070   if (!SCHEME_MUTABLE_BYTE_STRINGP(obj)) {
01071     scheme_wrong_type(where, "mutable byte string", -1, 0, &obj);
01072   }
01073   return SCHEME_BYTE_STR_VAL(obj);
01074 }
01075 
01076 char *objscheme_unbundle_pathname_guards(Scheme_Object *obj, const char *where, int guards)
01077 {
01078   (void)objscheme_istype_pathname(obj, where);
01079   return scheme_expand_string_filename(obj, (char *)where, NULL, guards);
01080 }
01081 
01082 char *objscheme_unbundle_pathname(Scheme_Object *obj, const char *where)
01083 {
01084   return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_READ);
01085 }
01086 
01087 char *objscheme_unbundle_epathname(Scheme_Object *obj, const char *where)
01088 {
01089   (void)objscheme_istype_epathname(obj, where);
01090   return SCHEME_PATH_VAL(obj);
01091 }
01092 
01093 char *objscheme_unbundle_xpathname(Scheme_Object *obj, const char *where)
01094 {
01095   (void)objscheme_istype_xpathname(obj, where);
01096   if (!SCHEME_PATHP(obj))
01097     obj = scheme_char_string_to_path(obj);
01098 
01099   return SCHEME_PATH_VAL(obj);
01100 }
01101 
01102 char *objscheme_unbundle_write_pathname(Scheme_Object *obj, const char *where)
01103 {
01104   return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_WRITE);
01105 }
01106 
01107 char *objscheme_unbundle_nullable_string(Scheme_Object *obj, const char *where)
01108 {
01109   if (XC_SCHEME_NULLP(obj))
01110     return NULL;
01111   else if (!where || SCHEME_CHAR_STRINGP(obj))
01112     return objscheme_unbundle_string(obj, where);
01113   else {
01114     scheme_wrong_type(where, "string or "  XC_NULL_STR, -1, 0, &obj);
01115     return NULL;
01116   }
01117 }
01118 
01119 char *objscheme_unbundle_nullable_bstring(Scheme_Object *obj, const char *where)
01120 {
01121   if (XC_SCHEME_NULLP(obj))
01122     return NULL;
01123   else if (!where || SCHEME_BYTE_STRINGP(obj))
01124     return objscheme_unbundle_bstring(obj, where);
01125   else {
01126     scheme_wrong_type(where, "byte string or "  XC_NULL_STR, -1, 0, &obj);
01127     return NULL;
01128   }
01129 }
01130 
01131 mzchar *objscheme_unbundle_nullable_mzstring(Scheme_Object *obj, const char *where)
01132 {
01133   if (XC_SCHEME_NULLP(obj))
01134     return NULL;
01135   else if (!where || SCHEME_CHAR_STRINGP(obj))
01136     return objscheme_unbundle_mzstring(obj, where);
01137   else {
01138     scheme_wrong_type(where, "string or "  XC_NULL_STR, -1, 0, &obj);
01139     return NULL;
01140   }
01141 }
01142 
01143 char *objscheme_unbundle_nullable_pstring(Scheme_Object *obj, const char *where)
01144 {
01145   if (XC_SCHEME_NULLP(obj))
01146     return NULL;
01147   else if (!where || SCHEME_PATH_STRINGP(obj))
01148     return objscheme_unbundle_pstring(obj, where);
01149   else {
01150     scheme_wrong_type(where, SCHEME_PATH_STRING_STR " or "  XC_NULL_STR, -1, 0, &obj);
01151     return NULL;
01152   }
01153 }
01154 
01155 char *objscheme_unbundle_nullable_pathname(Scheme_Object *obj, const char *where)
01156 {
01157   if (XC_SCHEME_NULLP(obj))
01158     return NULL;
01159   else if (!where || SCHEME_PATHP(obj) || SCHEME_CHAR_STRINGP(obj))
01160     return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_READ);
01161   else  {
01162     scheme_wrong_type(where, "path, string, or " XC_NULL_STR, -1, 0, &obj);
01163     return NULL;
01164   }
01165     
01166 }
01167 
01168 char *objscheme_unbundle_nullable_xpathname(Scheme_Object *obj, const char *where)
01169 {
01170   if (XC_SCHEME_NULLP(obj))
01171     return NULL;
01172   else if (SCHEME_PATHP(obj) || SCHEME_CHAR_STRINGP(obj))
01173     return objscheme_unbundle_xpathname(obj, NULL);
01174   else  if (where) {
01175     scheme_wrong_type(where, "path, string, or " XC_NULL_STR, -1, 0, &obj);
01176     return NULL;
01177   } else
01178     return NULL;
01179 }
01180 
01181 char *objscheme_unbundle_nullable_epathname(Scheme_Object *obj, const char *where)
01182 {
01183   if (XC_SCHEME_NULLP(obj))
01184     return NULL;
01185   else if (!where || SCHEME_PATHP(obj))
01186     return objscheme_unbundle_epathname(obj, where);
01187   else  {
01188     scheme_wrong_type(where, "path or " XC_NULL_STR, -1, 0, &obj);
01189     return NULL;
01190   }
01191     
01192 }
01193 
01194 char *objscheme_unbundle_nullable_write_pathname(Scheme_Object *obj, const char *where)
01195 {
01196   if (XC_SCHEME_NULLP(obj))
01197     return NULL;
01198   else if (!where || SCHEME_PATHP(obj) || SCHEME_CHAR_STRINGP(obj))
01199     return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_WRITE);
01200   else  {
01201     scheme_wrong_type(where, "path, string, or " XC_NULL_STR, -1, 0, &obj);
01202     return NULL;
01203   }
01204     
01205 }
01206 
01207 mzchar objscheme_unbundle_char(Scheme_Object *obj, const char *where)
01208 {
01209   (void)objscheme_istype_char(obj, where);
01210   return SCHEME_CHAR_VAL(obj);
01211 }
01212 
01213 Scheme_Object *objscheme_car(Scheme_Object *obj, const char *where)
01214 {  
01215   (void)objscheme_istype_pair(obj, where);
01216   return scheme_car(obj);
01217 }
01218 
01219 Scheme_Object *objscheme_unbox(Scheme_Object *obj, const char *where)
01220 {  
01221   (void)objscheme_istype_box(obj, where);
01222   return scheme_unbox(obj);
01223 }
01224 
01225 Scheme_Object *objscheme_nullable_unbox(Scheme_Object *obj, const char *where)
01226 {  
01227   if (!SCHEME_BOXP(obj)) {
01228     if (where)
01229       scheme_wrong_type(where, "box or " XC_NULL_STR, -1, 0, &obj);
01230     return NULL;
01231   } else
01232     return scheme_unbox(obj);
01233     
01234 }
01235 
01236 /************************************************************************/
01237 
01238 void objscheme_set_box(Scheme_Object *b, Scheme_Object *v)
01239 {
01240   (void)objscheme_istype_box(b, "set-box!");
01241   SCHEME_PTR_VAL(b) = v;
01242 }
01243 
01244 /************************************************************************/
01245 
01246 #ifdef SUPPORT_ARBITRARY_OBJECTS
01247 
01248 #define HASH(realobj) (((long)realobj >> 2) % hashsize)
01249 
01250 #define GONE ((void *)1)
01251 
01252 void objscheme_save_object(void *realobj, Scheme_Object *obj)
01253 {
01254   int i;
01255 
01256   if (2 * hashcount > hashsize) {
01257     long oldsize = hashsize;
01258     ObjectHash *old = hash;
01259 
01260     hashsize *= 2;
01261     hash = (ObjectHash *)scheme_malloc_atomic(sizeof(ObjectHash) * hashsize);
01262 
01263     for (i = 0; i < hashsize; i++) {
01264       hash[i].realobj = NULL;
01265     }
01266 
01267     hashcount = 0;
01268     for (i = 0; i < oldsize; i++) {
01269       if (old[i].realobj && NOT_SAME_PTR(old[i].realobj, GONE))
01270        objscheme_save_object(old[i].realobj, (Scheme_Object *)old[i].obj);
01271     }
01272   }
01273 
01274   i = HASH(realobj);
01275   if (i < 0)
01276     i = -i;
01277 
01278   while (hash[i].realobj && NOT_SAME_PTR(hash[i].realobj, GONE)) {
01279     i++;
01280     if (i >= hashsize)
01281       i = 0;
01282   }
01283 
01284   hash[i].realobj = realobj;
01285   hash[i].obj = obj;
01286 
01287   hashcount++;
01288 }
01289 
01290 Scheme_Object *objscheme_find_object(void *realobj)
01291 {
01292   int i;
01293 
01294   i = HASH(realobj);
01295   if (i < 0)
01296     i = -i;
01297 
01298   while (NOT_SAME_PTR(hash[i].realobj, realobj) || SAME_PTR(hash[i].realobj, GONE)) {
01299     if (!hash[i].realobj)
01300       return NULL;
01301     i++;
01302     if (i >= hashsize)
01303       i = 0;
01304   }
01305 
01306   return hash[i].obj;
01307 }
01308 
01309 #endif
01310 
01311 void objscheme_check_valid(Scheme_Object *sclass, const char *name, int n, Scheme_Object **argv)
01312 {
01313   Scheme_Class_Object *obj = (Scheme_Class_Object *)argv[0];
01314 
01315   if (!SCHEME_STRUCTP((Scheme_Object *)obj)
01316       || !scheme_is_struct_instance(object_struct, (Scheme_Object *)obj)) {
01317     scheme_wrong_type(name ? name : "unbundle", "primitive object", 0, n, argv);
01318     return;
01319   }
01320 
01321   if (sclass) {
01322     Scheme_Object *osclass;
01323     osclass = scheme_struct_type_property_ref(object_property, (Scheme_Object *)obj);
01324     if (!objscheme_is_subclass(osclass, sclass)) {
01325       scheme_wrong_type(name ? name : "unbundle", ((Scheme_Class *)sclass)->name, 0, n, argv);
01326       return;
01327     }
01328   }
01329 
01330   if (SCHEME_FALSEP((Scheme_Object *)obj->primflag)) {
01331     scheme_signal_error("%s: object is not yet initialized: %V",
01332                      name ? name : "unbundle",
01333                      obj);
01334   }
01335   if (obj->primflag < 0) {
01336     scheme_signal_error("%s: %sobject%s: %V",
01337                      name ? name : "unbundle",
01338                      (obj->primflag == -1) ? "invalidated " : "",
01339                      (obj->primflag == -2) ? " (shutdown by a custodian)" : "",
01340                      obj);
01341     return;
01342   }
01343 }
01344 
01345 int objscheme_is_shutdown(Scheme_Object *o)
01346 {
01347   Scheme_Class_Object *obj = (Scheme_Class_Object *)o;
01348 
01349   return (obj->primflag < 0);
01350 }
01351 
01352 void objscheme_destroy(void *realobj, Scheme_Object *obj_in)
01353 {
01354 #ifdef SUPPORT_ARBITRARY_OBJECTS
01355   int i;
01356 #endif
01357   Scheme_Class_Object *obj;
01358 
01359   --num_objects_allocated;
01360 
01361   obj = (Scheme_Class_Object *)obj_in;
01362 
01363 #ifdef SUPPORT_ARBITRARY_OBJECTS
01364   if (!obj) {
01365     i = HASH(realobj);
01366     if (i < 0)
01367       i = -i;
01368     
01369     while (NOT_SAME_PTR(hash[i].realobj, realobj) 
01370           || SAME_PTR(hash[i].realobj, GONE)) {
01371       if (!hash[i].realobj)
01372        break;
01373       i++;
01374       if (i >= hashsize)
01375        i = 0;
01376     }
01377     
01378     if (hash[i].realobj) {
01379       obj = hash[i].obj;
01380       hash[i].realobj = GONE;
01381     }
01382   }
01383 #endif
01384 
01385   if (obj) {
01386     if (obj->primflag < 0)
01387       return;
01388 
01389     obj->primflag = -1;
01390     obj->primdata = NULL;
01391   }
01392 }
01393 
01394 void objscheme_register_primpointer(void *prim_obj, void *prim_ptr_address)
01395 {
01396 #ifdef MZ_PRECISE_GC
01397   GC_finalization_weak_ptr((void **)prim_obj, (void **)prim_ptr_address - (void **)prim_obj);
01398 #else
01399   GC_general_register_disappearing_link((void **)prim_ptr_address, NULL);
01400 #endif
01401 }
01402 
01403 /***************************************************************/
01404 
01405 void objscheme_install_bundler(Objscheme_Bundler f, long id)
01406 {
01407   long i;
01408 
01409   i = id % bhashsize;
01410   while(bhash[i].id && bhash[i].id != id) {
01411     i = (i + bhashstep) % bhashsize;
01412   }
01413 
01414   bhash[i].id = id;
01415   bhash[i].f = f;
01416   bhashcount++;
01417 }
01418 
01419 Scheme_Object *objscheme_bundle_by_type(void *realobj, long id)
01420 {
01421   long i;
01422 
01423   i = id % bhashsize;
01424   while(bhash[i].id && bhash[i].id != id) {
01425     i = (i + bhashstep) % bhashsize;
01426   }
01427 
01428   if (!bhash[i].id)
01429     return NULL;
01430 
01431   return bhash[i].f(realobj);
01432 }
01433 
01434 /************************************************************************/
01435 
01436 #ifdef __cplusplus
01437 extern "C" 
01438 {
01439 #endif
01440 
01441 void objscheme_mark_external_invalid(void *sobj)
01442 {
01443   Scheme_Class_Object *obj = (Scheme_Class_Object *)sobj;
01444 
01445   obj->primflag = -1;
01446   obj->primdata = NULL;  
01447 }
01448 
01449 #ifdef __cplusplus
01450 }
01451 #endif
01452