root/src/class.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. class_list_to_array
  2. class_array_to_list
  3. class_array_to_names
  4. Scm__InternalClassName
  5. class_allocate
  6. class_print
  7. allocate
  8. class_compute_cpl
  9. Scm_ClassOf
  10. Scm_BaseClassOf
  11. class_of_cc
  12. Scm_VMClassOf
  13. is_a_cc
  14. Scm_VMIsA
  15. class_name
  16. class_name_set
  17. class_cpl
  18. class_cpl_set
  19. class_direct_supers
  20. class_direct_supers_set
  21. class_direct_slots
  22. class_direct_slots_set
  23. class_slots_ref
  24. class_slots_set
  25. class_accessors
  26. class_accessors_set
  27. class_numislots
  28. class_numislots_set
  29. class_category
  30. class_initargs
  31. class_initargs_set
  32. class_defined_modules
  33. class_defined_modules_set
  34. class_direct_subclasses
  35. class_direct_methods
  36. class_redefined
  37. make_implicit_meta
  38. Scm_SubtypeP
  39. Scm_TypeP
  40. Scm_ComputeCPL
  41. lock_class_redefinition
  42. unlock_class_redefinition
  43. Scm_StartClassRedefinition
  44. Scm_CommitClassRedefinition
  45. Scm_CheckClassBinding
  46. Scm_ReplaceClassBinding
  47. Scm_AddDirectSubclass
  48. Scm_DeleteDirectSubclass
  49. Scm_AddDirectMethod
  50. Scm_DeleteDirectMethod
  51. Scm_TransplantInstance
  52. Scm_VMTouchInstance
  53. Scm_AllocateInstance
  54. instance_class_redefinition
  55. scheme_slot_ref
  56. scheme_slot_set
  57. Scm_InstanceSlotRef
  58. Scm_InstanceSlotSet
  59. slot_initialize_cc
  60. Scm_VMSlotInitializeUsingAccessor
  61. Scm_GetSlotAccessor
  62. slot_ref_using_accessor_cc
  63. slot_boundp_using_accessor_cc
  64. slot_ref_using_accessor
  65. slot_ref_cc
  66. Scm_VMSlotRef
  67. slot_ref_using_accessor_cc1
  68. Scm_VMSlotRefUsingAccessor
  69. slot_ref_using_class
  70. slot_set_using_accessor
  71. slot_set_cc
  72. Scm_VMSlotSet
  73. slot_set_using_accessor_cc
  74. Scm_VMSlotSetUsingAccessor
  75. slot_set_using_class
  76. slot_boundp_cc
  77. Scm_VMSlotBoundP
  78. slot_bound_using_class_p
  79. builtin_initialize
  80. slot_accessor_allocate
  81. slot_accessor_print
  82. slot_accessor_class
  83. slot_accessor_class_set
  84. slot_accessor_name
  85. slot_accessor_name_set
  86. slot_accessor_init_value
  87. slot_accessor_init_value_set
  88. slot_accessor_init_keyword
  89. slot_accessor_init_keyword_set
  90. slot_accessor_init_thunk
  91. slot_accessor_init_thunk_set
  92. slot_accessor_slot_number
  93. slot_accessor_slot_number_set
  94. slot_accessor_initializable
  95. slot_accessor_initializable_set
  96. slot_accessor_scheme_getter
  97. slot_accessor_scheme_getter_set
  98. slot_accessor_scheme_setter
  99. slot_accessor_scheme_setter_set
  100. slot_accessor_scheme_boundp
  101. slot_accessor_scheme_boundp_set
  102. Scm_ObjectAllocate
  103. object_initialize1
  104. object_initialize_cc
  105. object_initialize
  106. object_compare
  107. object_compare_default
  108. generic_allocate
  109. generic_print
  110. generic_name
  111. generic_name_set
  112. generic_methods
  113. generic_methods_set
  114. Scm_MakeBaseGeneric
  115. Scm_NoNextMethod
  116. Scm_NoOperation
  117. Scm_InvalidApply
  118. Scm_ComputeApplicableMethods
  119. compute_applicable_methods
  120. method_more_specific
  121. method_more_specific_p
  122. Scm_SortMethods
  123. method_allocate
  124. method_print
  125. method_initialize
  126. method_required
  127. method_optional
  128. method_generic
  129. method_generic_set
  130. method_specializers
  131. method_specializers_set
  132. Scm_UpdateDirectMethod
  133. generic_updatedirectmethod
  134. Scm_AddMethod
  135. generic_addmethod
  136. Scm_DeleteMethod
  137. generic_deletemethod
  138. Scm_MakeNextMethod
  139. next_method_print
  140. accessor_method_print
  141. accessor_get_proc
  142. accessor_set_proc
  143. accessor_method_initialize
  144. accessor_method_slot_accessor
  145. accessor_method_slot_accessor_set
  146. Scm_MakeForeignPointerClass
  147. fp_finalize
  148. make_foreign_int
  149. Scm_MakeForeignPointer
  150. Scm_ForeignPointerAttr
  151. Scm_ForeignPointerAttrGet
  152. Scm_ForeignPointerAttrSet
  153. initialize_builtin_cpl
  154. init_class
  155. Scm_InitStaticClass
  156. Scm_InitStaticClassWithSupers
  157. Scm_InitStaticClassWithMeta
  158. Scm_InitBuiltinClass
  159. Scm_InitBuiltinGeneric
  160. Scm_InitBuiltinMethod
  161. Scm__InitClass

   1 /*
   2  * class.c - class metaobject implementation
   3  *
   4  *   Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
   5  * 
   6  *   Redistribution and use in source and binary forms, with or without
   7  *   modification, are permitted provided that the following conditions
   8  *   are met:
   9  * 
  10  *   1. Redistributions of source code must retain the above copyright
  11  *      notice, this list of conditions and the following disclaimer.
  12  *
  13  *   2. Redistributions in binary form must reproduce the above copyright
  14  *      notice, this list of conditions and the following disclaimer in the
  15  *      documentation and/or other materials provided with the distribution.
  16  *
  17  *   3. Neither the name of the authors nor the names of its contributors
  18  *      may be used to endorse or promote products derived from this
  19  *      software without specific prior written permission.
  20  *
  21  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  27  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  28  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  29  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  30  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  31  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32  *
  33  *  $Id: class.c,v 1.131 2005/10/13 08:14:13 shirok Exp $
  34  */
  35 
  36 #define LIBGAUCHE_BODY
  37 #include "gauche.h"
  38 #include "gauche/macro.h"
  39 #include "gauche/class.h"
  40 #include "gauche/code.h"
  41 #include "gauche/builtin-syms.h"
  42 
  43 /*===================================================================
  44  * Built-in classes
  45  */
  46 
  47 static void class_print(ScmObj, ScmPort *, ScmWriteContext*);
  48 static void generic_print(ScmObj, ScmPort *, ScmWriteContext*);
  49 static void method_print(ScmObj, ScmPort *, ScmWriteContext*);
  50 static void next_method_print(ScmObj, ScmPort *, ScmWriteContext*);
  51 static void slot_accessor_print(ScmObj, ScmPort *, ScmWriteContext*);
  52 static void accessor_method_print(ScmObj, ScmPort *, ScmWriteContext*);
  53 
  54 static ScmObj class_allocate(ScmClass *klass, ScmObj initargs);
  55 static ScmObj generic_allocate(ScmClass *klass, ScmObj initargs);
  56 static ScmObj method_allocate(ScmClass *klass, ScmObj initargs);
  57 static ScmObj slot_accessor_allocate(ScmClass *klass, ScmObj initargs);
  58 static void   initialize_builtin_cpl(ScmClass *klass, ScmObj supers);
  59 
  60 static ScmObj instance_class_redefinition(ScmObj obj, ScmClass *old);
  61 static ScmObj slot_set_using_accessor(ScmObj obj, ScmSlotAccessor *sa,
  62                                       ScmObj val);
  63 
  64 static int object_compare(ScmObj x, ScmObj y, int equalp);
  65 
  66 static ScmObj builtin_initialize(ScmObj *, int, ScmGeneric *);
  67 
  68 ScmClass *Scm_DefaultCPL[] = {
  69     SCM_CLASS_STATIC_PTR(Scm_TopClass),
  70     NULL
  71 };
  72 
  73 ScmClass *Scm_CollectionCPL[] = {
  74     SCM_CLASS_STATIC_PTR(Scm_CollectionClass),
  75     SCM_CLASS_STATIC_PTR(Scm_TopClass),
  76     NULL
  77 };
  78 
  79 ScmClass *Scm_SequenceCPL[] = {
  80     SCM_CLASS_STATIC_PTR(Scm_SequenceClass),
  81     SCM_CLASS_STATIC_PTR(Scm_CollectionClass),
  82     SCM_CLASS_STATIC_PTR(Scm_TopClass),
  83     NULL
  84 };
  85 
  86 ScmClass *Scm_ObjectCPL[] = {
  87     SCM_CLASS_STATIC_PTR(Scm_ObjectClass),
  88     SCM_CLASS_STATIC_PTR(Scm_TopClass),
  89     NULL
  90 };
  91 
  92 static ScmClass *Scm_MethodCPL[] = {
  93     SCM_CLASS_STATIC_PTR(Scm_MethodClass),
  94     SCM_CLASS_STATIC_PTR(Scm_ObjectClass),
  95     SCM_CLASS_STATIC_PTR(Scm_TopClass),
  96     NULL
  97 };
  98 
  99 SCM_DEFINE_ABSTRACT_CLASS(Scm_TopClass, NULL);
 100 SCM_DEFINE_ABSTRACT_CLASS(Scm_CollectionClass, SCM_CLASS_DEFAULT_CPL);
 101 SCM_DEFINE_ABSTRACT_CLASS(Scm_SequenceClass, SCM_CLASS_COLLECTION_CPL);
 102 
 103 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_BoolClass, NULL);
 104 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_CharClass, NULL);
 105 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_UnknownClass, NULL);
 106 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_EOFObjectClass, NULL);
 107 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_UndefinedObjectClass, NULL);
 108 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_ForeignPointerClass, NULL);
 109 
 110 SCM_DEFINE_BASE_CLASS(Scm_ObjectClass, ScmInstance,
 111                       NULL, NULL, NULL, Scm_ObjectAllocate,
 112                       SCM_CLASS_DEFAULT_CPL);
 113 
 114 /* Basic metaobjects */
 115 SCM_DEFINE_BASE_CLASS(Scm_ClassClass, ScmClass,
 116                       class_print, NULL, NULL, class_allocate,
 117                       SCM_CLASS_OBJECT_CPL);
 118 SCM_DEFINE_BASE_CLASS(Scm_GenericClass, ScmGeneric,
 119                       generic_print, NULL, NULL, generic_allocate,
 120                       SCM_CLASS_OBJECT_CPL);
 121 SCM_DEFINE_BASE_CLASS(Scm_MethodClass, ScmMethod,
 122                       method_print, NULL, NULL, method_allocate,
 123                       SCM_CLASS_OBJECT_CPL);
 124 
 125 /* Internally used classes */
 126 SCM_DEFINE_BUILTIN_CLASS(Scm_SlotAccessorClass,
 127                          slot_accessor_print, NULL, NULL,
 128                          slot_accessor_allocate,
 129                          SCM_CLASS_DEFAULT_CPL);
 130 SCM_DEFINE_BUILTIN_CLASS(Scm_AccessorMethodClass,
 131                          accessor_method_print, NULL, NULL,
 132                          method_allocate,
 133                          Scm_MethodCPL);
 134 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_NextMethodClass, next_method_print);
 135 
 136 /* Builtin generic functions */
 137 SCM_DEFINE_GENERIC(Scm_GenericMake, Scm_NoNextMethod, NULL);
 138 SCM_DEFINE_GENERIC(Scm_GenericAllocate, Scm_NoNextMethod, NULL);
 139 SCM_DEFINE_GENERIC(Scm_GenericInitialize, builtin_initialize, NULL);
 140 SCM_DEFINE_GENERIC(Scm_GenericAddMethod, Scm_NoNextMethod, NULL);
 141 SCM_DEFINE_GENERIC(Scm_GenericDeleteMethod, Scm_NoNextMethod, NULL);
 142 SCM_DEFINE_GENERIC(Scm_GenericComputeCPL, Scm_NoNextMethod, NULL);
 143 SCM_DEFINE_GENERIC(Scm_GenericComputeSlots, Scm_NoNextMethod, NULL);
 144 SCM_DEFINE_GENERIC(Scm_GenericComputeGetNSet, Scm_NoNextMethod, NULL);
 145 SCM_DEFINE_GENERIC(Scm_GenericComputeApplicableMethods, Scm_NoNextMethod, NULL);
 146 SCM_DEFINE_GENERIC(Scm_GenericUpdateDirectMethod, Scm_NoNextMethod, NULL);
 147 SCM_DEFINE_GENERIC(Scm_GenericApplyGeneric, Scm_NoNextMethod, NULL);
 148 SCM_DEFINE_GENERIC(Scm_GenericMethodMoreSpecificP, Scm_NoNextMethod, NULL);
 149 SCM_DEFINE_GENERIC(Scm_GenericSlotMissing, Scm_NoNextMethod, NULL);
 150 SCM_DEFINE_GENERIC(Scm_GenericSlotUnbound, Scm_NoNextMethod, NULL);
 151 SCM_DEFINE_GENERIC(Scm_GenericSlotRefUsingClass, Scm_NoNextMethod, NULL);
 152 SCM_DEFINE_GENERIC(Scm_GenericSlotSetUsingClass, Scm_NoNextMethod, NULL);
 153 SCM_DEFINE_GENERIC(Scm_GenericSlotBoundUsingClassP, Scm_NoNextMethod, NULL);
 154 SCM_DEFINE_GENERIC(Scm_GenericObjectEqualP, Scm_NoNextMethod, NULL);
 155 SCM_DEFINE_GENERIC(Scm_GenericObjectCompare, Scm_NoNextMethod, NULL);
 156 SCM_DEFINE_GENERIC(Scm_GenericObjectHash, Scm_NoNextMethod, NULL);
 157 SCM_DEFINE_GENERIC(Scm_GenericObjectApply, Scm_InvalidApply, NULL);
 158 SCM_DEFINE_GENERIC(Scm_GenericObjectSetter, Scm_InvalidApply, NULL);
 159 SCM_DEFINE_GENERIC(Scm_GenericChangeClass, Scm_NoNextMethod, NULL);
 160 
 161 /* Some frequently-used pointers */
 162 static ScmObj key_allocation     = SCM_FALSE;
 163 static ScmObj key_slot_accessor  = SCM_FALSE;
 164 static ScmObj key_builtin        = SCM_FALSE;
 165 static ScmObj key_name           = SCM_FALSE;
 166 static ScmObj key_lambda_list    = SCM_FALSE;
 167 static ScmObj key_generic        = SCM_FALSE;
 168 static ScmObj key_specializers   = SCM_FALSE;
 169 static ScmObj key_body           = SCM_FALSE;
 170 
 171 /* A global lock to serialize class redefinition.  We need it since
 172    class redefinition is not a local effect---it propagates through
 173    its subclasses.  So it is pretty difficult to guarantee consistency
 174    if two threads enter the class redefinition, even if they redefine
 175    different classes.
 176    This lock works as a recursive lock.  Scm_StartClassRedefinition
 177    increments the lock count, and Scm_CommitClassRedefinition decrements it.
 178 */
 179 static struct {
 180     ScmVM             *owner;   /* thread that grabs the lock, or NULL */
 181     int               count;
 182     ScmInternalMutex  mutex;
 183     ScmInternalCond   cv;
 184 } class_redefinition_lock = { NULL, -1 }; /* we initialize other than zero,
 185                                              to ensure this sturcture is
 186                                              placed in the data area */
 187 
 188 /*=====================================================================
 189  * Auxiliary utilities
 190  */
 191 
 192 static ScmClass **class_list_to_array(ScmObj classes, int len)
 193 {
 194     ScmObj cp;
 195     ScmClass **v, **vp;
 196     v = vp = SCM_NEW_ARRAY(ScmClass*, len+1);
 197     SCM_FOR_EACH(cp, classes) {
 198         if (!Scm_TypeP(SCM_CAR(cp), SCM_CLASS_CLASS))
 199             Scm_Error("list of classes required, but found non-class object"
 200                       " %S in %S", SCM_CAR(cp), classes);
 201         *vp++ = SCM_CLASS(SCM_CAR(cp));
 202     }
 203     *vp = NULL;
 204     return v;
 205 }
 206 
 207 static ScmObj class_array_to_list(ScmClass **array, int len)
 208 {
 209     ScmObj h = SCM_NIL, t = SCM_NIL;
 210     if (array) while (len-- > 0) SCM_APPEND1(h, t, SCM_OBJ(*array++));
 211     return h;
 212 }
 213 
 214 static ScmObj class_array_to_names(ScmClass **array, int len)
 215 {
 216     ScmObj h = SCM_NIL, t = SCM_NIL;
 217     int i;
 218     for (i=0; i<len; i++, array++) SCM_APPEND1(h, t, (*array)->name);
 219     return h;
 220 }
 221 
 222 /* If the class name has brackets '<' and '>', as in Gauche's convention,
 223    returns a string without those brackets.  Otherwise returns the class
 224    name.  This is used by some print method. */
 225 ScmObj Scm__InternalClassName(ScmClass *klass)
 226 {
 227     ScmObj name = klass->name;
 228     int size;
 229 
 230     if (SCM_SYMBOLP(name)) {
 231         const ScmStringBody *b = SCM_STRING_BODY(SCM_SYMBOL_NAME(name));
 232         if (((size = SCM_STRING_BODY_SIZE(b)) > 2)
 233             && SCM_STRING_BODY_START(b)[0] == '<'
 234             && SCM_STRING_BODY_START(b)[size-1] == '>') {
 235             return Scm_Substring(SCM_SYMBOL_NAME(name), 1,
 236                                  SCM_STRING_BODY_LENGTH(b)-1);
 237         }
 238     }
 239     return name;
 240 }
 241 
 242 /*=====================================================================
 243  * Class metaobject
 244  */
 245 
 246 /* One of the design goals of Gauche object system is to make Scheme-defined
 247  * class easily accessible from C code, and vice versa.
 248  *
 249  * Class is implemented in two layers; Scheme layer and C layer.  The two
 250  * layers work together to realize efficient MOP.   In the following
 251  * description, (FOOBAR baz) indicates Scheme call where FooBar(baz) indicates
 252  * C call.
 253  *
 254  * Class instantiation is handled as follows.
 255  *
 256  *  (MAKE class . initargs)
 257  *    If class is a descendant of <class> eventually this calls
 258  *    a method (MAKE <class> . initargs).
 259  *
 260  *  (MAKE <class> . initargs)
 261  *    Defined in lib/gauche/object.scm.  This calls
 262  *    (ALLOCATE-INSTANCE <class> initargs), then
 263  *    (INITIALIZE obj initargs).
 264  *
 265  *  (ALLOCATE-INSTANCE <class> <list>)
 266  *    This is a C-defined method, and calls allocate() below.
 267  *
 268  *  static ScmObj allocate(ScmNextMethod *, ScmObj *, int, void*)
 269  *    The default allocation dispatcher.   This calls class->allocate().
 270  *    Some builtin function doesn't allow instantiation from Scheme and
 271  *    sets class->allocate() to NULL; an error is raised in such case.
 272  *
 273  *    The class->allocate() function usually allocates the instance
 274  *    (Scm*** structure) and initializes its slots with reasonable values.
 275  *    For example, if class is <class>, class->allocate allocates
 276  *    ScmClass structure.  If the class allows subclassing, class->allocate
 277  *    must allocate extra storage for as many slots as class->numInstanceSlots.
 278  *
 279  *    The allocated and set up structure is returned as ScmObj, which
 280  *    eventually retured by (ALLOCATE-INSTANCE ...) method, and passed to
 281  *    (INITIALIZE obj initargs) structure.
 282  *
 283  *  (INITIALIZE obj initargs)
 284  *    In most cases this method is defined in Scheme, if ever defined.
 285  *    The Scheme method does whatever it want, but it must call
 286  *    (NEXT-METHOD) in it, and it eventually calls the C-defined fallback
 287  *    method buildin_initialize().
 288  *
 289  *  ScmObj builtin_initialize(ScmObj *, int, ScmGeneric*)
 290  *    This function traverses the slot accessors, and if the slot has
 291  *    not been initialized, initialize it as specified in initargs or
 292  *    slot options.
 293  */
 294 
 295 /* Defining builtin class in C.
 296  *
 297  *    Defining classes in C is devided in two steps.  First, you have to
 298  *    define the static part of the class; it is done by one of the
 299  *    SCM_DEFINE_***_CLASS macros provided in gauche.h, and it defines
 300  *    static instance of ScmClass structure.  Then, in the initialization
 301  *    phase, you have to call Scm_InitStaticClass to initialize the dynamic
 302  *    part of the structure.
 303  *
 304  *      void Scm_InitStaticClass(ScmClass *klass, const char *name,
 305  *                               ScmModule *mod,
 306  *                               ScmClassStaticSlotSpec *slots,
 307  *                               int flags)
 308  *
 309  *         This function fills the ScmClass structure that can't be
 310  *         defined statically, and inserts the binding from the named
 311  *         symbol to the class object in the specified module.
 312  *         The 'flags' arg is reserved for future use, and must be 0
 313  *         for the time being.
 314  *
 315  *    See comments in gauche.h (around "Class categories") about
 316  *    the categories of C-defined classes.
 317  */
 318 
 319 /*
 320  * Built-in protocols
 321  *
 322  *  ScmObj klass->allocate(ScmClass *klass, ScmObj initargs)
 323  *     Called at the bottom of the chain of allocate-instance method.
 324  *     Besides allocating the required space, it must initialize
 325  *     members of the C-specific part of the instance, including SCM_HEADER.
 326  *     This protocol can be NULL for core base classes; if so, attempt
 327  *     to "make" such class reports an error.
 328  *
 329  *  void klass->print(ScmObj obj, ScmPort *sink, ScmWriteContext *ctx)
 330  *     OBJ is an instance of klass (you can safely assume it).  This
 331  *     function should print OBJ into SINK.  See write.c about the
 332  *     details of the context.
 333  *     If this function pointer is not set, a default print method
 334  *     is used.
 335  *
 336  *  int klass->compare(ScmObj x, ScmObj y, int equalp)
 337  *     X and Y are instances of klass.  If equalp is FALSE, 
 338  *     return -1, 0, or 1, when X < Y, X == Y or X > Y, respectively.
 339  *     In case if klass is not orderable, it can signal an error.
 340  *     If equalp is TRUE, just test the equality: return -1 if X != Y
 341  *     and 0 if X == Y.
 342  *
 343  *  int klass->serialize(ScmObj obj, ScmPort *sink, ScmObj table)
 344  *     OBJ is an instance of klass.  This method is only called when OBJ
 345  *     has not been output in the current serializing session.
 346  */
 347 
 348 /* A note on the 'data' member of ScmClass
 349  *
 350  *   It can be used to hang an opaque data to a specific class.  So far,
 351  *   we use it only for <simple> class mechanism.  Its use is highly
 352  *   controversial; I mean, The Right Thing is to define a metaclass
 353  *   which defines an extra member, and allocate <simple> class as an
 354  *   instance of it.  However, creating metaclass from C is messy now,
 355  *   so I chose to hack.  In future we may have a nice C API to create
 356  *   a metaclass, and then we may remove this 'data' member.  So DO NOT
 357  *   RELY ON ITS EXISTENCE.
 358  */
 359 
 360 /*
 361  * Class metaobject protocol implementation
 362  */
 363 
 364 /* Allocate class structure.  klass is a metaclass. */
 365 static ScmObj class_allocate(ScmClass *klass, ScmObj initargs)
 366 {
 367     ScmClass *instance = SCM_ALLOCATE(ScmClass, klass);
 368     SCM_SET_CLASS(instance, klass);
 369     instance->allocate = NULL;  /* will be set when CPL is set */
 370     instance->print = NULL;
 371     instance->compare = object_compare;
 372     instance->serialize = NULL; /* class_serialize? */
 373     instance->cpa = NULL;
 374     instance->numInstanceSlots = 0; /* will be adjusted in class init */
 375     instance->coreSize = 0;     /* will be set when CPL is set */
 376     instance->flags = SCM_CLASS_SCHEME; /* default */
 377     instance->name = SCM_FALSE;
 378     instance->directSupers = SCM_NIL;
 379     instance->accessors = SCM_NIL;
 380     instance->cpl = SCM_NIL;
 381     instance->directSlots = SCM_NIL;
 382     instance->slots = SCM_NIL;
 383     instance->directSubclasses = SCM_NIL;
 384     instance->directMethods = SCM_NIL;
 385     instance->initargs = SCM_NIL;
 386     instance->modules = SCM_NIL;
 387     instance->redefined = SCM_FALSE;
 388     (void)SCM_INTERNAL_MUTEX_INIT(instance->mutex);
 389     (void)SCM_INTERNAL_COND_INIT(instance->cv);
 390     instance->data = NULL;      /* see the above note on the 'data' member */
 391     return SCM_OBJ(instance);
 392 }
 393 
 394 static void class_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx) 
 395 {
 396     Scm_Printf(port, "#<class %A>", SCM_CLASS(obj)->name);
 397 }
 398 
 399 /*
 400  * (make <class> ...)   - default method to make a class instance.
 401  */
 402 
 403 /* defined in Scheme */
 404 
 405 /*
 406  * (allocate-instance <class> initargs)
 407  */
 408 static ScmObj allocate(ScmNextMethod *nm, ScmObj *args, int nargs, void *d)
 409 {
 410     ScmClass *c = SCM_CLASS(args[0]);
 411     if (c->allocate == NULL) {
 412         Scm_Error("built-in class can't be allocated via allocate-instance: %S",
 413                   SCM_OBJ(c));
 414     }
 415     return c->allocate(c, args[1]);
 416 }
 417 
 418 static ScmClass *class_allocate_SPEC[] = {
 419     SCM_CLASS_STATIC_PTR(Scm_ClassClass), SCM_CLASS_STATIC_PTR(Scm_ListClass)
 420 };
 421 static SCM_DEFINE_METHOD(class_allocate_rec, &Scm_GenericAllocate,
 422                          2, 0, class_allocate_SPEC, allocate, NULL);
 423 
 424 /*
 425  * (compute-cpl <class>)
 426  */
 427 static ScmObj class_compute_cpl(ScmNextMethod *nm, ScmObj *args, int nargs,
 428                                 void *d)
 429 {
 430     ScmClass *c = SCM_CLASS(args[0]);
 431     return Scm_ComputeCPL(c);
 432 }
 433 
 434 static ScmClass *class_compute_cpl_SPEC[] = {
 435     SCM_CLASS_STATIC_PTR(Scm_ClassClass)
 436 };
 437 static SCM_DEFINE_METHOD(class_compute_cpl_rec, &Scm_GenericComputeCPL,
 438                          1, 0, class_compute_cpl_SPEC,
 439                          class_compute_cpl, NULL);
 440 
 441 /*
 442  * (class-of obj)
 443  */
 444 
 445 ScmClass *Scm_ClassOf(ScmObj obj)
 446 {
 447     if (!SCM_PTRP(obj)) {
 448         if (SCM_TRUEP(obj) || SCM_FALSEP(obj)) return SCM_CLASS_BOOL;
 449         if (SCM_NULLP(obj)) return SCM_CLASS_NULL;
 450         if (SCM_CHARP(obj)) return SCM_CLASS_CHAR;
 451         if (SCM_INTP(obj))  return SCM_CLASS_INTEGER;
 452         if (SCM_EOFP(obj))  return SCM_CLASS_EOF_OBJECT;
 453         if (SCM_UNDEFINEDP(obj)) return SCM_CLASS_UNDEFINED_OBJECT;
 454         else return SCM_CLASS_UNKNOWN;
 455     } else if (SCM_PAIRP(obj)) {
 456         return SCM_CLASS_PAIR;
 457     } else {
 458         return SCM_CLASS_OF(obj);
 459     }
 460 }
 461 
 462 /* Returns the pointer of the first base class found in the given
 463    class's CPA.  If the class is pure abstract or builtin, NULL is
 464    returned. */
 465 ScmClass *Scm_BaseClassOf(ScmClass *klass)
 466 {
 467     ScmClass **cp = klass->cpa;
 468     ScmClass *k;
 469     while ((k = *cp++) != NULL) {
 470         if (SCM_CLASS_CATEGORY(k) == SCM_CLASS_BASE) {
 471             return k;
 472         }
 473     }
 474     return NULL;
 475 }
 476 
 477 /*
 478  * (class-of obj class)
 479  *   - if obj's class is redefined, first updates obj.
 480  */
 481 ScmObj class_of_cc(ScmObj result, void **data)
 482 {
 483     return Scm_VMClassOf(result);
 484 }
 485 
 486 ScmObj Scm_VMClassOf(ScmObj obj)
 487 {
 488     ScmClass *k = Scm_ClassOf(obj);
 489     if (!SCM_FALSEP(k->redefined)) {
 490         Scm_VMPushCC(class_of_cc, NULL, 0);
 491         return instance_class_redefinition(obj, k);
 492     }
 493     return SCM_OBJ(k);
 494 }
 495 
 496 /*
 497  * (is-a? obj class)
 498  *   - if obj's class is redefined, first updates obj.
 499  */
 500 ScmObj is_a_cc(ScmObj result, void **data)
 501 {
 502     return Scm_VMIsA(SCM_OBJ(data[0]), SCM_CLASS(data[1]));
 503 }
 504 
 505 ScmObj Scm_VMIsA(ScmObj obj, ScmClass *klass)
 506 {
 507     ScmClass *k = Scm_ClassOf(obj);
 508     if (!SCM_FALSEP(k->redefined)) {
 509         void *data[2];
 510         data[0] = obj;
 511         data[1] = klass;
 512         Scm_VMPushCC(is_a_cc, data, 2);
 513         return instance_class_redefinition(obj, k);
 514     }
 515     return SCM_MAKE_BOOL(Scm_TypeP(obj, klass));
 516 }
 517 
 518 /*--------------------------------------------------------------
 519  * Metainformation accessors
 520  */
 521 /* TODO: disable modification of system-builtin classes */
 522 
 523 static ScmObj class_name(ScmClass *klass)
 524 {
 525     return klass->name;
 526 }
 527 
 528 static void class_name_set(ScmClass *klass, ScmObj val)
 529 {
 530     klass->name = val;
 531 }
 532 
 533 static ScmObj class_cpl(ScmClass *klass)
 534 {
 535     return klass->cpl;
 536 }
 537 
 538 static void class_cpl_set(ScmClass *klass, ScmObj val)
 539 {
 540     /* have to make sure things are consistent */
 541     int len, object_inherited = FALSE, applicable = FALSE;
 542     ScmObj cp;
 543     ScmClass **p;
 544 
 545     if (!SCM_PAIRP(val)) goto err;
 546     /* check if the CPL begins with the class itself. */
 547     if (SCM_CAR(val) != SCM_OBJ(klass)) goto err;
 548 
 549     /* set up the cpa */
 550     cp = SCM_CDR(val);
 551     if ((len = Scm_Length(cp)) < 0) goto err;
 552     klass->cpa = class_list_to_array(cp, len);
 553     if (klass->cpa[len-1] != SCM_CLASS_TOP) goto err;
 554     klass->cpl = Scm_CopyList(val);
 555     /* find correct allocation method */
 556     klass->allocate = NULL;
 557     for (p = klass->cpa; *p; p++) {
 558         if ((*p)->allocate) {
 559             if ((*p)->allocate != Scm_ObjectAllocate) {
 560                 if (klass->allocate && klass->allocate != (*p)->allocate) {
 561                     Scm_Error("class precedence list has more than one C-defined base class (except <object>): %S", val);
 562                 }
 563                 klass->allocate = (*p)->allocate;
 564                 klass->coreSize = (*p)->coreSize;
 565             } else {
 566                 object_inherited = TRUE;
 567             }
 568         }
 569         if ((*p)->flags & SCM_CLASS_APPLICABLE) {
 570             applicable = TRUE;
 571         }
 572     }
 573     if (!object_inherited) {
 574         Scm_Error("class precedence list doesn't have a base class: %S", val);
 575     }
 576     if (!klass->allocate) {
 577         klass->allocate = Scm_ObjectAllocate; /* default */
 578         klass->coreSize = sizeof(ScmInstance);
 579     }
 580     if (applicable) {
 581         klass->flags |= SCM_CLASS_APPLICABLE;
 582     }
 583     return;
 584   err:
 585     Scm_Error("class precedence list must be a proper list of class "
 586               "metaobject, beginning from the class itself owing the list, "
 587               "and ending by the class <top>: %S", val);
 588 }
 589 
 590 static ScmObj class_direct_supers(ScmClass *klass)
 591 {
 592     return klass->directSupers;
 593 }
 594 
 595 static void class_direct_supers_set(ScmClass *klass, ScmObj val)
 596 {
 597     ScmObj vp;
 598     SCM_FOR_EACH(vp, val) {
 599         if (!Scm_TypeP(SCM_CAR(vp), SCM_CLASS_CLASS))
 600             Scm_Error("non-class object found in direct superclass list: %S",
 601                       SCM_CAR(vp));
 602     }
 603     klass->directSupers = val;
 604 }
 605 
 606 static ScmObj class_direct_slots(ScmClass *klass)
 607 {
 608     return klass->directSlots;
 609 }
 610 
 611 static void class_direct_slots_set(ScmClass *klass, ScmObj val)
 612 {
 613     ScmObj vp;
 614     SCM_FOR_EACH(vp, val) {
 615         if (!SCM_PAIRP(SCM_CAR(vp)))
 616             Scm_Error("bad slot spec found in direct slot list: %S",
 617                       SCM_CAR(vp));
 618     }
 619     klass->directSlots = val;
 620 }
 621 
 622 static ScmObj class_slots_ref(ScmClass *klass)
 623 {
 624     return klass->slots;
 625 }
 626 
 627 static void class_slots_set(ScmClass *klass, ScmObj val)
 628 {
 629     ScmObj vp;
 630     SCM_FOR_EACH(vp, val) {
 631         if (!SCM_PAIRP(SCM_CAR(vp)))
 632             Scm_Error("bad slot spec found in slot list: %S",
 633                       SCM_CAR(vp));
 634     }
 635     klass->slots = val;
 636 }
 637 
 638 static ScmObj class_accessors(ScmClass *klass)
 639 {
 640     return klass->accessors;
 641 }
 642 
 643 static void class_accessors_set(ScmClass *klass, ScmObj val)
 644 {
 645     ScmObj vp;
 646     SCM_FOR_EACH(vp, val) {
 647         if (!SCM_PAIRP(SCM_CAR(vp))
 648             || !SCM_SLOT_ACCESSOR_P(SCM_CDAR(vp)))
 649             Scm_Error("slot accessor list must be an assoc-list of slot name and slot accessor object, but found: %S",
 650                       SCM_CAR(vp));
 651     }
 652     klass->accessors = val;
 653 }
 654 
 655 static ScmObj class_numislots(ScmClass *klass)
 656 {
 657     return Scm_MakeInteger(klass->numInstanceSlots);
 658 }
 659 
 660 static void class_numislots_set(ScmClass *klass, ScmObj snf)
 661 {
 662     int nf = 0;
 663     if (!SCM_INTP(snf) || (nf = SCM_INT_VALUE(snf)) < 0) {
 664         Scm_Error("invalid argument: %S", snf);
 665         /*NOTREACHED*/
 666     }
 667     klass->numInstanceSlots = nf;
 668 }
 669 
 670 static ScmObj class_category(ScmClass *klass)
 671 {
 672     switch (SCM_CLASS_CATEGORY(klass)) {
 673     case SCM_CLASS_BUILTIN:  return SCM_SYM_BUILTIN;
 674     case SCM_CLASS_ABSTRACT: return SCM_SYM_ABSTRACT;
 675     case SCM_CLASS_BASE:     return SCM_SYM_BASE;
 676     default:                 return SCM_SYM_SCHEME;
 677     }
 678 }
 679 
 680 static ScmObj class_initargs(ScmClass *klass)
 681 {
 682     return klass->initargs;
 683 }
 684 
 685 static void class_initargs_set(ScmClass *klass, ScmObj val)
 686 {
 687     int len = Scm_Length(val);
 688     if (len < 0 || len%2 != 0) {
 689         Scm_Error("class-initargs must be a list of even number of elements, but got %S", val);
 690     }
 691     klass->initargs = val;
 692 }
 693 
 694 static ScmObj class_defined_modules(ScmClass *klass)
 695 {
 696     return klass->modules;
 697 }
 698 
 699 static void class_defined_modules_set(ScmClass *klass, ScmObj val)
 700 {
 701     ScmObj cp;
 702     SCM_FOR_EACH(cp, val) {
 703         if (!SCM_MODULEP(SCM_CAR(cp))) goto err;
 704     }
 705     if (!SCM_NULLP(cp)) goto err;
 706     klass->modules = val;
 707     return;
 708   err:
 709     Scm_Error("list of modules required, bot got %S", val);
 710 }
 711 
 712 /* 
 713  * The following slots should only be modified by a special MT-safe procedures.
 714  */
 715 static ScmObj class_direct_subclasses(ScmClass *klass)
 716 {
 717     return klass->directSubclasses;
 718 }
 719 
 720 static ScmObj class_direct_methods(ScmClass *klass)
 721 {
 722     return klass->directMethods;
 723 }
 724 
 725 static ScmObj class_redefined(ScmClass *klass)
 726 {
 727     ScmObj r;
 728     int abandoned = FALSE;
 729     
 730     /* If this class is being redefined by other thread, you should wait */
 731     (void)SCM_INTERNAL_MUTEX_LOCK(klass->mutex);
 732     while (SCM_VMP(klass->redefined)) {
 733         if (SCM_VM(klass->redefined)->state == SCM_VM_TERMINATED) {
 734             /* TODO: this means redefinition of klass has been abandoned,
 735                so the state of klass may be inconsistent.  Should we do
 736                something to it? */
 737             abandoned = TRUE;
 738             klass->redefined = SCM_FALSE;
 739         } else {
 740             (void)SCM_INTERNAL_COND_WAIT(klass->cv, klass->mutex);
 741         }
 742     }
 743     r = klass->redefined;
 744     (void)SCM_INTERNAL_MUTEX_UNLOCK(klass->mutex);
 745     if (abandoned) {
 746         Scm_Warn("redefinition of class %S has been abandoned", klass);
 747     }
 748     return r;
 749 }
 750 
 751 /*--------------------------------------------------------------
 752  * Implicit metaclass
 753  */
 754 /* This function does the equivalent to
 755  *  (make <class> :name NAME :supers (list <class>))
 756  */
 757 
 758 static ScmClass *make_implicit_meta(const char *name,
 759                                     ScmClass **cpa,
 760                                     ScmModule *mod)
 761 {
 762     ScmClass *meta = (ScmClass*)class_allocate(SCM_CLASS_CLASS, SCM_NIL);
 763     ScmObj s = SCM_INTERN(name);
 764     static ScmClass *metacpa[] = { SCM_CLASS_CLASS, SCM_CLASS_OBJECT, SCM_CLASS_TOP, NULL };
 765     ScmClass **metas = metacpa;
 766 
 767     /* check to see if parent class has also metaclass, and if so,
 768        adds it to the CPA.  We know all the builtin classes use
 769        single inheritance, so the CPA calculation should be straightforward.
 770        Note that this assumes the parent classes are already initialized.
 771     */
 772     {
 773         ScmClass **parent;
 774         int numExtraMetas = 0, i;
 775         for (parent = cpa; *parent; parent++) {
 776             if (SCM_CLASS_OF(*parent) != SCM_CLASS_CLASS) {
 777                 numExtraMetas++;
 778             }
 779         }
 780         if (numExtraMetas) {
 781             metas = SCM_NEW_ARRAY(ScmClass*, numExtraMetas+4);
 782             for (i = 0, parent = cpa; *parent; parent++) {
 783                 if (SCM_CLASS_OF(*parent) != SCM_CLASS_CLASS) {
 784                     metas[i++] = SCM_CLASS_OF(*parent);
 785                 }
 786             }
 787             metas[i++] = SCM_CLASS_CLASS;
 788             metas[i++] = SCM_CLASS_OBJECT;
 789             metas[i++] = SCM_CLASS_TOP;
 790             metas[i] = NULL;
 791         }
 792     }
 793 
 794     meta->name = s;
 795     meta->allocate = class_allocate;
 796     meta->print = class_print;
 797     meta->cpa = metas;
 798     meta->flags = SCM_CLASS_ABSTRACT;
 799     initialize_builtin_cpl(meta, SCM_FALSE);
 800     Scm_Define(mod, SCM_SYMBOL(s), SCM_OBJ(meta));
 801     meta->slots = Scm_ClassClass.slots;
 802     meta->accessors = Scm_ClassClass.accessors;
 803     return meta;
 804 }
 805 
 806 /*--------------------------------------------------------------
 807  * External interface
 808  */
 809 
 810 int Scm_SubtypeP(ScmClass *sub, ScmClass *type)
 811 {
 812     ScmClass **p;
 813     if (sub == type) return TRUE;
 814 
 815     p = sub->cpa;
 816     while (*p) {
 817         if (*p++ == type) return TRUE;
 818     }
 819     return FALSE;
 820 }
 821 
 822 int Scm_TypeP(ScmObj obj, ScmClass *type)
 823 {
 824     return Scm_SubtypeP(Scm_ClassOf(obj), type);
 825 }
 826 
 827 /*
 828  * compute-cpl
 829  */
 830 ScmObj Scm_ComputeCPL(ScmClass *klass)
 831 {
 832     ScmObj seqh = SCM_NIL, seqt = SCM_NIL, ds, dp, result;
 833 
 834     /* a trick to ensure we have <object> <top> at the end of CPL. */
 835     ds = Scm_Delete(SCM_OBJ(SCM_CLASS_OBJECT), klass->directSupers,
 836                     SCM_CMP_EQ);
 837     ds = Scm_Delete(SCM_OBJ(SCM_CLASS_TOP), ds, SCM_CMP_EQ);
 838     ds = Scm_Append2(ds, SCM_LIST1(SCM_OBJ(SCM_CLASS_OBJECT)));
 839 
 840     SCM_FOR_EACH(dp, klass->directSupers) {
 841         if (!Scm_TypeP(SCM_CAR(dp), SCM_CLASS_CLASS))
 842             Scm_Error("non-class found in direct superclass list: %S",
 843                       klass->directSupers);
 844         if (SCM_CAR(dp) == SCM_OBJ(SCM_CLASS_OBJECT)
 845             || SCM_CAR(dp) == SCM_OBJ(SCM_CLASS_TOP))
 846             continue;
 847         SCM_APPEND1(seqh, seqt, SCM_CLASS(SCM_CAR(dp))->cpl);
 848     }
 849     SCM_APPEND1(seqh, seqt, Scm_ObjectClass.cpl);
 850 
 851     SCM_APPEND1(seqh, seqt, ds);
 852     
 853     result = Scm_MonotonicMerge(SCM_OBJ(klass), seqh);
 854     if (SCM_FALSEP(result))
 855         Scm_Error("discrepancy found in class precedence lists of the superclasses: %S",
 856                   klass->directSupers);
 857     return result;
 858 }
 859 
 860 /*
 861  * Internal procedures for class redefinition
 862  */
 863 
 864 /* global lock manipulation */
 865 static void lock_class_redefinition(ScmVM *vm)
 866 {
 867     ScmVM *stolefrom = NULL;
 868     if (class_redefinition_lock.owner == vm) {
 869         class_redefinition_lock.count++;
 870     } else {
 871         (void)SCM_INTERNAL_MUTEX_LOCK(class_redefinition_lock.mutex);
 872         while (class_redefinition_lock.owner != vm) {
 873             if (class_redefinition_lock.owner == NULL) {
 874                 class_redefinition_lock.owner = vm;
 875             } else if (class_redefinition_lock.owner->state
 876                        == SCM_VM_TERMINATED) {
 877                 stolefrom = class_redefinition_lock.owner;
 878                 class_redefinition_lock.owner = vm;
 879             } else {
 880                 (void)SCM_INTERNAL_COND_WAIT(class_redefinition_lock.cv,
 881                                              class_redefinition_lock.mutex);
 882             }
 883         }
 884         (void)SCM_INTERNAL_MUTEX_UNLOCK(class_redefinition_lock.mutex);
 885         if (stolefrom) {
 886             Scm_Warn("a thread holding class redefinition lock has been terminated: %S", stolefrom);
 887         }
 888         class_redefinition_lock.count = 0;
 889     }
 890 }
 891 
 892 static void unlock_class_redefinition(ScmVM *vm)
 893 {
 894     if (class_redefinition_lock.owner != vm) return;
 895     if (--class_redefinition_lock.count <= 0) {
 896         (void)SCM_INTERNAL_COND_BROADCAST(class_redefinition_lock.cv);
 897     }
 898 }
 899 
 900 /* %start-class-redefinition klass */
 901 void Scm_StartClassRedefinition(ScmClass *klass)
 902 {
 903     int success = FALSE;
 904     ScmVM *vm;
 905     
 906     if (SCM_CLASS_CATEGORY(klass) != SCM_CLASS_SCHEME) {
 907         Scm_Error("cannot redefine class %S, which is not a Scheme-defined class", klass);
 908     }
 909     vm = Scm_VM();
 910 
 911     /* First, acquire the global lock. */
 912     lock_class_redefinition(vm);
 913     
 914     /* Mark this class to be redefined. */
 915     (void)SCM_INTERNAL_MUTEX_LOCK(klass->mutex);
 916     if (SCM_FALSEP(klass->redefined)) {
 917         klass->redefined = SCM_OBJ(vm);
 918         success = TRUE;
 919     }
 920     (void)SCM_INTERNAL_MUTEX_UNLOCK(klass->mutex);
 921 
 922     if (!success) {
 923         unlock_class_redefinition(vm);
 924         Scm_Error("class %S seems abandoned during class redefinition", klass);
 925     }
 926 }
 927 
 928 /* %commit-class-redefinition klass newklass */
 929 void Scm_CommitClassRedefinition(ScmClass *klass, ScmObj newklass)
 930 {
 931     ScmVM *vm;
 932     
 933     if (SCM_CLASS_CATEGORY(klass) != SCM_CLASS_SCHEME) return;
 934     if (!SCM_FALSEP(newklass)&&!SCM_CLASSP(newklass)) {
 935         Scm_Error("class or #f required, but got %S", newklass);
 936     }
 937     
 938     vm = Scm_VM();
 939 
 940     /* Release the lock of the class.
 941        We execute this regardless of class_redefinition_lock.owner.
 942        Theoretically, this procedure shouldn't be called unless the thread
 943        owns global class_redefinition_lock.  However, we don't require it,
 944        so that this procedure can be used for a program to exit from
 945        obscure state. */
 946     (void)SCM_INTERNAL_MUTEX_LOCK(klass->mutex);
 947     if (SCM_EQ(klass->redefined, SCM_OBJ(vm))) {
 948         klass->redefined = newklass;
 949         (void)SCM_INTERNAL_COND_BROADCAST(klass->cv);
 950     }
 951     (void)SCM_INTERNAL_MUTEX_UNLOCK(klass->mutex);
 952 
 953     /* Decrement the recursive global lock. */
 954     unlock_class_redefinition(vm);
 955 }
 956 
 957 /* %check-class-binding name module
 958    See the bindings of name in module, and iff it is bound to a class,
 959    returns the class; otherwise returns #f.
 960    This can't be implemented in Scheme, since the class we're looking for
 961    may be set to autoload, and this function is invoked during the autoload
 962    process---in which case, the class hasn't defined yet, and referencing
 963    the value in Scheme triggers recursive autoload that is an error. */
 964 ScmObj Scm_CheckClassBinding(ScmObj name, ScmModule *module)
 965 {
 966     ScmObj v;
 967     if (!SCM_SYMBOLP(name)) return FALSE;
 968     v = Scm_SymbolValue(module, SCM_SYMBOL(name));
 969     return SCM_CLASSP(v) ? v : SCM_FALSE;
 970 }
 971 
 972 /* %replace-class-binding! klass newklass
 973    Called when a descendant of klass is redefined.  If klass has a global
 974    binding, replace it to newklass. */
 975 void Scm_ReplaceClassBinding(ScmClass *klass, ScmClass *newklass)
 976 {
 977     ScmObj cp;
 978     if (!SCM_SYMBOLP(klass->name)) return;
 979     SCM_FOR_EACH(cp, klass->modules) {
 980         if (!SCM_MODULEP(SCM_CAR(cp))) continue;
 981         Scm_Define(SCM_MODULE(SCM_CAR(cp)),
 982                    SCM_SYMBOL(klass->name),
 983                    SCM_OBJ(newklass));
 984     }
 985 }
 986 
 987 /* %add-direct-subclass! super sub */
 988 void Scm_AddDirectSubclass(ScmClass *super, ScmClass *sub)
 989 {
 990     if (SCM_CLASS_CATEGORY(super) == SCM_CLASS_SCHEME) {
 991         ScmObj p = Scm_Cons(SCM_OBJ(sub), SCM_NIL);
 992         (void)SCM_INTERNAL_MUTEX_LOCK(super->mutex);
 993         /* avoid duplication */
 994         if (SCM_FALSEP(Scm_Memq(super->directSubclasses, SCM_OBJ(sub)))) {
 995             SCM_SET_CDR(p, super->directSubclasses);
 996             super->directSubclasses = p;
 997         }
 998         (void)SCM_INTERNAL_MUTEX_UNLOCK(super->mutex);
 999     }
1000 }
1001 
1002 /* %delete-direct-subclass! super sub */
1003 void Scm_DeleteDirectSubclass(ScmClass *super, ScmClass *sub)
1004 {
1005     if (SCM_CLASS_CATEGORY(super) == SCM_CLASS_SCHEME) {
1006         (void)SCM_INTERNAL_MUTEX_LOCK(super->mutex);
1007         super->directSubclasses =
1008             Scm_DeleteX(SCM_OBJ(sub), super->directSubclasses, SCM_CMP_EQ);
1009         (void)SCM_INTERNAL_MUTEX_UNLOCK(super->mutex);
1010     }
1011 }
1012 
1013 /* %add-direct-method! super sub */
1014 void Scm_AddDirectMethod(ScmClass *super, ScmMethod *m)
1015 {
1016     if (SCM_CLASS_CATEGORY(super) == SCM_CLASS_SCHEME) {
1017         ScmObj p = Scm_Cons(SCM_OBJ(m), SCM_NIL);
1018         (void)SCM_INTERNAL_MUTEX_LOCK(super->mutex);
1019         /* avoid duplication */
1020         if (SCM_FALSEP(Scm_Memq(super->directMethods, SCM_OBJ(m)))) {
1021             SCM_SET_CDR(p, super->directMethods);
1022             super->directMethods = p;
1023         }
1024         (void)SCM_INTERNAL_MUTEX_UNLOCK(super->mutex);
1025     }
1026 }
1027 
1028 /* %delete-direct-method! super sub */
1029 void Scm_DeleteDirectMethod(ScmClass *super, ScmMethod *m)
1030 {
1031     if (SCM_CLASS_CATEGORY(super) == SCM_CLASS_SCHEME) {
1032         (void)SCM_INTERNAL_MUTEX_LOCK(super->mutex);
1033         super->directMethods =
1034             Scm_DeleteX(SCM_OBJ(m), super->directMethods, SCM_CMP_EQ);
1035         (void)SCM_INTERNAL_MUTEX_UNLOCK(super->mutex);
1036     }
1037 }
1038 
1039 /* %transplant-instance! src dst */
1040 /* Copies the contents of the core structure pointed by src over
1041    the contents of dst.  The contents of dst is destroyed.  This
1042    astonishingly dangerous operation has to be done at the last stage
1043    of change-class, in order to keep the identity of the instance
1044    being updated.
1045 
1046    Note that this procedure doesn't overwrite the Scheme slot
1047    vectors. */
1048 void Scm_TransplantInstance(ScmObj src, ScmObj dst)
1049 {
1050     ScmClass *srcklass = Scm_ClassOf(src);
1051     ScmClass *dstklass = Scm_ClassOf(dst);
1052     ScmClass *base;
1053 
1054     /* Extra check.  We can't transplant the contents to different
1055        an instance that has different base class. */
1056     if ((base = Scm_BaseClassOf(srcklass)) == NULL
1057         || !SCM_EQ(base, Scm_BaseClassOf(dstklass))) {
1058         Scm_Error("%%transplant-instance: classes are incompatible between %S and %S",
1059                   src, dst);
1060     }
1061     if (base->coreSize < sizeof(ScmInstance)) {
1062         Scm_Error("%%transplant-instance: baseclass is too small (implementation error?)");
1063     }
1064     memcpy(dst, src, base->coreSize);
1065 }
1066 
1067 /* touch-instance! obj 
1068  * If obj's class is redefined, update obj.  Otherwise it does nothing.
1069  * Handy to ensure obj is in the newest state.  Returns obj.
1070  */
1071 ScmObj Scm_VMTouchInstance(ScmObj obj)
1072 {
1073     ScmClass *klass = Scm_ClassOf(obj);
1074     if (!SCM_FALSEP(klass->redefined)) {
1075         return instance_class_redefinition(obj, klass);
1076     }
1077     return obj;
1078 }
1079 
1080 /*=====================================================================
1081  * Scheme slot access
1082  */
1083 
1084 /* Scheme slots are stored in ScmObj array pointed by slots field
1085  * of ScmInstance.  This one-level indirection allows an instance
1086  * to be redefined.
1087  */
1088 
1089 /* Unbound slot: if the slot value yields either SCM_UNBOUND or
1090  * SCM_UNDEFINED, a generic function slot-unbound is called.
1091  * We count SCM_UNDEFINED as unbound so that a Scheme program can
1092  * make slot unbound, especially needed for procedural slots.
1093  */
1094 
1095 /* A common routine to be used to allocate object.
1096    Coresize should be a size of base C structure in bytes.
1097    Klass may be a subclass.   If klass is inheritable by Scheme
1098    (i.e. it's category is either SCM_CLASS_BASE or SCM_CLASS_SCHEME),
1099    This routine also allocates a slot vector, and initializes the
1100    slot vector with SCM_UNBOUND.
1101    We don't care class redefinition at this point.  If the class is
1102    redefined simultaneously, it will be handled by the subsequent initialize
1103    method.
1104 */
1105 ScmObj Scm_AllocateInstance(ScmClass *klass, int coresize)
1106 {
1107     int i;
1108     ScmObj obj = SCM_NEW2(ScmObj, coresize);
1109     ScmObj *slots;
1110 
1111     if (SCM_CLASS_CATEGORY(klass) == SCM_CLASS_BASE
1112         || SCM_CLASS_CATEGORY(klass) == SCM_CLASS_SCHEME) {
1113         slots = SCM_NEW_ARRAY(ScmObj, klass->numInstanceSlots);
1114 
1115         /* NB: actually, for Scheme instances, 'coresize' argument is
1116            redundant since klass->coreSize has it.  There's a historical
1117            confusion in the class protocol.  We should clear it out someday.
1118         */
1119         if (coresize != klass->coreSize) {
1120             Scm_Printf(SCM_CURERR, "WARNING: allocating instance of class %S: coresize argument %d doesn't match the class definition's (%d)\n", klass, coresize, klass->coreSize);
1121         }
1122 
1123         for (i=0; i<klass->numInstanceSlots; i++) {
1124             slots[i] = SCM_UNBOUND;
1125         }
1126         SCM_INSTANCE(obj)->slots = slots;
1127     }
1128     return obj;
1129 }
1130 
1131 /* Invoke class redefinition method */
1132 static ScmObj instance_class_redefinition(ScmObj obj, ScmClass *old)
1133 {
1134     ScmObj newc;
1135     (void)SCM_INTERNAL_MUTEX_LOCK(old->mutex);
1136     while (!SCM_ISA(old->redefined, SCM_CLASS_CLASS)) {
1137         (void)SCM_INTERNAL_COND_WAIT(old->cv, old->mutex);
1138     }
1139     newc = old->redefined;
1140     (void)SCM_INTERNAL_MUTEX_UNLOCK(old->mutex);
1141     if (SCM_CLASSP(newc)) {
1142         return Scm_VMApply2(SCM_OBJ(&Scm_GenericChangeClass), obj, newc);
1143     } else {
1144         return SCM_OBJ(old);
1145     }
1146 }
1147 
1148 /* most primitive internal accessor */
1149 static inline ScmObj scheme_slot_ref(ScmObj obj, int number)
1150 {
1151     ScmClass *k = Scm_ClassOf(obj);
1152     if (number < 0 || number >= k->numInstanceSlots)
1153         Scm_Error("instance slot index %d out of bounds for %S", number, obj);
1154     return SCM_INSTANCE_SLOTS(obj)[number];
1155 }
1156 
1157 static inline void scheme_slot_set(ScmObj obj, int number, ScmObj val)
1158 {
1159     ScmClass *k = Scm_ClassOf(obj);
1160     if (number < 0 || number >= k->numInstanceSlots)
1161         Scm_Error("instance slot index %d out of bounds for %S", number, obj);
1162     SCM_INSTANCE_SLOTS(obj)[number] = val;
1163 }
1164 
1165 /* These two are exposed to Scheme to do some nasty things.
1166    We shoudn't do class redefinition check here, since the slot number
1167    is calculated based on the old class, if the class is ever redefined.
1168 */
1169 ScmObj Scm_InstanceSlotRef(ScmObj obj, int number)
1170 {
1171     return scheme_slot_ref(obj, number);
1172 }
1173 
1174 void Scm_InstanceSlotSet(ScmObj obj, int number, ScmObj val)
1175 {
1176     scheme_slot_set(obj, number, val);
1177 }
1178 
1179 /* Initialize a slot according to its accessor spec
1180    TODO: class redefintion check
1181 */
1182 static ScmObj slot_initialize_cc(ScmObj result, void **data)
1183 {
1184     ScmObj obj = data[0];
1185     ScmSlotAccessor *sa = SCM_SLOT_ACCESSOR(data[1]);
1186     return slot_set_using_accessor(obj, sa, result);
1187 }
1188 
1189 ScmObj Scm_VMSlotInitializeUsingAccessor(ScmObj obj,
1190                                          ScmSlotAccessor *sa,
1191                                          ScmObj initargs)
1192 {
1193     /* (1) see if we have init-keyword */
1194     if (SCM_KEYWORDP(sa->initKeyword)) {
1195         ScmObj v = Scm_GetKeyword(sa->initKeyword, initargs, SCM_UNDEFINED);
1196         if (!SCM_UNDEFINEDP(v)) {
1197             return slot_set_using_accessor(obj, sa, v);
1198         }
1199     }
1200     /* (2) use init-value or init-thunk, if this slot is initializable. */
1201     if (sa->initializable) {
1202         if (!SCM_UNBOUNDP(sa->initValue)) {
1203             return slot_set_using_accessor(obj, sa, sa->initValue);
1204         }
1205         if (SCM_PROCEDUREP(sa->initThunk)) {
1206             void *data[2];
1207             data[0] = (void*)obj;
1208             data[1] = (void*)sa;
1209             Scm_VMPushCC(slot_initialize_cc, data, 2);
1210             return Scm_VMApply(sa->initThunk, SCM_NIL);
1211         }
1212     }
1213     return SCM_UNDEFINED;
1214 }
1215 
1216 /*-------------------------------------------------------------------
1217  * slot-ref, slot-set! and families
1218  */
1219 
1220 /* helper macros */
1221 #define SLOT_UNBOUND(klass, obj, slot)                  \
1222     Scm_VMApply(SCM_OBJ(&Scm_GenericSlotUnbound),       \
1223                 SCM_LIST3(SCM_OBJ(klass), obj, slot))
1224 
1225 #define SLOT_MISSING3(klass, obj, slot)                 \
1226     Scm_VMApply(SCM_OBJ(&Scm_GenericSlotMissing),       \
1227                 SCM_LIST3(SCM_OBJ(klass), obj, slot))
1228 
1229 #define SLOT_MISSING4(klass, obj, slot, val)            \
1230     Scm_VMApply(SCM_OBJ(&Scm_GenericSlotMissing),       \
1231                 SCM_LIST4(SCM_OBJ(klass), obj, slot, val))
1232 
1233 /* GET-SLOT-ACCESSOR
1234  *
1235  * (define (get-slot-accessor class slot)
1236  *   (cond ((assq slot (ref class 'accessors)) => cdr)
1237  *         (else (error !!!))))
1238  */
1239 inline ScmSlotAccessor *Scm_GetSlotAccessor(ScmClass *klass, ScmObj slot)
1240 {
1241     ScmObj p = Scm_Assq(slot, klass->accessors);
1242     if (!SCM_PAIRP(p)) return NULL;
1243     if (!SCM_XTYPEP(SCM_CDR(p), SCM_CLASS_SLOT_ACCESSOR))
1244         Scm_Error("slot accessor information of class %S, slot %S is screwed up.",
1245                   SCM_OBJ(klass), slot);
1246     return SCM_SLOT_ACCESSOR(SCM_CDR(p));
1247 }
1248 
1249 /* (internal) slot-ref-using-accessor
1250  *
1251  * - assumes accessor belongs to the proper class.
1252  * - no class redefinition check is done
1253  */
1254 static ScmObj slot_ref_using_accessor_cc(ScmObj result, void **data)
1255 {
1256     ScmObj obj = data[0];
1257     ScmObj slot = data[1];
1258     int boundp = (data[2] != NULL);
1259 
1260     if (SCM_UNBOUNDP(result) || SCM_UNDEFINEDP(result)) {
1261         if (boundp)
1262             return SCM_FALSE;
1263         else 
1264             return SLOT_UNBOUND(Scm_ClassOf(obj), obj, slot);
1265     } else {
1266         if (boundp)
1267             return SCM_TRUE;
1268         else 
1269             return result;
1270     }
1271 }
1272 
1273 static ScmObj slot_boundp_using_accessor_cc(ScmObj result, void **data)
1274 {
1275     return SCM_FALSEP(result)? SCM_FALSE:SCM_TRUE;
1276 }
1277 
1278 static ScmObj slot_ref_using_accessor(ScmObj obj,
1279                                       ScmSlotAccessor *sa,
1280                                       int boundp)
1281 {
1282     ScmObj val = SCM_UNBOUND;
1283     if (sa->getter) {
1284         val = sa->getter(obj);
1285     } else if (sa->slotNumber >= 0) {
1286         val = scheme_slot_ref(obj, sa->slotNumber);
1287     } else if (boundp && SCM_PROCEDUREP(sa->schemeBoundp)) {
1288         void *data[3];
1289         data[0] = obj;
1290         data[1] = sa->name;
1291         data[2] = (void*)(long)boundp;
1292         Scm_VMPushCC(slot_boundp_using_accessor_cc, data, 3);
1293         return Scm_VMApply(sa->schemeBoundp, SCM_LIST1(obj));
1294     } else if (SCM_PROCEDUREP(sa->schemeGetter)) {
1295         void *data[3];
1296         data[0] = obj;
1297         data[1] = sa->name;
1298         data[2] = (void*)(long)boundp;
1299         Scm_VMPushCC(slot_ref_using_accessor_cc, data, 3);
1300         return Scm_VMApply(sa->schemeGetter, SCM_LIST1(obj));
1301     } else {
1302         Scm_Error("don't know how to retrieve value of slot %S of object %S (MOP error?)",
1303                   sa->name, obj);
1304     }
1305     if (boundp) {
1306         return SCM_MAKE_BOOL(!(SCM_UNBOUNDP(val) || SCM_UNDEFINEDP(val)));
1307     } else {
1308         if (SCM_UNBOUNDP(val) || SCM_UNDEFINEDP(val)) {
1309             return SLOT_UNBOUND(Scm_ClassOf(obj), obj, sa->name);
1310         } else {
1311             return val;
1312         }
1313     }
1314 }
1315 
1316 /* SLOT-REF
1317  *
1318  *(define (slot-ref obj slot bound-check?)
1319  *   (%check-class-redefined (class-of obj))
1320  *   (let ((sa (get-slot-accessor (class-of obj) slot)))
1321  *     (if sa
1322  *         (%internal-slot-ref-using-accessor obj sa bound-check?)
1323  *         (slot-missing (class-of obj) obj slot))))
1324  */
1325 static ScmObj slot_ref_cc(ScmObj result, void **data)
1326 {
1327     return Scm_VMSlotRef(SCM_OBJ(data[0]), SCM_OBJ(data[1]), (int)data[2]);
1328 }
1329 
1330 ScmObj Scm_VMSlotRef(ScmObj obj, ScmObj slot, int boundp)
1331 {
1332     ScmClass *klass = Scm_ClassOf(obj);
1333     ScmSlotAccessor *sa;
1334     void *data[3];
1335 
1336     if (!SCM_FALSEP(klass->redefined)) {
1337         data[0] = obj;
1338         data[1] = slot;
1339         data[2] = (void*)boundp;
1340         Scm_VMPushCC(slot_ref_cc, data, 3);
1341         return instance_class_redefinition(obj, klass);
1342     }
1343     sa = Scm_GetSlotAccessor(klass, slot);
1344     if (sa == NULL) return SLOT_MISSING3(klass, obj, slot);
1345     else            return slot_ref_using_accessor(obj, sa, boundp);
1346 }
1347 
1348 /* SLOT-REF-USING-ACCESSOR
1349  *
1350  * (define (slot-ref-using-accessor obj sa bound-check?)
1351  *   (%check-if-sa-is-valid-for-object obj sa)
1352  *   (%internal-slot-ref-using-accessor obj sa bound-check?))
1353  *
1354  * - no class redefinition check is performed.  if obj isn't updated
1355  *   for the new class, sa must come from the old class.
1356  */
1357 #if 0
1358 static ScmObj slot_ref_using_accessor_cc1(ScmObj result, void **data)
1359 {
1360     return Scm_VMSlotRefUsingAccessor(SCM_OBJ(data[0]),
1361                                       SCM_SLOT_ACCESSOR(data[1]),
1362                                       (int)data[2]);
1363 }
1364 #endif
1365 
1366 ScmObj Scm_VMSlotRefUsingAccessor(ScmObj obj, ScmSlotAccessor *sa, int boundp)
1367 {
1368     ScmClass *klass = Scm_ClassOf(obj);
1369     if (klass != sa->klass) {
1370         Scm_Error("attempt to use a slot accessor %S on the object of different class: %S",
1371                   SCM_OBJ(sa), obj);
1372     }
1373 #if 0
1374     if (!SCM_FALSEP(klass->redefined)) {
1375         void *data[3];
1376         data[0] = obj;
1377         data[1] = sa;
1378         data[2] = (void*)boundp;
1379         Scm_VMPushCC(slot_ref_using_accessor_cc1, data, 3);
1380         return instance_class_redefinition(obj, klass);
1381     }
1382 #endif
1383     return slot_ref_using_accessor(obj, sa, boundp);
1384 }
1385 
1386 /* SLOT-REF-USING-CLASS
1387  *
1388  * (define-method slot-ref-using-class
1389  *      ((class <class>) (obj <object>) slot)
1390  *   (unless (eq? (class-of obj) class) (error !!!))
1391  *   (let ((sa (get-slot-accessor class slot)))
1392  *     (if sa
1393  *         (%internal-slot-ref-using-accessor obj sa #f)
1394  *         (slot-missing class obj slot))))
1395  *
1396  * - no class redefinition check is performed.  if obj isn't updated,
1397  *   and class is an old class, then it can access to the old instance's
1398  *   slot value.
1399  */
1400 static ScmObj slot_ref_using_class(ScmNextMethod *nm, ScmObj *args,
1401                                    int nargs, void *d)
1402 {
1403     ScmClass *klass = SCM_CLASS(args[0]);
1404     ScmObj obj = args[1];
1405     ScmObj slot = args[2];
1406     ScmSlotAccessor *sa;
1407     
1408     if (!SCM_EQ(SCM_OBJ(klass), SCM_OBJ(Scm_ClassOf(obj)))) {
1409         Scm_Error("slot-ref-using-class: class %S is not the class of object %S", klass, obj);
1410     }
1411     sa = Scm_GetSlotAccessor(klass, slot);
1412     if (sa == NULL) return SLOT_MISSING3(klass, obj, slot);
1413     else            return slot_ref_using_accessor(obj, sa, FALSE);
1414 }
1415 
1416 static ScmClass *slot_ref_using_class_SPEC[] = {
1417     SCM_CLASS_STATIC_PTR(Scm_ClassClass),
1418     SCM_CLASS_STATIC_PTR(Scm_ObjectClass),
1419     SCM_CLASS_STATIC_PTR(Scm_TopClass)
1420 };
1421 static SCM_DEFINE_METHOD(slot_ref_using_class_rec,
1422                          &Scm_GenericSlotRefUsingClass,
1423                          3, 0, slot_ref_using_class_SPEC,
1424                          slot_ref_using_class, NULL);
1425 
1426 /* (internal) SLOT-SET-USING-ACCESSOR
1427  *
1428  * - assumes accessor belongs to the proper class.
1429  * - no class redefinition check is done
1430  */
1431 ScmObj slot_set_using_accessor(ScmObj obj,
1432                                ScmSlotAccessor *sa,
1433                                ScmObj val)
1434 {
1435     if (sa->setter) {
1436         sa->setter(obj, val);
1437     } else if (sa->slotNumber >= 0) {
1438         scheme_slot_set(obj, sa->slotNumber, val);
1439     } else if (SCM_PROCEDUREP(sa->schemeSetter)) {
1440         return Scm_VMApply(sa->schemeSetter, SCM_LIST2(obj, val));
1441     } else {
1442         Scm_Error("slot %S of class %S is read-only", sa->name,
1443                   SCM_OBJ(Scm_ClassOf(obj)));
1444     }
1445     return SCM_UNDEFINED;
1446 }
1447 
1448 /* SLOT-SET!
1449  *
1450  * (define (slot-set! obj slot val)
1451  *   (%check-class-redefined (class-of obj))
1452  *   (let ((sa (get-slot-accessor (class-of obj) slot)))
1453  *     (if sa
1454  *         (%internal-slot-set-using-accessor obj sa val)
1455  *         (slot-missing (class-of obj) obj slot val))))
1456  */
1457 static ScmObj slot_set_cc(ScmObj result, void **data)
1458 {
1459     return Scm_VMSlotSet(SCM_OBJ(data[0]), SCM_OBJ(data[1]), SCM_OBJ(data[2]));
1460 }
1461 
1462 ScmObj Scm_VMSlotSet(ScmObj obj, ScmObj slot, ScmObj val)
1463 {
1464     ScmClass *klass = Scm_ClassOf(obj);
1465     ScmSlotAccessor *sa;
1466     void *data[3];
1467     if (!SCM_FALSEP(klass->redefined)) {
1468         data[0] = obj;
1469         data[1] = slot;
1470         data[2] = val;
1471         Scm_VMPushCC(slot_set_cc, data, 3);
1472         return instance_class_redefinition(obj, klass);
1473     }
1474     sa = Scm_GetSlotAccessor(klass, slot);
1475     if (sa == NULL) return SLOT_MISSING4(klass, obj, slot, val);
1476     else            return slot_set_using_accessor(obj, sa, val);
1477 }
1478 
1479 /* SLOT-SET-USING-ACCESSOR
1480  *
1481  * (define (slot-set-using-accessor obj sa val)
1482  *   (%check-if-sa-is-valid-for-object obj sa)
1483  *   (%internal-slot-set-using-accessor obj sa val))
1484  *
1485  * - no class redefinition check is performed.  if obj isn't updated
1486  *   for the new class, sa must come from the old class.
1487  */
1488 #if 0
1489 static ScmObj slot_set_using_accessor_cc(ScmObj result, void **data)
1490 {
1491     return Scm_VMSlotSetUsingAccessor(SCM_OBJ(data[0]),
1492                                       SCM_SLOT_ACCESSOR(data[1]),
1493                                       SCM_OBJ(data[2]));
1494 }
1495 #endif
1496 
1497 ScmObj Scm_VMSlotSetUsingAccessor(ScmObj obj, ScmSlotAccessor *sa, ScmObj val)
1498 {
1499     ScmClass *klass = Scm_ClassOf(obj);
1500     if (klass != sa->klass) {
1501         Scm_Error("attempt to use a slot accessor %S on the object of different class: %S",
1502                   SCM_OBJ(sa), obj);
1503     }
1504 #if 0
1505     if (!SCM_FALSEP(klass->redefined)) {
1506         void *data[3];
1507         data[0] = obj;
1508         data[1] = sa;
1509         data[2] = val;
1510         Scm_VMPushCC(slot_set_using_accessor_cc, data, 3);
1511         return instance_class_redefinition(obj, klass);
1512     }
1513 #endif
1514     return slot_set_using_accessor(obj, sa, val);
1515 }
1516 
1517 /* SLOT-SET-USING-CLASS
1518  *
1519  * (define-method slot-set-using-class
1520  *      ((class <class>) (obj <object>) slot val)
1521  *   (unless (eq? (class-of obj) class) (error !!!))
1522  *   (let ((sa (get-slot-accessor class slot)))
1523  *     (if sa
1524  *         (%internal-slot-set-using-accessor obj sa val)
1525  *         (slot-missing class obj slot val))))
1526  *
1527  * - no class redefinition check is performed.  if obj isn't updated,
1528  *   and class is an old class, then it can access to the old instance's
1529  *   slot value.
1530  */
1531 static ScmObj slot_set_using_class(ScmNextMethod *nm, ScmObj *args,
1532                                    int nargs, void *d)
1533 {
1534     ScmClass *klass = SCM_CLASS(args[0]);
1535     ScmObj obj = args[1];
1536     ScmObj slot = args[2];
1537     ScmObj val = args[3];
1538     ScmSlotAccessor *sa;
1539     
1540     if (!SCM_EQ(SCM_OBJ(klass), SCM_OBJ(Scm_ClassOf(obj)))) {
1541         Scm_Error("slot-ref-using-class: class %S is not the class of object %S", klass, obj);
1542     }
1543     sa = Scm_GetSlotAccessor(klass, slot);
1544     if (sa == NULL) return SLOT_MISSING4(klass, obj, slot, val);
1545     else            return slot_set_using_accessor(obj, sa, val);
1546 }
1547 
1548 static ScmClass *slot_set_using_class_SPEC[] = {
1549     SCM_CLASS_STATIC_PTR(Scm_ClassClass),
1550     SCM_CLASS_STATIC_PTR(Scm_ObjectClass),
1551     SCM_CLASS_STATIC_PTR(Scm_TopClass),
1552     SCM_CLASS_STATIC_PTR(Scm_TopClass)
1553 };
1554 static SCM_DEFINE_METHOD(slot_set_using_class_rec,
1555                          &Scm_GenericSlotSetUsingClass,
1556                          4, 0, slot_set_using_class_SPEC,
1557                          slot_set_using_class, NULL);
1558 
1559 /* SLOT-BOUND?
1560  *
1561  * (define (slot-bound? obj slot)
1562  *   (%check-class-redefined (class-of obj))
1563  *   (slot-bound-using-class (class-of obj) obj slot))
1564  */
1565 static ScmObj slot_boundp_cc(ScmObj result, void **data)
1566 {
1567     ScmObj obj = SCM_OBJ(data[0]);
1568     ScmObj slot = SCM_OBJ(data[1]);
1569     return Scm_VMSlotBoundP(obj, slot);
1570 }
1571 
1572 ScmObj Scm_VMSlotBoundP(ScmObj obj, ScmObj slot)
1573 {
1574     ScmClass *klass = Scm_ClassOf(obj);
1575     void *data[2];
1576     
1577     if (!SCM_FALSEP(klass->redefined)) {
1578         data[0] = obj;
1579         data[1] = slot;
1580         Scm_VMPushCC(slot_boundp_cc, data, 2);
1581         return instance_class_redefinition(obj, Scm_ClassOf(obj));
1582     }
1583     return Scm_VMApply(SCM_OBJ(&Scm_GenericSlotBoundUsingClassP),
1584                        SCM_LIST3(SCM_OBJ(klass), obj, slot));
1585 }
1586 
1587 /* SLOT-BOUND-USING-CLASS?
1588  *
1589  * (define-method slot-bound-using-class? ((class <class>)
1590  *                                         (obj <obj>)
1591  *                                         slot)
1592  *   (unless (eq? class (class-of obj)) (error !!!))
1593  *   (let ((sa (get-slot-accessor class slot)))
1594  *     (if sa
1595  *         (%internal-slot-ref-using-accessor obj sa #t)
1596  *         (slot-missing class obj slot)))
1597  *
1598  * - no redefinition check!
1599  */
1600 static ScmObj slot_bound_using_class_p(ScmNextMethod *nm, ScmObj *args,
1601                                        int nargs, void *data)
1602 {
1603     ScmClass *klass = SCM_CLASS(args[0]);
1604     ScmObj obj = args[1];
1605     ScmObj slot = args[2];
1606     ScmSlotAccessor *sa;
1607 
1608     if (!SCM_EQ(SCM_OBJ(klass), SCM_OBJ(Scm_ClassOf(obj)))) {
1609         Scm_Error("slot-bound-using-class?: class %S is not the class of object %S", klass, obj);
1610     }
1611     sa = Scm_GetSlotAccessor(klass, slot);
1612     if (sa == NULL) return SLOT_MISSING3(klass, obj, slot);
1613     else            return slot_ref_using_accessor(obj, sa, TRUE);
1614 }
1615 
1616 static ScmClass *slot_bound_using_class_p_SPEC[] = {
1617     SCM_CLASS_STATIC_PTR(Scm_ClassClass),
1618     SCM_CLASS_STATIC_PTR(Scm_TopClass),
1619     SCM_CLASS_STATIC_PTR(Scm_TopClass)
1620 };
1621 static SCM_DEFINE_METHOD(slot_bound_using_class_p_rec,
1622                          &Scm_GenericSlotBoundUsingClassP,
1623                          3, 0,
1624                          slot_bound_using_class_p_SPEC,
1625                          slot_bound_using_class_p, NULL);
1626 
1627 /*
1628  * Builtin object initializer
1629  * This is the fallback method of generic initialize.  Since all the
1630  * Scheme-defined objects will be initialized by object_initialize,
1631  * this method is called only for built-in classes.
1632  */
1633 static ScmObj builtin_initialize(ScmObj *args, int nargs, ScmGeneric *gf)
1634 {
1635     ScmObj instance, initargs, ap;
1636     ScmClass *klass;
1637     SCM_ASSERT(nargs == 2);
1638     instance = args[0];
1639     initargs = args[1];
1640     if (Scm_Length(initargs) % 2) {
1641         Scm_Error("initializer list is not even: %S", initargs);
1642     }
1643     klass = Scm_ClassOf(instance);
1644     SCM_FOR_EACH(ap, klass->accessors) {
1645         ScmSlotAccessor *acc = SCM_SLOT_ACCESSOR(SCM_CDAR(ap));
1646         if (acc->setter && SCM_KEYWORDP(acc->initKeyword)) {
1647             ScmObj val = Scm_GetKeyword(acc->initKeyword, initargs, SCM_UNDEFINED);
1648             if (!SCM_UNDEFINEDP(val)) {
1649                 acc->setter(instance, val);
1650             }
1651         }
1652     }
1653     return instance;
1654 }
1655 
1656 /*--------------------------------------------------------------
1657  * Slot accessor object
1658  */
1659 
1660 /* we initialize fields appropriately here. */
1661 static ScmObj slot_accessor_allocate(ScmClass *klass, ScmObj initargs)
1662 {
1663     ScmSlotAccessor *sa = SCM_NEW(ScmSlotAccessor);
1664 
1665     SCM_SET_CLASS(sa, klass);
1666     sa->name = SCM_FALSE;
1667     sa->getter = NULL;
1668     sa->setter = NULL;
1669     sa->initValue = SCM_UNBOUND;
1670     sa->initKeyword = SCM_FALSE;
1671     sa->initThunk = SCM_FALSE;
1672     sa->initializable = FALSE;
1673     sa->slotNumber = -1;
1674     sa->schemeGetter = SCM_FALSE;
1675     sa->schemeSetter = SCM_FALSE;
1676     sa->schemeBoundp = SCM_FALSE;
1677     return SCM_OBJ(sa);
1678 }
1679 
1680 static void slot_accessor_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
1681 {
1682     ScmSlotAccessor *sa = SCM_SLOT_ACCESSOR(obj);
1683     
1684     Scm_Printf(out, "#<slot-accessor %S.%S ",
1685                (sa->klass? sa->klass->name : SCM_FALSE),
1686                sa->name);
1687     if (sa->getter) Scm_Printf(out, "native");
1688     else if (!SCM_FALSEP(sa->schemeGetter)) Scm_Printf(out, "proc");
1689     else if (sa->slotNumber >= 0) Scm_Printf(out, "%d", sa->slotNumber);
1690     else Scm_Printf(out, "unknown");
1691     if (!SCM_FALSEP(sa->initKeyword))
1692         Scm_Printf(out, " %S", sa->initKeyword);
1693     Scm_Printf(out, ">");
1694 }
1695 
1696 /* some information is visible from Scheme world */
1697 static ScmObj slot_accessor_class(ScmSlotAccessor *sa)
1698 {
1699     return SCM_OBJ(sa->klass);
1700 }
1701 
1702 static void slot_accessor_class_set(ScmSlotAccessor *sa, ScmObj v)
1703 {
1704     if (!Scm_TypeP(v, SCM_CLASS_CLASS)) {
1705         Scm_Error(":class argument must be a class metaobject, but got %S", v);
1706     }
1707     sa->klass = SCM_CLASS(v);
1708 }
1709 
1710 static ScmObj slot_accessor_name(ScmSlotAccessor *sa)
1711 {
1712     return sa->name;
1713 }
1714 
1715 static void slot_accessor_name_set(ScmSlotAccessor *sa, ScmObj v)
1716 {
1717     sa->name = v;
1718 }
1719 
1720 static ScmObj slot_accessor_init_value(ScmSlotAccessor *sa)
1721 {
1722     return sa->initValue;
1723 }
1724 
1725 static void slot_accessor_init_value_set(ScmSlotAccessor *sa, ScmObj v)
1726 {
1727     sa->initValue = v;
1728 }
1729 
1730 static ScmObj slot_accessor_init_keyword(ScmSlotAccessor *sa)
1731 {
1732     return sa->initKeyword;
1733 }
1734 
1735 static void slot_accessor_init_keyword_set(ScmSlotAccessor *sa, ScmObj v)
1736 {
1737     sa->initKeyword = v;
1738 }
1739 
1740 static ScmObj slot_accessor_init_thunk(ScmSlotAccessor *sa)
1741 {
1742     return sa->initThunk;
1743 }
1744 
1745 static void slot_accessor_init_thunk_set(ScmSlotAccessor *sa, ScmObj v)
1746 {
1747     sa->initThunk = v;
1748 }
1749 
1750 static ScmObj slot_accessor_slot_number(ScmSlotAccessor *sa)
1751 {
1752     return SCM_MAKE_INT(sa->slotNumber);
1753 }
1754 
1755 static void slot_accessor_slot_number_set(ScmSlotAccessor *sa, ScmObj val)
1756 {
1757     int n = 0;
1758     if (!SCM_INTP(val) || ((n = SCM_INT_VALUE(val)) < 0))
1759         Scm_Error("small positive integer required, but got %S", val);
1760     sa->slotNumber = n;
1761 }
1762 
1763 static ScmObj slot_accessor_initializable(ScmSlotAccessor *sa)
1764 {
1765     return SCM_MAKE_BOOL(sa->initializable);
1766 }
1767 
1768 static void slot_accessor_initializable_set(ScmSlotAccessor *sa, ScmObj v)
1769 {
1770     sa->initializable = SCM_FALSEP(v)? FALSE : TRUE;
1771 }
1772 
1773 static ScmObj slot_accessor_scheme_getter(ScmSlotAccessor *sa)
1774 {
1775     return sa->schemeGetter;
1776 }
1777 
1778 static void slot_accessor_scheme_getter_set(ScmSlotAccessor *sa, ScmObj p)
1779 {
1780     /* TODO: check */
1781     sa->schemeGetter = p;
1782 }
1783 
1784 static ScmObj slot_accessor_scheme_setter(ScmSlotAccessor *sa)
1785 {
1786     return sa->schemeSetter;
1787 }
1788 
1789 static void slot_accessor_scheme_setter_set(ScmSlotAccessor *sa, ScmObj p)
1790 {
1791     /* TODO: check */
1792     sa->schemeSetter = p;
1793 }
1794 
1795 static ScmObj slot_accessor_scheme_boundp(ScmSlotAccessor *sa)
1796 {
1797     return sa->schemeBoundp;
1798 }
1799 
1800 static void slot_accessor_scheme_boundp_set(ScmSlotAccessor *sa, ScmObj p)
1801 {
1802     /* TODO: check */
1803     sa->schemeBoundp = p;
1804 }
1805 
1806 /*=====================================================================
1807  * <object> class initialization
1808  */
1809 
1810 ScmObj Scm_ObjectAllocate(ScmClass *klass, ScmObj initargs)
1811 {
1812     ScmObj obj = Scm_AllocateInstance(klass, sizeof(ScmInstance));
1813     SCM_SET_CLASS(obj, klass);
1814     return SCM_OBJ(obj);
1815 }
1816 
1817 /* (initialize <object> initargs) */
1818 static ScmObj object_initialize_cc(ScmObj result, void **data);
1819 
1820 static ScmObj object_initialize1(ScmObj obj, ScmObj accs, ScmObj initargs)
1821 {
1822     void *next[3];
1823     if (SCM_NULLP(accs)) return obj;
1824     SCM_ASSERT(SCM_PAIRP(SCM_CAR(accs))
1825                && SCM_SLOT_ACCESSOR_P(SCM_CDAR(accs)));
1826     next[0] = obj;
1827     next[1] = SCM_CDR(accs);
1828     next[2] = initargs;
1829     Scm_VMPushCC(object_initialize_cc, next, 3);
1830     return Scm_VMSlotInitializeUsingAccessor(obj,
1831                                              SCM_SLOT_ACCESSOR(SCM_CDAR(accs)),
1832                                              initargs);
1833 }
1834 
1835 static ScmObj object_initialize_cc(ScmObj result, void **data)
1836 {
1837     ScmObj obj = SCM_OBJ(data[0]);
1838     ScmObj accs = SCM_OBJ(data[1]);
1839     ScmObj initargs = SCM_OBJ(data[2]);
1840     return object_initialize1(obj, accs, initargs);
1841 }
1842 
1843 static ScmObj object_initialize(ScmNextMethod *nm, ScmObj *args, int nargs,
1844                                 void *data)
1845 {
1846     ScmObj obj = args[0];
1847     ScmObj initargs = args[1];
1848     ScmObj accs = Scm_ClassOf(obj)->accessors;
1849     if (SCM_NULLP(accs)) return obj;
1850     return object_initialize1(obj, accs, initargs);
1851 }
1852 
1853 static ScmClass *object_initialize_SPEC[] = {
1854     SCM_CLASS_STATIC_PTR(Scm_ObjectClass), SCM_CLASS_STATIC_PTR(Scm_ListClass)
1855 };
1856 static SCM_DEFINE_METHOD(object_initialize_rec,
1857                          &Scm_GenericInitialize,
1858                          2, 0,
1859                          object_initialize_SPEC,
1860                          object_initialize, NULL);
1861 
1862 /* Default equal? delegates compare action to generic function object-equal?.
1863    We can't use VMApply here */
1864 static int object_compare(ScmObj x, ScmObj y, int equalp)
1865 {
1866     ScmObj r;
1867     if (equalp) {
1868         r = Scm_Apply(SCM_OBJ(&Scm_GenericObjectEqualP), SCM_LIST2(x, y));
1869         return (SCM_FALSEP(r)? -1 : 0);
1870     } else {
1871         r = Scm_Apply(SCM_OBJ(&Scm_GenericObjectCompare), SCM_LIST2(x, y));
1872         if (SCM_INTP(r)) {
1873             int ri = SCM_INT_VALUE(r);
1874             if (ri < 0) return -1;
1875             if (ri > 0) return 1;
1876             else return 0;
1877         }
1878         Scm_Error("object %S and %S can't be ordered", x, y);
1879         return 0;               /* dummy */
1880     }
1881 }
1882 
1883 /* Fallback methods */
1884 static ScmObj object_compare_default(ScmNextMethod *nm, ScmObj *args,
1885                                      int nargs, void *data)
1886 {
1887     return SCM_FALSE;
1888 }
1889 
1890 static ScmClass *object_compare_SPEC[] = {
1891     SCM_CLASS_STATIC_PTR(Scm_TopClass), SCM_CLASS_STATIC_PTR(Scm_TopClass)
1892 };
1893 static SCM_DEFINE_METHOD(object_compare_rec,
1894                          &Scm_GenericObjectCompare,
1895                          2, 0,
1896                          object_compare_SPEC,
1897                          object_compare_default, NULL);
1898 static SCM_DEFINE_METHOD(object_equalp_rec,
1899                          &Scm_GenericObjectEqualP,
1900                          2, 0,
1901                          object_compare_SPEC,
1902                          object_compare_default, NULL);
1903 
1904 /*=====================================================================
1905  * Generic function
1906  */
1907 
1908 static ScmObj generic_allocate(ScmClass *klass, ScmObj initargs)
1909 {
1910     ScmGeneric *instance = SCM_ALLOCATE(ScmGeneric, klass);
1911     SCM_SET_CLASS(instance, klass);
1912     SCM_PROCEDURE_INIT(instance, 0, 0, SCM_PROC_GENERIC, SCM_FALSE);
1913     instance->methods = SCM_NIL;
1914     instance->fallback = Scm_NoNextMethod;
1915     instance->data = NULL;
1916     (void)SCM_INTERNAL_MUTEX_INIT(instance->lock);
1917     return SCM_OBJ(instance);
1918 }
1919 
1920 static void generic_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
1921 {
1922     Scm_Printf(port, "#<generic %S (%d)>",
1923                SCM_GENERIC(obj)->common.info,
1924                Scm_Length(SCM_GENERIC(obj)->methods));
1925 }
1926 
1927 /*
1928  * Accessors
1929  */
1930 static ScmObj generic_name(ScmGeneric *gf)
1931 {
1932     return gf->common.info;
1933 }
1934 
1935 static void generic_name_set(ScmGeneric *gf, ScmObj val)
1936 {
1937     gf->common.info = val;
1938 }
1939 
1940 static ScmObj generic_methods(ScmGeneric *gf)
1941 {
1942     return gf->methods;
1943 }
1944 
1945 static void generic_methods_set(ScmGeneric *gf, ScmObj val)
1946 {
1947     gf->methods = val;
1948 }
1949 
1950 /* Make base generic function from C */
1951 ScmObj Scm_MakeBaseGeneric(ScmObj name,
1952                            ScmObj (*fallback)(ScmObj *, int, ScmGeneric*),
1953                            void *data)
1954 {
1955     ScmGeneric *gf = SCM_GENERIC(generic_allocate(SCM_CLASS_GENERIC, SCM_NIL));
1956     gf->common.info = name;
1957     if (fallback) {
1958         gf->fallback = fallback;
1959         gf->data = data;
1960     }
1961     return SCM_OBJ(gf);
1962 }
1963 
1964 /* default "default method" */
1965 ScmObj Scm_NoNextMethod(ScmObj *args, int nargs, ScmGeneric *gf)
1966 {
1967     Scm_Error("no applicable method for %S with arguments %S",
1968               SCM_OBJ(gf), Scm_ArrayToList(args, nargs));
1969     return SCM_UNDEFINED;       /* dummy */
1970 }
1971 
1972 /* another handy "default method", which does nothing. */
1973 ScmObj Scm_NoOperation(ScmObj *arg, int nargs, ScmGeneric *gf)
1974 {
1975     return SCM_UNDEFINED;
1976 }
1977 
1978 /* fallback of object-apply */
1979 ScmObj Scm_InvalidApply(ScmObj *args, int nargs, ScmGeneric *gf)
1980 {
1981     Scm_Error("invalid application: %S", Scm_ArrayToList(args, nargs));
1982     return SCM_UNDEFINED;
1983 }
1984 
1985 /* compute-applicable-methods */
1986 ScmObj Scm_ComputeApplicableMethods(ScmGeneric *gf, ScmObj *args, int nargs)
1987 {
1988     ScmObj methods = gf->methods, mp;
1989     ScmObj h = SCM_NIL, t = SCM_NIL;
1990 
1991     SCM_FOR_EACH(mp, methods) {
1992         ScmMethod *m = SCM_METHOD(SCM_CAR(mp));
1993         ScmObj *ap;
1994         ScmClass **sp;
1995         int n;
1996         
1997         if (nargs < m->common.required) continue;
1998         if (!m->common.optional && nargs > m->common.required) continue;
1999         for (ap = args, sp = m->specializers, n = 0;
2000              n < m->common.required;
2001              ap++, sp++, n++) {
2002             if (!Scm_SubtypeP(Scm_ClassOf(*ap), *sp)) break;
2003         }
2004         if (n == m->common.required) SCM_APPEND1(h, t, SCM_OBJ(m));
2005     }
2006     return h;
2007 }
2008 
2009 static ScmObj compute_applicable_methods(ScmNextMethod *nm,
2010                                          ScmObj *args,
2011                                          int nargs,
2012                                          void *data)
2013 {
2014     ScmGeneric *gf = SCM_GENERIC(args[0]);
2015     ScmObj arglist = args[1], ap;
2016     ScmObj *argv;
2017     int n = Scm_Length(arglist), i;
2018     if (n < 0) Scm_Error("bad argument list: %S", arglist);
2019 
2020     argv = SCM_NEW_ARRAY(ScmObj, n);
2021     i = 0;
2022     SCM_FOR_EACH(ap, arglist) argv[i++] = SCM_CAR(ap);
2023     return Scm_ComputeApplicableMethods(gf, argv, n);
2024 }
2025 
2026 static ScmClass *compute_applicable_methods_SPEC[] = {
2027     SCM_CLASS_STATIC_PTR(Scm_GenericClass), SCM_CLASS_STATIC_PTR(Scm_ListClass)
2028 };
2029 static SCM_DEFINE_METHOD(compute_applicable_methods_rec,
2030                          &Scm_GenericComputeApplicableMethods,
2031                          2, 0,
2032                          compute_applicable_methods_SPEC,
2033                          compute_applicable_methods, NULL);
2034 
2035 /* method-more-specific? */
2036 static inline int method_more_specific(ScmMethod *x, ScmMethod *y,
2037                                        ScmClass **targs, int nargs)
2038 {
2039     ScmClass **xs = x->specializers;
2040     ScmClass **ys = y->specializers;
2041     ScmClass *ac, **acpl;
2042     int i;
2043     for (i=0; i<SCM_PROCEDURE_REQUIRED(x) && i<SCM_PROCEDURE_REQUIRED(y); i++) {
2044         if (xs[i] != ys[i]) {
2045             ac = targs[i];
2046             if (xs[i] == ac) return TRUE;
2047             if (ys[i] == ac) return FALSE;
2048             for (acpl = ac->cpa; *acpl; acpl++) {
2049                 if (xs[i] == *acpl) return TRUE;
2050                 if (ys[i] == *acpl) return FALSE;
2051             }
2052             Scm_Panic("internal error: couldn't determine more specific method.");
2053         }
2054     }
2055     /* all specializers match.  the one without optional arg is more special.*/
2056     if (SCM_PROCEDURE_OPTIONAL(y)) return TRUE;
2057     else return FALSE;
2058 }
2059 
2060 static ScmObj method_more_specific_p(ScmNextMethod *nm, ScmObj *args,
2061                                      int nargs, void *data)
2062 {
2063     ScmMethod *x = SCM_METHOD(args[0]);
2064     ScmMethod *y = SCM_METHOD(args[1]);
2065     ScmObj targlist = args[2], tp;
2066     ScmClass **targs;
2067     int ntargs = Scm_Length(targlist), i;
2068     if (ntargs < 0) Scm_Error("bad targ list: %S", targlist);
2069     targs = SCM_NEW_ARRAY(ScmClass*, ntargs);
2070     i = 0;
2071     SCM_FOR_EACH(tp, targlist) {
2072         if (!Scm_TypeP(SCM_CAR(tp), SCM_CLASS_CLASS))
2073             Scm_Error("bad class object in type list: %S", SCM_CAR(tp));
2074         targs[i++] = SCM_CLASS(SCM_CAR(tp));
2075     }
2076     return SCM_MAKE_BOOL(method_more_specific(x, y, targs, ntargs));
2077 }
2078 static ScmClass *method_more_specific_p_SPEC[] = {
2079     SCM_CLASS_STATIC_PTR(Scm_MethodClass),
2080     SCM_CLASS_STATIC_PTR(Scm_MethodClass),
2081     SCM_CLASS_STATIC_PTR(Scm_ListClass)
2082 };
2083 static SCM_DEFINE_METHOD(method_more_specific_p_rec,
2084                          &Scm_GenericMethodMoreSpecificP,
2085                          3, 0,
2086                          method_more_specific_p_SPEC,
2087                          method_more_specific_p, NULL);
2088 
2089 /* sort-methods
2090  *  This is a naive implementation just to make things work.
2091  * TODO: can't we carry around the method list in array
2092  * instead of list, at least internally?
2093  */
2094 #define STATIC_SORT_ARRAY_SIZE  32
2095 
2096 ScmObj Scm_SortMethods(ScmObj methods, ScmObj *args, int nargs)
2097 {
2098     ScmObj starray[STATIC_SORT_ARRAY_SIZE], *array = starray;
2099     ScmClass *sttargs[STATIC_SORT_ARRAY_SIZE], **targs = sttargs;
2100     int cnt = 0, len = Scm_Length(methods), step, i, j;
2101     ScmObj mp;
2102 
2103     if (len >= STATIC_SORT_ARRAY_SIZE)
2104         array = SCM_NEW_ARRAY(ScmObj, len);
2105     if (nargs >= STATIC_SORT_ARRAY_SIZE)
2106         targs = SCM_NEW_ARRAY(ScmClass*, nargs);
2107 
2108     SCM_FOR_EACH(mp, methods) {
2109         if (!Scm_TypeP(SCM_CAR(mp), SCM_CLASS_METHOD))
2110             Scm_Error("bad method in applicable method list: %S", SCM_CAR(mp));
2111         array[cnt] = SCM_CAR(mp);
2112         cnt++;
2113     }
2114     for (i=0; i<nargs; i++) targs[i] = Scm_ClassOf(args[i]);
2115 
2116     for (step = len/2; step > 0; step /= 2) {
2117         for (i=step; i<len; i++) {
2118             for (j=i-step; j >= 0; j -= step) {
2119                 if (method_more_specific(SCM_METHOD(array[j]),
2120                                          SCM_METHOD(array[j+step]),
2121                                          targs, nargs)) {
2122                     break;
2123                 } else {
2124                     ScmObj tmp = array[j+step];
2125                     array[j+step] = array[j];
2126                     array[j] = tmp;
2127                 }
2128             }
2129         }
2130     }
2131     return Scm_ArrayToList(array, len);
2132 }
2133 
2134 /*=====================================================================
2135  * Method
2136  */
2137 
2138 static ScmObj method_allocate(ScmClass *klass, ScmObj initargs)
2139 {
2140     ScmMethod *instance = SCM_ALLOCATE(ScmMethod, klass);
2141     SCM_SET_CLASS(instance, klass);
2142     SCM_PROCEDURE_INIT(instance, 0, 0, SCM_PROC_METHOD, SCM_FALSE);
2143     instance->generic = NULL;
2144     instance->specializers = NULL;
2145     instance->func = NULL;
2146     return SCM_OBJ(instance);
2147 }
2148 
2149 static void method_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
2150 {
2151     Scm_Printf(port, "#<method %S>", SCM_METHOD(obj)->common.info);
2152 }
2153 
2154 /*
2155  * (initialize <method> (&key lamdba-list generic specializers body))
2156  *    Method initialization.   This needs to be hardcoded, since
2157  *    we can't call Scheme verison of initialize to initialize the
2158  *    "initialize" method (chicken-and-egg circularity).
2159  */
2160 static ScmObj method_initialize(ScmNextMethod *nm, ScmObj *args, int nargs,
2161                                 void *data)
2162 {
2163     ScmMethod *m = SCM_METHOD(args[0]);
2164     ScmGeneric *g;
2165     ScmObj initargs = args[1];
2166     ScmObj llist = Scm_GetKeyword(key_lambda_list, initargs, SCM_FALSE);
2167     ScmObj generic = Scm_GetKeyword(key_generic, initargs, SCM_FALSE);
2168     ScmObj specs = Scm_GetKeyword(key_specializers, initargs, SCM_FALSE);
2169     ScmObj body = Scm_GetKeyword(key_body, initargs, SCM_FALSE);
2170     ScmClass **specarray;
2171     ScmObj lp, h, t;
2172     int speclen = 0, req = 0, opt = 0, i;
2173 
2174     if (!Scm_TypeP(generic, SCM_CLASS_GENERIC))
2175         Scm_Error("generic function required for :generic argument: %S",
2176                   generic);
2177     g = SCM_GENERIC(generic);
2178     if (!SCM_CLOSUREP(body))
2179         Scm_Error("closure required for :body argument: %S", body);
2180     if ((speclen = Scm_Length(specs)) < 0)
2181         Scm_Error("invalid specializers list: %S", specs);
2182     specarray = class_list_to_array(specs, speclen);
2183 
2184     /* find out # of args from lambda list */
2185     SCM_FOR_EACH(lp, llist) req++;
2186     if (!SCM_NULLP(lp)) opt++;
2187 
2188     if (SCM_PROCEDURE_REQUIRED(body) != req + opt + 1)
2189         Scm_Error("body doesn't match with lambda list: %S", body);
2190     if (speclen != req)
2191         Scm_Error("specializer list doesn't match with lambda list: %S",specs);
2192 
2193     m->common.required = req;
2194     m->common.optional = opt;
2195     m->common.info = Scm_Cons(g->common.info,
2196                               class_array_to_names(specarray, speclen));
2197     m->generic = g;
2198     m->specializers = specarray;
2199     m->func = NULL;
2200     m->data = SCM_CLOSURE(body)->code;
2201     m->env = SCM_CLOSURE(body)->env;
2202 
2203     /* NB: for comprehensive debugging & profiling information, we modify
2204        the 'name' field of the compiled code to contain
2205        (generic-name specializer-class-names ...).  It may be a hazard if
2206        some existing named closure is given as BODY; as far as the standard
2207        macro is used, though, altering it should be OK. */
2208     h = t = SCM_NIL;
2209     for (i=0; i<speclen; i++) {
2210         SCM_APPEND1(h, t, specarray[i]->name);
2211     }
2212     SCM_COMPILED_CODE(m->data)->name = Scm_Cons(SCM_PROCEDURE_INFO(g), h);
2213 
2214     /* Register this method to all classes in the specializers.
2215        This has to come after the part that may throw an error. */
2216     for (i=0; i<speclen; i++) {
2217         Scm_AddDirectMethod(specarray[i], m);
2218     }
2219     return SCM_OBJ(m);
2220 }
2221 
2222 static ScmClass *method_initialize_SPEC[] = {
2223     SCM_CLASS_STATIC_PTR(Scm_MethodClass),
2224     SCM_CLASS_STATIC_PTR(Scm_ListClass)
2225 };
2226 static SCM_DEFINE_METHOD(method_initialize_rec,
2227                          &Scm_GenericInitialize,
2228                          2, 0,
2229                          method_initialize_SPEC,
2230                          method_initialize, NULL);
2231 
2232 /*
2233  * Accessors
2234  */
2235 static ScmObj method_required(ScmMethod *m)
2236 {
2237     return SCM_MAKE_INT(m->common.required);
2238 }
2239 
2240 static ScmObj method_optional(ScmMethod *m)
2241 {
2242     return SCM_MAKE_BOOL(m->common.optional);
2243 }
2244 
2245 static ScmObj method_generic(ScmMethod *m)
2246 {
2247     return m->generic ? SCM_OBJ(m->generic) : SCM_FALSE;
2248 }
2249 
2250 static void method_generic_set(ScmMethod *m, ScmObj val)
2251 {
2252     if (SCM_GENERICP(val))
2253         m->generic = SCM_GENERIC(val);
2254     else
2255         Scm_Error("generic function required, but got %S", val);
2256 }
2257 
2258 static ScmObj method_specializers(ScmMethod *m)
2259 {
2260     if (m->specializers) {
2261         return class_array_to_list(m->specializers, m->common.required);
2262     } else {
2263         return SCM_NIL;
2264     }
2265 }
2266 
2267 static void method_specializers_set(ScmMethod *m, ScmObj val)
2268 {
2269     int len = Scm_Length(val);
2270     if (len != m->common.required)
2271         Scm_Error("specializer list doesn't match body's lambda list:", val);
2272     if (len == 0) 
2273         m->specializers = NULL;
2274     else 
2275         m->specializers = class_list_to_array(val, len);
2276 }
2277 
2278 /* update-direct-method! method old-class new-class
2279  *   To be called during class redefinition, and swaps reference of
2280  *   old-class for new-class.
2281  *
2282  *   This procedure swaps the pointer "in-place", so as far as the pointer
2283  *   arithmetic is atomic, we won't have a race condition.  Class
2284  *   redefinition is serialized inside class-redefinition, so we won't
2285  *   have the case that more than one thread call this procedure with
2286  *   the same OLD pointer.  It is possible that more than one thread call
2287  *   this procedure on the same method simultaneously, but the OLD pointer
2288  *   should differ, and it won't do any harm for them to run concurrently.
2289  *
2290  *   Note that if we implement this in Scheme, we need a mutex to lock the
2291  *   specializer array.
2292  */
2293 ScmObj Scm_UpdateDirectMethod(ScmMethod *m, ScmClass *old, ScmClass *newc)
2294 {
2295     int i, rec = SCM_PROCEDURE_REQUIRED(m);
2296     ScmClass **sp = m->specializers;
2297     for (i=0; i<rec; i++) {
2298         if (sp[i] == old) sp[i] = newc;
2299     }
2300     if (SCM_FALSEP(Scm_Memq(SCM_OBJ(m), newc->directMethods))) {
2301         newc->directMethods = Scm_Cons(SCM_OBJ(m), newc->directMethods);
2302     }
2303     return SCM_OBJ(m);
2304 }
2305 
2306 static ScmObj generic_updatedirectmethod(ScmNextMethod *nm, ScmObj *args,
2307                                          int nargs, void *data)
2308 {
2309     return Scm_UpdateDirectMethod(SCM_METHOD(args[0]),
2310                                   SCM_CLASS(args[1]),
2311                                   SCM_CLASS(args[2]));
2312 }
2313 
2314 static ScmClass *generic_updatedirectmethod_SPEC[] = {
2315     SCM_CLASS_STATIC_PTR(Scm_MethodClass),
2316     SCM_CLASS_STATIC_PTR(Scm_ClassClass),
2317     SCM_CLASS_STATIC_PTR(Scm_ClassClass)
2318 };
2319 static SCM_DEFINE_METHOD(generic_updatedirectmethod_rec,
2320                          &Scm_GenericUpdateDirectMethod, 3, 0,
2321                          generic_updatedirectmethod_SPEC,
2322                          generic_updatedirectmethod, NULL);
2323 
2324 /*
2325  * ADD-METHOD, and it's default method version.
2326  */
2327 ScmObj Scm_AddMethod(ScmGeneric *gf, ScmMethod *method)
2328 {
2329     ScmObj mp, pair;
2330     int replaced = FALSE;
2331         
2332     if (method->generic && method->generic != gf)
2333         Scm_Error("method %S already added to a generic function %S",
2334                   method, method->generic);
2335     if (!SCM_FALSEP(Scm_Memq(SCM_OBJ(method), gf->methods)))
2336         Scm_Error("method %S already appears in a method list of generic %S"
2337                   " something wrong in MOP implementation?",
2338                   method, gf);
2339     method->generic = gf;
2340     /* pre-allocate cons pair to avoid triggering GC in the critical region */
2341     pair = Scm_Cons(SCM_OBJ(method), gf->methods);
2342 
2343     /* Check if a method with the same signature exists */
2344     (void)SCM_INTERNAL_MUTEX_LOCK(gf->lock);
2345     SCM_FOR_EACH(mp, gf->methods) {
2346         ScmMethod *mm = SCM_METHOD(SCM_CAR(mp));
2347         if (SCM_PROCEDURE_REQUIRED(method) == SCM_PROCEDURE_REQUIRED(mm)
2348             && SCM_PROCEDURE_OPTIONAL(method) == SCM_PROCEDURE_OPTIONAL(mm)) {
2349             ScmClass **sp1 = method->specializers;
2350             ScmClass **sp2 = mm->specializers;
2351             int i;
2352             for (i=0; i<SCM_PROCEDURE_REQUIRED(method); i++) {
2353                 if (sp1[i] != sp2[i]) break;
2354             }
2355             if (i == SCM_PROCEDURE_REQUIRED(method)) {
2356                 SCM_SET_CAR(mp, SCM_OBJ(method));
2357                 replaced = TRUE;
2358                 break;
2359             }
2360         }
2361     }
2362     if (!replaced) gf->methods = pair;
2363     (void)SCM_INTERNAL_MUTEX_UNLOCK(gf->lock);
2364     return SCM_UNDEFINED;
2365 }
2366 
2367 static ScmObj generic_addmethod(ScmNextMethod *nm, ScmObj *args, int nargs,
2368                                 void *data)
2369 {
2370     return Scm_AddMethod(SCM_GENERIC(args[0]), SCM_METHOD(args[1]));
2371 }
2372 
2373 static ScmClass *generic_addmethod_SPEC[] = {
2374     SCM_CLASS_STATIC_PTR(Scm_GenericClass),
2375     SCM_CLASS_STATIC_PTR(Scm_MethodClass)
2376 };
2377 static SCM_DEFINE_METHOD(generic_addmethod_rec,
2378                          &Scm_GenericAddMethod, 2, 0,
2379                          generic_addmethod_SPEC,
2380                          generic_addmethod, NULL);
2381 
2382 /*
2383  * DELETE-METHOD, and it's default method version.
2384  */
2385 ScmObj Scm_DeleteMethod(ScmGeneric *gf, ScmMethod *method)
2386 {
2387     ScmObj mp;
2388 
2389     if (!method->generic || method->generic != gf) return SCM_UNDEFINED;
2390 
2391     (void)SCM_INTERNAL_MUTEX_LOCK(gf->lock);
2392     mp = gf->methods;
2393     if (SCM_PAIRP(mp)) {
2394         if (SCM_EQ(SCM_CAR(mp), SCM_OBJ(method))) {
2395             gf->methods = SCM_CDR(mp);
2396             method->generic = NULL;
2397         } else {
2398             while (SCM_PAIRP(SCM_CDR(mp))) {
2399                 if (SCM_EQ(SCM_CADR(mp), SCM_OBJ(method))) {
2400                     SCM_CDR(mp) = SCM_CDDR(mp);
2401                     method->generic = NULL;
2402                     break;
2403                 }
2404                 mp = SCM_CDR(mp);
2405             }
2406         }
2407     }
2408     (void)SCM_INTERNAL_MUTEX_UNLOCK(gf->lock);
2409     return SCM_UNDEFINED;
2410 }
2411 
2412 static ScmObj generic_deletemethod(ScmNextMethod *nm, ScmObj *args, int nargs,
2413                                    void *data)
2414 {
2415     return Scm_DeleteMethod(SCM_GENERIC(args[0]), SCM_METHOD(args[1]));
2416 }
2417 
2418 static ScmClass *generic_deletemethod_SPEC[] = {
2419     SCM_CLASS_STATIC_PTR(Scm_GenericClass),
2420     SCM_CLASS_STATIC_PTR(Scm_MethodClass)
2421 };
2422 static SCM_DEFINE_METHOD(generic_deletemethod_rec,
2423                          &Scm_GenericDeleteMethod, 2, 0,
2424                          generic_deletemethod_SPEC,
2425                          generic_deletemethod, NULL);
2426 
2427 /*=====================================================================
2428  * Next Method
2429  */
2430 
2431 ScmObj Scm_MakeNextMethod(ScmGeneric *gf, ScmObj methods,
2432                           ScmObj *args, int nargs, int copyArgs)
2433 {
2434     ScmNextMethod *nm = SCM_NEW(ScmNextMethod);
2435     SCM_SET_CLASS(nm, SCM_CLASS_NEXT_METHOD);
2436     SCM_PROCEDURE_INIT(nm, 0, 0, SCM_PROC_NEXT_METHOD, SCM_FALSE);
2437     nm->generic = gf;
2438     nm->methods = methods;
2439     if (copyArgs) {
2440         nm->args = SCM_NEW_ARRAY(ScmObj, nargs);
2441         memcpy(nm->args, args, sizeof(ScmObj)*nargs);
2442     } else {
2443         nm->args = args;
2444     }
2445     nm->nargs = nargs;
2446     return SCM_OBJ(nm);
2447 }
2448 
2449 static void next_method_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
2450 {
2451     ScmNextMethod *nm = SCM_NEXT_METHOD(obj);
2452     ScmObj args = Scm_ArrayToList(nm->args, nm->nargs);
2453     Scm_Printf(out, "#<next-method %S %S>", nm->methods, args);
2454 }
2455 
2456 /*=====================================================================
2457  * Accessor Method
2458  */
2459 
2460 static void accessor_method_print(ScmObj obj, ScmPort *port,
2461                                   ScmWriteContext *ctx)
2462 {
2463     Scm_Printf(port, "#<accessor-method %S>", SCM_METHOD(obj)->common.info);
2464 }
2465 
2466 static ScmObj accessor_get_proc(ScmNextMethod *nm, ScmObj *args, int nargs,
2467                                 void *data)
2468 {
2469     ScmObj obj = args[0];
2470     ScmSlotAccessor *ca = (ScmSlotAccessor*)data;
2471     /* NB: we need this extra check, in case if the getter method of parent
2472        class and the one of subclass don't share the generic function, and
2473        the getter method of parent class is called on the subclass's instance.
2474        See test/object.scm "module and accessor" section for a concrete
2475        example. */
2476     if (!SCM_EQ(Scm_ClassOf(obj), ca->klass)) {
2477         /* fallback to a normal protocol */
2478         return Scm_VMSlotRef(obj, ca->name, FALSE);
2479     }
2480     /* Standard path.  We can skip searching the slot, so it is faster. */
2481     return slot_ref_using_accessor(obj, ca, FALSE);
2482 }
2483 
2484 static ScmObj accessor_set_proc(ScmNextMethod *nm, ScmObj *args, int nargs,
2485                                 void *data)
2486 {
2487     ScmObj obj = args[0];
2488     ScmObj val = args[1];
2489     ScmSlotAccessor *ca = (ScmSlotAccessor*)data;
2490     /* See the comment in accessor_get_proc above about this check. */
2491     if (!SCM_EQ(Scm_ClassOf(obj), ca->klass)) {
2492         return Scm_VMSlotSet(obj, ca->name, val);
2493     }
2494     return slot_set_using_accessor(obj, ca, val);
2495 }
2496 
2497 /* Accessor method can be just created by usual allocate/initialize
2498    sequence.  But it requires :slot-accessor initarg.  The method body
2499    is overridden by C function, and the closure given to :body doesn't
2500    have an effect.  */
2501 static ScmObj accessor_method_initialize(ScmNextMethod *nm, ScmObj *args,
2502                                          int nargs, void *data)
2503 {
2504     ScmMethod *m = SCM_METHOD(method_initialize(nm, args, nargs, data));
2505     ScmObj initargs = args[1];
2506     ScmObj sa = Scm_GetKeyword(key_slot_accessor, initargs, SCM_FALSE);
2507 
2508     if (!SCM_SLOT_ACCESSOR_P(sa)) {
2509         Scm_Error("slot accessor required for :slot-accessor argument: %S",
2510                   sa);
2511     }
2512 
2513     m->data = sa;
2514     switch (SCM_PROCEDURE_REQUIRED(m)) {
2515     case 1: /* accessor <obj> - this is a getter */
2516         m->func = accessor_get_proc;
2517         break;
2518     case 2: /* accessor <obj> <val> - this is a setter */
2519         m->func = accessor_set_proc;
2520         break;
2521     default:
2522         Scm_Error("bad initialization parameter for accessor method %S", m);
2523     }
2524     return SCM_OBJ(m);
2525 }
2526 
2527 static ScmClass *accessor_method_initialize_SPEC[] = {
2528     SCM_CLASS_STATIC_PTR(Scm_AccessorMethodClass),
2529     SCM_CLASS_STATIC_PTR(Scm_ListClass)
2530 };
2531 static SCM_DEFINE_METHOD(accessor_method_initialize_rec,
2532                          &Scm_GenericInitialize,
2533                          2, 0,
2534                          accessor_method_initialize_SPEC,
2535                          accessor_method_initialize, NULL);
2536 
2537 static ScmObj accessor_method_slot_accessor(ScmAccessorMethod *m)
2538 {
2539     SCM_ASSERT(SCM_SLOT_ACCESSOR_P(m->data));
2540     return SCM_OBJ(m->data);
2541 }
2542 
2543 static void accessor_method_slot_accessor_set(ScmAccessorMethod *m, ScmObj v)
2544 {
2545     if (!SCM_SLOT_ACCESSOR_P(v)) {
2546         Scm_Error("slot accessor required, but got %S", v);
2547     }
2548     m->data = v;
2549 }
2550 
2551 /*=====================================================================
2552  * Foreign pointer mechanism
2553  */
2554 
2555 struct foreign_data_rec {
2556     int flags;
2557     ScmForeignCleanupProc cleanup;
2558     ScmHashTable *identity_map;
2559 };
2560 
2561 ScmClass *Scm_MakeForeignPointerClass(ScmModule *mod,
2562                                       const char *name,
2563                                       ScmClassPrintProc print_proc,
2564                                       ScmForeignCleanupProc cleanup_proc,
2565                                       int flags)
2566 {
2567     ScmClass *fp = (ScmClass*)class_allocate(SCM_CLASS_CLASS, SCM_NIL);
2568     ScmObj s = SCM_INTERN(name);
2569     struct foreign_data_rec *data = SCM_NEW(struct foreign_data_rec);
2570     static ScmClass *fpcpa[] = { SCM_CLASS_FOREIGN_POINTER, SCM_CLASS_TOP, NULL };
2571     fp->name = s;
2572     fp->allocate = NULL;
2573     fp->print = print_proc;
2574     fp->cpa = fpcpa;
2575     fp->flags = SCM_CLASS_BUILTIN;
2576     initialize_builtin_cpl(fp, SCM_FALSE);
2577     Scm_Define(mod, SCM_SYMBOL(s), SCM_OBJ(fp));
2578     fp->slots = SCM_NIL;
2579     fp->accessors = SCM_NIL;
2580     data->flags = flags;
2581     data->cleanup = cleanup_proc;
2582     if (flags & SCM_FOREIGN_POINTER_KEEP_IDENTITY) {
2583         data->identity_map =
2584             SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_WORD, 256));
2585     } else {
2586         data->identity_map = NULL;
2587     }
2588     fp->data = (void*)data; /* see the note above class_allocate() */
2589     return fp;
2590 }
2591 
2592 static void fp_finalize(ScmObj obj, void *data)
2593 {
2594     void (*cleanup)(ScmObj) = (void (*)(ScmObj))data;
2595     cleanup(obj);
2596 }
2597 
2598 static ScmForeignPointer *make_foreign_int(ScmClass *klass, void *ptr,
2599                                            struct foreign_data_rec *data)
2600 {
2601     ScmForeignPointer *obj;
2602     obj = SCM_NEW(ScmForeignPointer);
2603     SCM_SET_CLASS(obj, klass);
2604     obj->ptr = ptr;
2605     obj->attributes = SCM_NIL;
2606     if (data->cleanup) {
2607         Scm_RegisterFinalizer(SCM_OBJ(obj), fp_finalize, data->cleanup);
2608     }
2609     return obj;
2610 }
2611 
2612 ScmObj Scm_MakeForeignPointer(ScmClass *klass, void *ptr)
2613 {
2614     ScmForeignPointer *obj;
2615     struct foreign_data_rec *data = (struct foreign_data_rec *)klass->data;
2616     
2617     if (!klass) {               /* for extra safety */
2618         Scm_Error("NULL pointer passed to Scm_MakeForeignPointer");
2619     }
2620     if (!Scm_SubtypeP(klass, SCM_CLASS_FOREIGN_POINTER)) {
2621         Scm_Error("attempt to instantiate non-foreign-pointer class %S via Scm_MakeForeignPointer", klass);
2622     }
2623 
2624     if (ptr == NULL && (data->flags & SCM_FOREIGN_POINTER_MAP_NULL)) {
2625         return SCM_FALSE;
2626     }
2627 
2628     if (data->identity_map) {
2629         ScmHashEntry *e = Scm_HashTableAddRaw(data->identity_map, ptr, NULL);
2630         if (e->value) {
2631             if (Scm_WeakBoxEmptyP((ScmWeakBox*)e->value)) {
2632                 obj = make_foreign_int(klass, ptr, data);
2633                 Scm_WeakBoxSet((ScmWeakBox*)e->value, obj);
2634             } else {
2635                 obj = (ScmForeignPointer*)Scm_WeakBoxRef((ScmWeakBox*)e->value);
2636             }
2637         } else {
2638             obj = make_foreign_int(klass, ptr, data);
2639             e->value = Scm_MakeWeakBox(obj);
2640         }
2641     } else {
2642         obj = make_foreign_int(klass, ptr, data);
2643     }
2644     return SCM_OBJ(obj);
2645 }
2646 
2647 ScmObj Scm_ForeignPointerAttr(ScmForeignPointer *fp)
2648 {
2649     return fp->attributes;
2650 }
2651 
2652 ScmObj Scm_ForeignPointerAttrGet(ScmForeignPointer *fp,
2653                                  ScmObj key, ScmObj fallback)
2654 {
2655     ScmObj p = Scm_Assq(key, fp->attributes);
2656     if (SCM_PAIRP(p)) return SCM_CDR(p);
2657     if (SCM_UNBOUNDP(fallback)) {
2658         Scm_Error("No value associated with key %S in a foreign pointer %S",
2659                   key, SCM_OBJ(fp));
2660     }
2661     return fallback;
2662 }
2663 
2664 ScmObj Scm_ForeignPointerAttrSet(ScmForeignPointer *fp,
2665                                  ScmObj key, ScmObj value)
2666 {
2667     ScmObj p = Scm_Assq(key, fp->attributes);
2668     if (SCM_PAIRP(p)) return SCM_SET_CDR(p, value);
2669     else fp->attributes = Scm_Acons(key, value, fp->attributes);
2670     return SCM_UNDEFINED;
2671 }
2672 
2673 /*=====================================================================
2674  * Class initialization
2675  */
2676 
2677 /* TODO: need a cleaner way! */
2678 /* static declaration of some structures */
2679 
2680 static ScmClassStaticSlotSpec class_slots[] = {
2681     SCM_CLASS_SLOT_SPEC("name", class_name, class_name_set),
2682     SCM_CLASS_SLOT_SPEC("cpl",  class_cpl, class_cpl_set),
2683     SCM_CLASS_SLOT_SPEC("direct-supers",  class_direct_supers, class_direct_supers_set),
2684     SCM_CLASS_SLOT_SPEC("accessors", class_accessors, class_accessors_set),
2685     SCM_CLASS_SLOT_SPEC("slots", class_slots_ref, class_slots_set),
2686     SCM_CLASS_SLOT_SPEC("direct-slots", class_direct_slots, class_direct_slots_set),
2687     SCM_CLASS_SLOT_SPEC("num-instance-slots", class_numislots, class_numislots_set),
2688     SCM_CLASS_SLOT_SPEC("direct-subclasses", class_direct_subclasses, NULL),
2689     SCM_CLASS_SLOT_SPEC("direct-methods", class_direct_methods, NULL),
2690     SCM_CLASS_SLOT_SPEC("initargs", class_initargs, class_initargs_set),
2691     SCM_CLASS_SLOT_SPEC("defined-modules", class_defined_modules, class_defined_modules_set),
2692     SCM_CLASS_SLOT_SPEC("redefined", class_redefined, NULL),
2693     SCM_CLASS_SLOT_SPEC("category", class_category, NULL),
2694     { NULL }
2695 };
2696 
2697 static ScmClassStaticSlotSpec generic_slots[] = {
2698     SCM_CLASS_SLOT_SPEC("name", generic_name, generic_name_set),
2699     SCM_CLASS_SLOT_SPEC("methods", generic_methods, generic_methods_set),
2700     { NULL }
2701 };
2702 
2703 static ScmClassStaticSlotSpec method_slots[] = {
2704     SCM_CLASS_SLOT_SPEC("required", method_required, NULL),
2705     SCM_CLASS_SLOT_SPEC("optional", method_optional, NULL),
2706     SCM_CLASS_SLOT_SPEC("generic", method_generic, method_generic_set),
2707     SCM_CLASS_SLOT_SPEC("specializers", method_specializers, method_specializers_set),
2708     { NULL }
2709 };
2710 
2711 static ScmClassStaticSlotSpec accessor_method_slots[] = {
2712     SCM_CLASS_SLOT_SPEC("required", method_required, NULL),
2713     SCM_CLASS_SLOT_SPEC("optional", method_optional, NULL),
2714     SCM_CLASS_SLOT_SPEC("generic", method_generic, method_generic_set),
2715     SCM_CLASS_SLOT_SPEC("specializers", method_specializers, method_specializers_set),
2716     SCM_CLASS_SLOT_SPEC("slot-accessor", accessor_method_slot_accessor, accessor_method_slot_accessor_set),
2717     { NULL }
2718 };
2719 
2720 static ScmClassStaticSlotSpec slot_accessor_slots[] = {
2721     SCM_CLASS_SLOT_SPEC("class", slot_accessor_class,
2722                         slot_accessor_class_set),
2723     SCM_CLASS_SLOT_SPEC("name", slot_accessor_name,
2724                         slot_accessor_name_set),
2725     SCM_CLASS_SLOT_SPEC("init-value", slot_accessor_init_value,
2726                         slot_accessor_init_value_set),
2727     SCM_CLASS_SLOT_SPEC("init-keyword", slot_accessor_init_keyword,
2728                         slot_accessor_init_keyword_set),
2729     SCM_CLASS_SLOT_SPEC("init-thunk", slot_accessor_init_thunk,
2730                         slot_accessor_init_thunk_set),
2731     SCM_CLASS_SLOT_SPEC("initializable", slot_accessor_initializable,
2732                         slot_accessor_initializable_set),
2733     SCM_CLASS_SLOT_SPEC("slot-number", slot_accessor_slot_number,
2734                         slot_accessor_slot_number_set),
2735     SCM_CLASS_SLOT_SPEC("getter", slot_accessor_scheme_getter,
2736                         slot_accessor_scheme_getter_set),
2737     SCM_CLASS_SLOT_SPEC("setter", slot_accessor_scheme_setter,
2738                         slot_accessor_scheme_setter_set),
2739     SCM_CLASS_SLOT_SPEC("bound?", slot_accessor_scheme_boundp,
2740                         slot_accessor_scheme_boundp_set),
2741     { NULL }
2742 };
2743 
2744 /*
2745  * Sets up CPL from CPA
2746  */
2747 static void initialize_builtin_cpl(ScmClass *klass, ScmObj supers)
2748 {
2749     ScmClass **p;
2750     ScmObj h = SCM_NIL, t;
2751     
2752     SCM_APPEND1(h, t, SCM_OBJ(klass));
2753     for (p = klass->cpa; *p; p++) SCM_APPEND1(h, t, SCM_OBJ(*p));
2754     klass->cpl = h;
2755     if (SCM_PAIRP(supers)) {
2756         /* Check validity of the given supers. */
2757         ScmObj cp, sp = supers;
2758         SCM_FOR_EACH(cp, klass->cpl) {
2759             if (SCM_EQ(SCM_CAR(cp), SCM_CAR(sp))) {
2760                 sp = SCM_CDR(sp);
2761                 if (SCM_NULLP(sp)) break;
2762             }
2763         }
2764         if (!SCM_NULLP(sp)) {
2765             /* NB: At this point we may not have initialized error handing
2766                mechanism, so we have no option but quit. */
2767             const char *cname = "(unnamed class)";
2768             if (SCM_STRINGP(klass->name)) {
2769                 cname = Scm_GetStringConst(SCM_STRING(klass->name));
2770             }
2771             Scm_Panic("Class %s is being initialized with inconsistent super class list.  Must be an implementation error.  Report to the author.", cname);
2772         }
2773         klass->directSupers = supers;
2774     } else if (SCM_PAIRP(SCM_CDR(h))) {
2775         /* Default: take the next class of CPL as the only direct super */
2776         klass->directSupers = SCM_LIST1(SCM_CADR(h));
2777     } else {
2778         /* Should this happen? */
2779         klass->directSupers = SCM_NIL;
2780     }
2781 }
2782 
2783 /*
2784  * A common part for builtin class initialization
2785  */
2786 static void init_class(ScmClass *klass, 
2787                        const char *name,
2788                        ScmModule *mod,
2789                        ScmObj supers,  /* SCM_FALSE if using default */
2790                        ScmClassStaticSlotSpec *specs,
2791                        int flags)  /* reserved */
2792 {
2793     ScmObj slots = SCM_NIL, t = SCM_NIL;
2794     ScmObj acc = SCM_NIL, sp;
2795     ScmClass **super;
2796 
2797     /* set class name first, for it may be used by error messages. */
2798     klass->name = SCM_INTERN(name);
2799 
2800     /* initialize CPL and directSupers */
2801     if (klass->cpa == NULL) {
2802         klass->cpa = SCM_CLASS_DEFAULT_CPL;
2803     }
2804     initialize_builtin_cpl(klass, supers);
2805 
2806     /* insert binding */
2807     Scm_Define(mod, SCM_SYMBOL(klass->name), SCM_OBJ(klass));
2808     
2809     /* initialize direct slots */
2810     if (specs) {
2811         for (;specs->name; specs++) {
2812             ScmObj snam = SCM_INTERN(specs->name);
2813             specs->accessor.klass = klass;
2814             specs->accessor.name = snam;
2815             acc = Scm_Acons(snam, SCM_OBJ(&specs->accessor), acc);
2816             specs->accessor.initKeyword = SCM_MAKE_KEYWORD(specs->name);
2817             SCM_APPEND1(slots, t,
2818                         Scm_List(snam,
2819                                  key_allocation, key_builtin,
2820                                  key_slot_accessor, SCM_OBJ(&specs->accessor),
2821                                  NULL));
2822         }
2823     }
2824     klass->directSlots = slots;
2825 
2826     /* compute other slots inherited from supers */
2827     for (super = klass->cpa; *super; super++) {
2828         SCM_FOR_EACH(sp, (*super)->directSlots) {
2829             ScmObj slot = SCM_CAR(sp), snam, p, a;
2830             SCM_ASSERT(SCM_PAIRP(slot));
2831             snam = SCM_CAR(slot);
2832             p = Scm_Assq(snam, slots);
2833             if (SCM_FALSEP(p)) {
2834                 slots = Scm_Cons(Scm_CopyList(slot), slots);
2835                 a = Scm_GetKeyword(key_slot_accessor, SCM_CDR(slot), SCM_FALSE);
2836                 SCM_ASSERT(SCM_HOBJP(a));
2837                 SCM_ASSERT(SCM_SLOT_ACCESSOR_P(a));
2838                 acc = Scm_Acons(snam, a, acc);
2839             }
2840         }
2841     }
2842     klass->slots = slots;
2843     klass->accessors = acc;
2844 }
2845 
2846 /*
2847  * Inter-module API
2848  */
2849 
2850 /* The most standard way to initialize a class. */
2851 void Scm_InitStaticClass(ScmClass *klass,
2852                          const char *name,
2853                          ScmModule *mod,
2854                          ScmClassStaticSlotSpec *specs,
2855                          int flags) /* reserved */
2856 {
2857     init_class(klass, name, mod, SCM_FALSE, specs, flags);
2858 }
2859 
2860 /* If the builtin class needs multiple inheritance... */
2861 void Scm_InitStaticClassWithSupers(ScmClass *klass,
2862                                    const char *name,
2863                                    ScmModule *mod,
2864                                    ScmObj supers,
2865                                    ScmClassStaticSlotSpec *specs,
2866                                    int flags) /* reserved */
2867 {
2868     init_class(klass, name, mod, supers, specs, flags);
2869 }
2870 
2871 /* A special initialization for some of builtin classes.
2872    Sets klass's metaclass to META.  If META is NULL, a new metaclass
2873    (whose name has "-meta" after the original class name except brackets)
2874    is created automatically.  This procedure should be only if
2875    metaclass is absolutely required (e.g. all condition classes should
2876    be an instance of <condition-meta>).   The older version of Gauche
2877    has metaclasses for many builtin classes, which is a compensation of
2878    lack of eqv-method specializer; such use of metaclass is deprecated
2879    and will be removed in future. */
2880 void Scm_InitStaticClassWithMeta(ScmClass *klass,
2881                                  const char *name,
2882                                  ScmModule *mod,
2883                                  ScmClass *meta,
2884                                  ScmObj supers,
2885                                  ScmClassStaticSlotSpec *specs,
2886                                  int flags)
2887 {
2888     init_class(klass, name, mod, supers, specs, flags);
2889 
2890     if (meta) {
2891         SCM_SET_CLASS(klass, meta);
2892     } else {
2893         int nlen;
2894         char *metaname;
2895     
2896         nlen = strlen(name);
2897         metaname = SCM_NEW_ATOMIC2(char *, nlen + 6);
2898 
2899         if (name[nlen - 1] == '>') {
2900             strncpy(metaname, name, nlen-1);
2901             strcpy(metaname+nlen-1, "-meta>");
2902         } else {
2903             strcpy(metaname, name);
2904             strcat(metaname, "-meta");
2905         }
2906         SCM_SET_CLASS(klass, make_implicit_meta(metaname, klass->cpa, mod));
2907     }
2908 }
2909 
2910 /* The old API - deprecated.  We keep this around for a while
2911    for backward compatibility. */
2912 void Scm_InitBuiltinClass(ScmClass *klass, const char *name,
2913                           ScmClassStaticSlotSpec *specs,
2914                           int withMeta, ScmModule *mod)
2915 {
2916     if (withMeta) {
2917         Scm_InitStaticClassWithMeta(klass, name, mod, NULL, SCM_FALSE, specs, 0);
2918     } else {
2919         Scm_InitStaticClass(klass, name, mod, specs, 0);
2920     }
2921 }
2922 
2923 void Scm_InitBuiltinGeneric(ScmGeneric *gf, const char *name, ScmModule *mod)
2924 {
2925     ScmObj s = SCM_INTERN(name);
2926     gf->common.info = s;
2927     if (gf->fallback == NULL) {
2928         gf->fallback = Scm_NoNextMethod;
2929     }
2930     (void)SCM_INTERNAL_MUTEX_INIT(gf->lock);
2931     Scm_Define(mod, SCM_SYMBOL(s), SCM_OBJ(gf));
2932 }
2933 
2934 void Scm_InitBuiltinMethod(ScmMethod *m)
2935 {
2936     m->common.info = Scm_Cons(m->generic->common.info,
2937                               class_array_to_names(m->specializers,
2938                                                    m->common.required));
2939     Scm_AddMethod(m->generic, m);
2940 }
2941 
2942 void Scm__InitClass(void)
2943 {
2944     ScmModule *mod = Scm_GaucheModule();
2945     static ScmClass *nullcpa[1] = {NULL}; /* for <top> */
2946     
2947     key_allocation = SCM_MAKE_KEYWORD("allocation");
2948     key_builtin = SCM_MAKE_KEYWORD("builtin");
2949     key_slot_accessor = SCM_MAKE_KEYWORD("slot-accessor");
2950     key_name = SCM_MAKE_KEYWORD("name");
2951     key_lambda_list = SCM_MAKE_KEYWORD("lambda-list");
2952     key_generic = SCM_MAKE_KEYWORD("generic");
2953     key_specializers = SCM_MAKE_KEYWORD("specializers");
2954     key_body = SCM_MAKE_KEYWORD("body");
2955 
2956     (void)SCM_INTERNAL_MUTEX_INIT(class_redefinition_lock.mutex);
2957     (void)SCM_INTERNAL_COND_INIT(class_redefinition_lock.cv);
2958     
2959     /* booting class metaobject */
2960     Scm_TopClass.cpa = nullcpa;
2961 
2962 #define BINIT(cl, nam, slots) \
2963     Scm_InitStaticClass(cl, nam, mod, slots, 0)
2964 
2965 #define CINIT(cl, nam) \
2966     Scm_InitStaticClassWithMeta(cl, nam, mod, NULL, SCM_FALSE, NULL, 0)
2967     
2968     /* class.c */
2969     BINIT(SCM_CLASS_CLASS,  "<class>", class_slots);
2970     BINIT(SCM_CLASS_TOP,    "<top>",     NULL);
2971     CINIT(SCM_CLASS_BOOL,   "<boolean>");
2972     CINIT(SCM_CLASS_CHAR,   "<char>");
2973     BINIT(SCM_CLASS_EOF_OBJECT,"<eof-object>", NULL);
2974     BINIT(SCM_CLASS_UNDEFINED_OBJECT,"<undefined-object>", NULL);
2975     BINIT(SCM_CLASS_UNKNOWN,"<unknown>", NULL);
2976     BINIT(SCM_CLASS_OBJECT, "<object>",  NULL);
2977     BINIT(SCM_CLASS_GENERIC,"<generic>", generic_slots);
2978     Scm_GenericClass.flags |= SCM_CLASS_APPLICABLE;
2979     BINIT(SCM_CLASS_METHOD, "<method>",  method_slots);
2980     Scm_MethodClass.flags |= SCM_CLASS_APPLICABLE;
2981     BINIT(SCM_CLASS_NEXT_METHOD, "<next-method>", NULL);
2982     Scm_NextMethodClass.flags |= SCM_CLASS_APPLICABLE;
2983     BINIT(SCM_CLASS_ACCESSOR_METHOD, "<accessor-method>", accessor_method_slots);
2984     Scm_AccessorMethodClass.flags |= SCM_CLASS_APPLICABLE;
2985     BINIT(SCM_CLASS_SLOT_ACCESSOR,"<slot-accessor>", slot_accessor_slots);
2986     BINIT(SCM_CLASS_COLLECTION, "<collection>", NULL);
2987     BINIT(SCM_CLASS_SEQUENCE,   "<sequence>", NULL);
2988     BINIT(SCM_CLASS_FOREIGN_POINTER, "<foreign-pointer>", NULL);
2989 
2990     /* char.c */
2991     CINIT(SCM_CLASS_CHARSET,          "<char-set>");
2992 
2993     /* compile.c */
2994     /* initialized in Scm__InitCompiler */
2995 
2996     /* error.c */
2997     /* initialized in Scm__InitExceptions */
2998 
2999     /* hash.c */
3000     CINIT(SCM_CLASS_HASH_TABLE,       "<hash-table>");
3001 
3002     /* keyword.c */
3003     CINIT(SCM_CLASS_KEYWORD,          "<keyword>");
3004 
3005     /* list.c */
3006     CINIT(SCM_CLASS_LIST,             "<list>");
3007     CINIT(SCM_CLASS_PAIR,             "<pair>");
3008     CINIT(SCM_CLASS_NULL,             "<null>");
3009 
3010     /* load.c */
3011     CINIT(SCM_CLASS_AUTOLOAD,         "<autoload>");
3012 
3013     /* macro.c */
3014     CINIT(SCM_CLASS_SYNTAX,           "<syntax>");
3015     CINIT(SCM_CLASS_MACRO,            "<macro>");
3016     CINIT(SCM_CLASS_SYNTAX_PATTERN,   "<syntax-pattern>");
3017     CINIT(SCM_CLASS_SYNTAX_RULES,     "<syntax-rules>");
3018 
3019     /* module.c */
3020     CINIT(SCM_CLASS_MODULE,           "<module>");
3021 
3022     /* number.c */
3023     CINIT(SCM_CLASS_NUMBER,           "<number>");
3024     CINIT(SCM_CLASS_COMPLEX,          "<complex>");
3025     CINIT(SCM_CLASS_REAL,             "<real>");
3026     CINIT(SCM_CLASS_INTEGER,          "<integer>");
3027 
3028     /* port.c */
3029     /* initialized in Scm__InitPort */
3030 
3031     /* proc.c */
3032     /* initialized in Scm__InitProc */
3033 
3034     /* promise.c */
3035     CINIT(SCM_CLASS_PROMISE,          "<promise>");
3036 
3037     /* read.c */
3038     BINIT(SCM_CLASS_READ_REFERENCE,   "<read-reference>", NULL);
3039     
3040     /* regexp.c */
3041     CINIT(SCM_CLASS_REGEXP,           "<regexp>");
3042     CINIT(SCM_CLASS_REGMATCH,         "<regmatch>");
3043 
3044     /* string.c */
3045     CINIT(SCM_CLASS_STRING,           "<string>");
3046     CINIT(SCM_CLASS_STRING_POINTER,   "<string-pointer>");
3047 
3048     /* symbol.c */
3049     CINIT(SCM_CLASS_SYMBOL,           "<symbol>");
3050     CINIT(SCM_CLASS_GLOC,             "<gloc>");
3051 
3052     /* system.c */
3053     /* initialized in Scm__InitSystem */
3054     
3055     /* vector.c */
3056     CINIT(SCM_CLASS_VECTOR,           "<vector>");
3057     
3058     /* weak.c */
3059     CINIT(SCM_CLASS_WEAK_VECTOR,      "<weak-vector>");
3060 
3061 #define GINIT(gf, nam) \
3062     Scm_InitBuiltinGeneric(gf, nam, mod);
3063 
3064     GINIT(&Scm_GenericMake, "make");
3065     GINIT(&Scm_GenericAllocate, "allocate-instance");
3066     GINIT(&Scm_GenericInitialize, "initialize");
3067     GINIT(&Scm_GenericAddMethod, "add-method!");
3068     GINIT(&Scm_GenericDeleteMethod, "delete-method!");
3069     GINIT(&Scm_GenericComputeCPL, "compute-cpl");
3070     GINIT(&Scm_GenericComputeSlots, "compute-slots");
3071     GINIT(&Scm_GenericComputeGetNSet, "compute-get-n-set");
3072     GINIT(&Scm_GenericComputeApplicableMethods, "compute-applicable-methods");
3073     GINIT(&Scm_GenericUpdateDirectMethod, "update-direct-method!");
3074     GINIT(&Scm_GenericMethodMoreSpecificP, "method-more-specific?");
3075     GINIT(&Scm_GenericApplyGeneric, "apply-generic");
3076     GINIT(&Scm_GenericSlotMissing, "slot-missing");
3077     GINIT(&Scm_GenericSlotUnbound, "slot-unbound");
3078     GINIT(&Scm_GenericSlotRefUsingClass, "slot-ref-using-class");
3079     GINIT(&Scm_GenericSlotSetUsingClass, "slot-set-using-class!");
3080     GINIT(&Scm_GenericSlotBoundUsingClassP, "slot-bound-using-class?");
3081     GINIT(&Scm_GenericObjectEqualP, "object-equal?");
3082     GINIT(&Scm_GenericObjectCompare, "object-compare");
3083     GINIT(&Scm_GenericObjectHash, "object-hash");
3084     GINIT(&Scm_GenericObjectApply, "object-apply");
3085     GINIT(&Scm_GenericObjectSetter, "setter of object-apply");
3086     GINIT(&Scm_GenericChangeClass, "change-class");
3087 
3088     Scm_SetterSet(SCM_PROCEDURE(&Scm_GenericObjectApply),
3089                   SCM_PROCEDURE(&Scm_GenericObjectSetter),
3090                   TRUE);
3091 
3092     Scm_InitBuiltinMethod(&class_allocate_rec);
3093     Scm_InitBuiltinMethod(&class_compute_cpl_rec);
3094     Scm_InitBuiltinMethod(&slot_ref_using_class_rec);
3095     Scm_InitBuiltinMethod(&slot_set_using_class_rec);
3096     Scm_InitBuiltinMethod(&slot_bound_using_class_p_rec);
3097     Scm_InitBuiltinMethod(&object_initialize_rec);
3098     Scm_InitBuiltinMethod(&generic_addmethod_rec);
3099     Scm_InitBuiltinMethod(&generic_deletemethod_rec);
3100     Scm_InitBuiltinMethod(&method_initialize_rec);
3101     Scm_InitBuiltinMethod(&accessor_method_initialize_rec);
3102     Scm_InitBuiltinMethod(&compute_applicable_methods_rec);
3103     Scm_InitBuiltinMethod(&generic_updatedirectmethod_rec);
3104     Scm_InitBuiltinMethod(&method_more_specific_p_rec);
3105     Scm_InitBuiltinMethod(&object_equalp_rec);
3106     Scm_InitBuiltinMethod(&object_compare_rec);
3107 }

/* [<][>][^][v][top][bottom][index][help] */