/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- class_list_to_array
- class_array_to_list
- class_array_to_names
- Scm__InternalClassName
- class_allocate
- class_print
- allocate
- class_compute_cpl
- Scm_ClassOf
- Scm_BaseClassOf
- class_of_cc
- Scm_VMClassOf
- is_a_cc
- Scm_VMIsA
- class_name
- class_name_set
- class_cpl
- class_cpl_set
- class_direct_supers
- class_direct_supers_set
- class_direct_slots
- class_direct_slots_set
- class_slots_ref
- class_slots_set
- class_accessors
- class_accessors_set
- class_numislots
- class_numislots_set
- class_category
- class_initargs
- class_initargs_set
- class_defined_modules
- class_defined_modules_set
- class_direct_subclasses
- class_direct_methods
- class_redefined
- make_implicit_meta
- Scm_SubtypeP
- Scm_TypeP
- Scm_ComputeCPL
- lock_class_redefinition
- unlock_class_redefinition
- Scm_StartClassRedefinition
- Scm_CommitClassRedefinition
- Scm_CheckClassBinding
- Scm_ReplaceClassBinding
- Scm_AddDirectSubclass
- Scm_DeleteDirectSubclass
- Scm_AddDirectMethod
- Scm_DeleteDirectMethod
- Scm_TransplantInstance
- Scm_VMTouchInstance
- Scm_AllocateInstance
- instance_class_redefinition
- scheme_slot_ref
- scheme_slot_set
- Scm_InstanceSlotRef
- Scm_InstanceSlotSet
- slot_initialize_cc
- Scm_VMSlotInitializeUsingAccessor
- Scm_GetSlotAccessor
- slot_ref_using_accessor_cc
- slot_boundp_using_accessor_cc
- slot_ref_using_accessor
- slot_ref_cc
- Scm_VMSlotRef
- slot_ref_using_accessor_cc1
- Scm_VMSlotRefUsingAccessor
- slot_ref_using_class
- slot_set_using_accessor
- slot_set_cc
- Scm_VMSlotSet
- slot_set_using_accessor_cc
- Scm_VMSlotSetUsingAccessor
- slot_set_using_class
- slot_boundp_cc
- Scm_VMSlotBoundP
- slot_bound_using_class_p
- builtin_initialize
- slot_accessor_allocate
- slot_accessor_print
- slot_accessor_class
- slot_accessor_class_set
- slot_accessor_name
- slot_accessor_name_set
- slot_accessor_init_value
- slot_accessor_init_value_set
- slot_accessor_init_keyword
- slot_accessor_init_keyword_set
- slot_accessor_init_thunk
- slot_accessor_init_thunk_set
- slot_accessor_slot_number
- slot_accessor_slot_number_set
- slot_accessor_initializable
- slot_accessor_initializable_set
- slot_accessor_scheme_getter
- slot_accessor_scheme_getter_set
- slot_accessor_scheme_setter
- slot_accessor_scheme_setter_set
- slot_accessor_scheme_boundp
- slot_accessor_scheme_boundp_set
- Scm_ObjectAllocate
- object_initialize1
- object_initialize_cc
- object_initialize
- object_compare
- object_compare_default
- generic_allocate
- generic_print
- generic_name
- generic_name_set
- generic_methods
- generic_methods_set
- Scm_MakeBaseGeneric
- Scm_NoNextMethod
- Scm_NoOperation
- Scm_InvalidApply
- Scm_ComputeApplicableMethods
- compute_applicable_methods
- method_more_specific
- method_more_specific_p
- Scm_SortMethods
- method_allocate
- method_print
- method_initialize
- method_required
- method_optional
- method_generic
- method_generic_set
- method_specializers
- method_specializers_set
- Scm_UpdateDirectMethod
- generic_updatedirectmethod
- Scm_AddMethod
- generic_addmethod
- Scm_DeleteMethod
- generic_deletemethod
- Scm_MakeNextMethod
- next_method_print
- accessor_method_print
- accessor_get_proc
- accessor_set_proc
- accessor_method_initialize
- accessor_method_slot_accessor
- accessor_method_slot_accessor_set
- Scm_MakeForeignPointerClass
- fp_finalize
- make_foreign_int
- Scm_MakeForeignPointer
- Scm_ForeignPointerAttr
- Scm_ForeignPointerAttrGet
- Scm_ForeignPointerAttrSet
- initialize_builtin_cpl
- init_class
- Scm_InitStaticClass
- Scm_InitStaticClassWithSupers
- Scm_InitStaticClassWithMeta
- Scm_InitBuiltinClass
- Scm_InitBuiltinGeneric
- Scm_InitBuiltinMethod
- 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 }