generic dispatch protocol in scheme, not yet wired up
[bpt/guile.git] / libguile / goops.c
1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
2 * Free Software Foundation, Inc.
3 *
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
13 *
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
18 */
19 \f
20
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 *
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
26 */
27
28 #ifdef HAVE_CONFIG_H
29 # include <config.h>
30 #endif
31
32 #include <stdio.h>
33 #include <assert.h>
34
35 #include "libguile/_scm.h"
36 #include "libguile/alist.h"
37 #include "libguile/async.h"
38 #include "libguile/chars.h"
39 #include "libguile/debug.h"
40 #include "libguile/dynl.h"
41 #include "libguile/dynwind.h"
42 #include "libguile/eval.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
57 #include "libguile/vm.h"
58
59 #include "libguile/validate.h"
60 #include "libguile/goops.h"
61
62 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
63
64 #define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
65 #define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
66 #define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
67 #define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
68
69 /* Port classes */
70 #define SCM_IN_PCLASS_INDEX 0
71 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
72 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
73
74 /* this file is a mess. in theory, though, we shouldn't have many SCM references
75 -- most of the references should be to vars. */
76
77 static SCM var_slot_unbound = SCM_BOOL_F;
78 static SCM var_slot_missing = SCM_BOOL_F;
79 static SCM var_compute_cpl = SCM_BOOL_F;
80 static SCM var_no_applicable_method = SCM_BOOL_F;
81 static SCM var_memoize_method_x = SCM_BOOL_F;
82 static SCM var_change_class = SCM_BOOL_F;
83
84 SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
85 SCM_SYMBOL (sym_slot_missing, "slot-missing");
86 SCM_SYMBOL (sym_compute_cpl, "compute-cpl");
87 SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method");
88 SCM_SYMBOL (sym_memoize_method_x, "memoize-method!");
89 SCM_SYMBOL (sym_change_class, "change-class");
90
91 SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
92
93
94 /* FIXME, exports should come from the scm file only */
95 #define DEFVAR(v, val) \
96 { scm_module_define (scm_module_goops, (v), (val)); \
97 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
98 }
99
100
101 /* Class redefinition protocol:
102
103 A class is represented by a heap header h1 which points to a
104 malloc:ed memory block m1.
105
106 When a new version of a class is created, a new header h2 and
107 memory block m2 are allocated. The headers h1 and h2 then switch
108 pointers so that h1 refers to m2 and h2 to m1. In this way, names
109 bound to h1 will point to the new class at the same time as h2 will
110 be a handle which the GC will use to free m1.
111
112 The `redefined' slot of m1 will be set to point to h1. An old
113 instance will have its class pointer (the CAR of the heap header)
114 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
115 the class modification and the new class pointer can be found via
116 h1.
117 */
118
119 #define TEST_CHANGE_CLASS(obj, class) \
120 { \
121 class = SCM_CLASS_OF (obj); \
122 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
123 { \
124 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
125 class = SCM_CLASS_OF (obj); \
126 } \
127 }
128
129 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
130 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
131
132 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
133 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
134
135 static int goops_loaded_p = 0;
136 static scm_t_rstate *goops_rstate;
137
138 /* These variables are filled in by the object system when loaded. */
139 SCM scm_class_boolean, scm_class_char, scm_class_pair;
140 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
141 SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
142 SCM scm_class_vector, scm_class_null;
143 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
144 SCM scm_class_unknown;
145 SCM scm_class_top, scm_class_object, scm_class_class;
146 SCM scm_class_applicable;
147 SCM scm_class_entity, scm_class_entity_with_setter;
148 SCM scm_class_generic, scm_class_generic_with_setter;
149 SCM scm_class_accessor;
150 SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
151 SCM scm_class_extended_accessor;
152 SCM scm_class_method;
153 SCM scm_class_simple_method, scm_class_accessor_method;
154 SCM scm_class_procedure_class;
155 SCM scm_class_entity_class;
156 SCM scm_class_number, scm_class_list;
157 SCM scm_class_keyword;
158 SCM scm_class_port, scm_class_input_output_port;
159 SCM scm_class_input_port, scm_class_output_port;
160 SCM scm_class_foreign_class, scm_class_foreign_object;
161 SCM scm_class_foreign_slot;
162 SCM scm_class_self, scm_class_protected;
163 SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
164 SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
165 SCM scm_class_scm;
166 SCM scm_class_int, scm_class_float, scm_class_double;
167
168 /* Port classes. Allocate 3 times the maximum number of port types so that
169 input ports, output ports, and in/out ports can be stored at different
170 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
171 SCM scm_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
172
173 /* SMOB classes. */
174 SCM scm_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
175
176 SCM scm_no_applicable_method;
177
178 SCM_SYMBOL (scm_sym_define_public, "define-public");
179
180 static SCM scm_make_unbound (void);
181 static SCM scm_unbound_p (SCM obj);
182 static SCM scm_assert_bound (SCM value, SCM obj);
183 static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
184 static SCM scm_sys_goops_loaded (void);
185 static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
186 int applicablep);
187
188 /* This function is used for efficient type dispatch. */
189 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
190 (SCM x),
191 "Return the class of @var{x}.")
192 #define FUNC_NAME s_scm_class_of
193 {
194 switch (SCM_ITAG3 (x))
195 {
196 case scm_tc3_int_1:
197 case scm_tc3_int_2:
198 return scm_class_integer;
199
200 case scm_tc3_imm24:
201 if (SCM_CHARP (x))
202 return scm_class_char;
203 else if (scm_is_bool (x))
204 return scm_class_boolean;
205 else if (scm_is_null (x))
206 return scm_class_null;
207 else
208 return scm_class_unknown;
209
210 case scm_tc3_cons:
211 switch (SCM_TYP7 (x))
212 {
213 case scm_tcs_cons_nimcar:
214 return scm_class_pair;
215 case scm_tcs_closures:
216 return scm_class_procedure;
217 case scm_tc7_symbol:
218 return scm_class_symbol;
219 case scm_tc7_vector:
220 case scm_tc7_wvect:
221 return scm_class_vector;
222 case scm_tc7_string:
223 return scm_class_string;
224 case scm_tc7_number:
225 switch SCM_TYP16 (x) {
226 case scm_tc16_big:
227 return scm_class_integer;
228 case scm_tc16_real:
229 return scm_class_real;
230 case scm_tc16_complex:
231 return scm_class_complex;
232 case scm_tc16_fraction:
233 return scm_class_fraction;
234 }
235 case scm_tc7_asubr:
236 case scm_tc7_subr_0:
237 case scm_tc7_subr_1:
238 case scm_tc7_dsubr:
239 case scm_tc7_cxr:
240 case scm_tc7_subr_3:
241 case scm_tc7_subr_2:
242 case scm_tc7_rpsubr:
243 case scm_tc7_subr_1o:
244 case scm_tc7_subr_2o:
245 case scm_tc7_lsubr_2:
246 case scm_tc7_lsubr:
247 if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
248 return scm_class_primitive_generic;
249 else
250 return scm_class_procedure;
251 case scm_tc7_gsubr:
252 case scm_tc7_program:
253 return scm_class_procedure;
254 case scm_tc7_pws:
255 return scm_class_procedure_with_setter;
256
257 case scm_tc7_smob:
258 {
259 scm_t_bits type = SCM_TYP16 (x);
260 if (type != scm_tc16_port_with_ps)
261 return scm_smob_class[SCM_TC2SMOBNUM (type)];
262 x = SCM_PORT_WITH_PS_PORT (x);
263 /* fall through to ports */
264 }
265 case scm_tc7_port:
266 return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
267 ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
268 ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
269 : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
270 : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
271 case scm_tcs_struct:
272 if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
273 return SCM_CLASS_OF (x);
274 else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
275 {
276 /* Goops object */
277 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
278 scm_change_object_class (x,
279 SCM_CLASS_OF (x), /* old */
280 SCM_OBJ_CLASS_REDEF (x)); /* new */
281 return SCM_CLASS_OF (x);
282 }
283 else
284 {
285 /* ordinary struct */
286 SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
287 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
288 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
289 else
290 {
291 SCM class, name;
292
293 name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
294 if (!scm_is_symbol (name))
295 name = scm_string_to_symbol (scm_nullstr);
296
297 class =
298 scm_make_extended_class_from_symbol (name,
299 SCM_STRUCT_APPLICABLE_P (x));
300 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
301 return class;
302 }
303 }
304 default:
305 if (scm_is_pair (x))
306 return scm_class_pair;
307 else
308 return scm_class_unknown;
309 }
310
311 case scm_tc3_struct:
312 case scm_tc3_tc7_1:
313 case scm_tc3_tc7_2:
314 case scm_tc3_closure:
315 /* Never reached */
316 break;
317 }
318 return scm_class_unknown;
319 }
320 #undef FUNC_NAME
321
322 /******************************************************************************
323 *
324 * Compute-cpl
325 *
326 * This version doesn't fully handle multiple-inheritance. It serves
327 * only for booting classes and will be overloaded in Scheme
328 *
329 ******************************************************************************/
330
331 static SCM
332 map (SCM (*proc) (SCM), SCM ls)
333 {
334 if (scm_is_null (ls))
335 return ls;
336 else
337 {
338 SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
339 SCM h = res;
340 ls = SCM_CDR (ls);
341 while (!scm_is_null (ls))
342 {
343 SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
344 h = SCM_CDR (h);
345 ls = SCM_CDR (ls);
346 }
347 return res;
348 }
349 }
350
351 static SCM
352 filter_cpl (SCM ls)
353 {
354 SCM res = SCM_EOL;
355 while (!scm_is_null (ls))
356 {
357 SCM el = SCM_CAR (ls);
358 if (scm_is_false (scm_c_memq (el, res)))
359 res = scm_cons (el, res);
360 ls = SCM_CDR (ls);
361 }
362 return res;
363 }
364
365 static SCM
366 compute_cpl (SCM class)
367 {
368 if (goops_loaded_p)
369 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
370 else
371 {
372 SCM supers = SCM_SLOT (class, scm_si_direct_supers);
373 SCM ls = scm_append (scm_acons (class, supers,
374 map (compute_cpl, supers)));
375 return scm_reverse_x (filter_cpl (ls), SCM_EOL);
376 }
377 }
378
379 /******************************************************************************
380 *
381 * compute-slots
382 *
383 ******************************************************************************/
384
385 static SCM
386 remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
387 {
388 SCM tmp;
389
390 if (scm_is_null (l))
391 return res;
392
393 tmp = SCM_CAAR (l);
394 if (!scm_is_symbol (tmp))
395 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
396
397 if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
398 res = scm_cons (SCM_CAR (l), res);
399 slots_already_seen = scm_cons (tmp, slots_already_seen);
400 }
401
402 return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
403 }
404
405 static SCM
406 build_slots_list (SCM dslots, SCM cpl)
407 {
408 register SCM res = dslots;
409
410 for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
411 res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
412 scm_si_direct_slots),
413 res));
414
415 /* res contains a list of slots. Remove slots which appears more than once */
416 return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
417 }
418
419 static SCM
420 maplist (SCM ls)
421 {
422 SCM orig = ls;
423 while (!scm_is_null (ls))
424 {
425 if (!scm_is_pair (SCM_CAR (ls)))
426 SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
427 ls = SCM_CDR (ls);
428 }
429 return orig;
430 }
431
432
433 SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
434 (SCM class),
435 "Return a list consisting of the names of all slots belonging to\n"
436 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
437 "its superclasses.")
438 #define FUNC_NAME s_scm_sys_compute_slots
439 {
440 SCM_VALIDATE_CLASS (1, class);
441 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
442 SCM_SLOT (class, scm_si_cpl));
443 }
444 #undef FUNC_NAME
445
446
447 /******************************************************************************
448 *
449 * compute-getters-n-setters
450 *
451 * This version doesn't handle slot options. It serves only for booting
452 * classes and will be overloaded in Scheme.
453 *
454 ******************************************************************************/
455
456 SCM_KEYWORD (k_init_value, "init-value");
457 SCM_KEYWORD (k_init_thunk, "init-thunk");
458
459 static SCM
460 compute_getters_n_setters (SCM slots)
461 {
462 SCM res = SCM_EOL;
463 SCM *cdrloc = &res;
464 long i = 0;
465
466 for ( ; !scm_is_null (slots); slots = SCM_CDR (slots))
467 {
468 SCM init = SCM_BOOL_F;
469 SCM options = SCM_CDAR (slots);
470 if (!scm_is_null (options))
471 {
472 init = scm_get_keyword (k_init_value, options, 0);
473 if (init)
474 {
475 init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
476 SCM_EOL,
477 scm_list_2 (scm_sym_quote,
478 init)),
479 SCM_EOL);
480 }
481 else
482 init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
483 }
484 *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
485 scm_cons (init,
486 scm_from_int (i++))),
487 SCM_EOL);
488 cdrloc = SCM_CDRLOC (*cdrloc);
489 }
490 return res;
491 }
492
493 /******************************************************************************
494 *
495 * initialize-object
496 *
497 ******************************************************************************/
498
499 /*fixme* Manufacture keywords in advance */
500 SCM
501 scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
502 {
503 long i;
504
505 for (i = 0; i != len; i += 2)
506 {
507 SCM obj = SCM_CAR (l);
508
509 if (!scm_is_keyword (obj))
510 scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
511 else if (scm_is_eq (obj, key))
512 return SCM_CADR (l);
513 else
514 l = SCM_CDDR (l);
515 }
516
517 return default_value;
518 }
519
520
521 SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
522 (SCM key, SCM l, SCM default_value),
523 "Determine an associated value for the keyword @var{key} from\n"
524 "the list @var{l}. The list @var{l} has to consist of an even\n"
525 "number of elements, where, starting with the first, every\n"
526 "second element is a keyword, followed by its associated value.\n"
527 "If @var{l} does not hold a value for @var{key}, the value\n"
528 "@var{default_value} is returned.")
529 #define FUNC_NAME s_scm_get_keyword
530 {
531 long len;
532
533 SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
534 len = scm_ilength (l);
535 if (len < 0 || len % 2 == 1)
536 scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
537
538 return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
539 }
540 #undef FUNC_NAME
541
542
543 SCM_KEYWORD (k_init_keyword, "init-keyword");
544
545 static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
546 static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
547
548 SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
549 (SCM obj, SCM initargs),
550 "Initialize the object @var{obj} with the given arguments\n"
551 "@var{initargs}.")
552 #define FUNC_NAME s_scm_sys_initialize_object
553 {
554 SCM tmp, get_n_set, slots;
555 SCM class = SCM_CLASS_OF (obj);
556 long n_initargs;
557
558 SCM_VALIDATE_INSTANCE (1, obj);
559 n_initargs = scm_ilength (initargs);
560 SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
561
562 get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
563 slots = SCM_SLOT (class, scm_si_slots);
564
565 /* See for each slot how it must be initialized */
566 for (;
567 !scm_is_null (slots);
568 get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
569 {
570 SCM slot_name = SCM_CAR (slots);
571 SCM slot_value = 0;
572
573 if (!scm_is_null (SCM_CDR (slot_name)))
574 {
575 /* This slot admits (perhaps) to be initialized at creation time */
576 long n = scm_ilength (SCM_CDR (slot_name));
577 if (n & 1) /* odd or -1 */
578 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
579 scm_list_1 (slot_name));
580 tmp = scm_i_get_keyword (k_init_keyword,
581 SCM_CDR (slot_name),
582 n,
583 0,
584 FUNC_NAME);
585 slot_name = SCM_CAR (slot_name);
586 if (tmp)
587 {
588 /* an initarg was provided for this slot */
589 if (!scm_is_keyword (tmp))
590 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
591 scm_list_1 (tmp));
592 slot_value = scm_i_get_keyword (tmp,
593 initargs,
594 n_initargs,
595 0,
596 FUNC_NAME);
597 }
598 }
599
600 if (slot_value)
601 /* set slot to provided value */
602 set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
603 else
604 {
605 /* set slot to its :init-form if it exists */
606 tmp = SCM_CADAR (get_n_set);
607 if (scm_is_true (tmp))
608 {
609 slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
610 if (SCM_GOOPS_UNBOUNDP (slot_value))
611 set_slot_value (class,
612 obj,
613 SCM_CAR (get_n_set),
614 scm_call_0 (tmp));
615 }
616 }
617 }
618
619 return obj;
620 }
621 #undef FUNC_NAME
622
623 /* NOTE: The following macros are interdependent with code
624 * in goops.scm:compute-getters-n-setters
625 */
626 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
627 (SCM_I_INUMP (SCM_CDDR (gns)) \
628 || (scm_is_pair (SCM_CDDR (gns)) \
629 && scm_is_pair (SCM_CDDDR (gns)) \
630 && scm_is_pair (SCM_CDDDDR (gns))))
631 #define SCM_GNS_INDEX(gns) \
632 (SCM_I_INUMP (SCM_CDDR (gns)) \
633 ? SCM_I_INUM (SCM_CDDR (gns)) \
634 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
635 #define SCM_GNS_SIZE(gns) \
636 (SCM_I_INUMP (SCM_CDDR (gns)) \
637 ? 1 \
638 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
639
640 SCM_KEYWORD (k_class, "class");
641 SCM_KEYWORD (k_allocation, "allocation");
642 SCM_KEYWORD (k_instance, "instance");
643
644 SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
645 (SCM class),
646 "")
647 #define FUNC_NAME s_scm_sys_prep_layout_x
648 {
649 SCM slots, getters_n_setters, nfields;
650 unsigned long int n, i;
651 char *s;
652 SCM layout;
653
654 SCM_VALIDATE_INSTANCE (1, class);
655 slots = SCM_SLOT (class, scm_si_slots);
656 getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
657 nfields = SCM_SLOT (class, scm_si_nfields);
658 if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
659 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
660 scm_list_1 (nfields));
661 n = 2 * SCM_I_INUM (nfields);
662 if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
663 && SCM_SUBCLASSP (class, scm_class_class))
664 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
665 scm_list_1 (nfields));
666
667 layout = scm_i_make_string (n, &s);
668 i = 0;
669 while (scm_is_pair (getters_n_setters))
670 {
671 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
672 {
673 SCM type;
674 int len, index, size;
675 char p, a;
676
677 if (i >= n || !scm_is_pair (slots))
678 goto inconsistent;
679
680 /* extract slot type */
681 len = scm_ilength (SCM_CDAR (slots));
682 type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
683 len, SCM_BOOL_F, FUNC_NAME);
684 /* determine slot GC protection and access mode */
685 if (scm_is_false (type))
686 {
687 p = 'p';
688 a = 'w';
689 }
690 else
691 {
692 if (!SCM_CLASSP (type))
693 SCM_MISC_ERROR ("bad slot class", SCM_EOL);
694 else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
695 {
696 if (SCM_SUBCLASSP (type, scm_class_self))
697 p = 's';
698 else if (SCM_SUBCLASSP (type, scm_class_protected))
699 p = 'p';
700 else
701 p = 'u';
702
703 if (SCM_SUBCLASSP (type, scm_class_opaque))
704 a = 'o';
705 else if (SCM_SUBCLASSP (type, scm_class_read_only))
706 a = 'r';
707 else if (SCM_SUBCLASSP (type, scm_class_hidden))
708 a = 'h';
709 else
710 a = 'w';
711 }
712 else
713 {
714 p = 'p';
715 a = 'w';
716 }
717 }
718
719 index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
720 if (index != (i >> 1))
721 goto inconsistent;
722 size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
723 while (size)
724 {
725 s[i++] = p;
726 s[i++] = a;
727 --size;
728 }
729 }
730 slots = SCM_CDR (slots);
731 getters_n_setters = SCM_CDR (getters_n_setters);
732 }
733 if (!scm_is_null (slots))
734 {
735 inconsistent:
736 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
737 }
738 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout));
739 return SCM_UNSPECIFIED;
740 }
741 #undef FUNC_NAME
742
743 static void prep_hashsets (SCM);
744
745 SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
746 (SCM class, SCM dsupers),
747 "")
748 #define FUNC_NAME s_scm_sys_inherit_magic_x
749 {
750 SCM ls = dsupers;
751 long flags = 0;
752 SCM_VALIDATE_INSTANCE (1, class);
753 while (!scm_is_null (ls))
754 {
755 SCM_ASSERT (scm_is_pair (ls)
756 && SCM_INSTANCEP (SCM_CAR (ls)),
757 dsupers,
758 SCM_ARG2,
759 FUNC_NAME);
760 flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
761 ls = SCM_CDR (ls);
762 }
763
764 SCM_SET_CLASS_FLAGS (class, flags &~SCM_CLASSF_PURE_GENERIC);
765
766 prep_hashsets (class);
767
768 return SCM_UNSPECIFIED;
769 }
770 #undef FUNC_NAME
771
772 static void
773 prep_hashsets (SCM class)
774 {
775 unsigned int i;
776
777 for (i = 0; i < 8; ++i)
778 SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
779 }
780
781 /******************************************************************************/
782
783 SCM
784 scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
785 {
786 SCM z, cpl, slots, nfields, g_n_s;
787
788 /* Allocate one instance */
789 z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
790
791 /* Initialize its slots */
792 SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
793 cpl = compute_cpl (z);
794 slots = build_slots_list (maplist (dslots), cpl);
795 nfields = scm_from_int (scm_ilength (slots));
796 g_n_s = compute_getters_n_setters (slots);
797
798 SCM_SET_SLOT (z, scm_vtable_index_name, name);
799 SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
800 SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
801 SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
802 SCM_SET_SLOT (z, scm_si_cpl, cpl);
803 SCM_SET_SLOT (z, scm_si_slots, slots);
804 SCM_SET_SLOT (z, scm_si_nfields, nfields);
805 SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
806 SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
807 SCM_SET_SLOT (z, scm_si_environment,
808 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
809
810 /* Add this class in the direct-subclasses slot of dsupers */
811 {
812 SCM tmp;
813 for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp))
814 SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
815 scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
816 scm_si_direct_subclasses)));
817 }
818
819 /* Support for the underlying structs: */
820 /* FIXME: set entity flag on z if class == entity_class ? */
821 SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
822 return z;
823 }
824
825 SCM
826 scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
827 {
828 SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
829 scm_sys_inherit_magic_x (z, dsupers);
830 scm_sys_prep_layout_x (z);
831 return z;
832 }
833
834 /******************************************************************************/
835
836 SCM_SYMBOL (sym_layout, "layout");
837 SCM_SYMBOL (sym_flags, "flags");
838 SCM_SYMBOL (sym_self, "%self");
839 SCM_SYMBOL (sym_instance_finalizer, "instance-finalizer");
840 SCM_SYMBOL (sym_reserved_0, "%reserved-0");
841 SCM_SYMBOL (sym_reserved_1, "%reserved-1");
842 SCM_SYMBOL (sym_print, "print");
843 SCM_SYMBOL (sym_procedure, "procedure");
844 SCM_SYMBOL (sym_setter, "setter");
845 SCM_SYMBOL (sym_redefined, "redefined");
846 SCM_SYMBOL (sym_h0, "h0");
847 SCM_SYMBOL (sym_h1, "h1");
848 SCM_SYMBOL (sym_h2, "h2");
849 SCM_SYMBOL (sym_h3, "h3");
850 SCM_SYMBOL (sym_h4, "h4");
851 SCM_SYMBOL (sym_h5, "h5");
852 SCM_SYMBOL (sym_h6, "h6");
853 SCM_SYMBOL (sym_h7, "h7");
854 SCM_SYMBOL (sym_name, "name");
855 SCM_SYMBOL (sym_direct_supers, "direct-supers");
856 SCM_SYMBOL (sym_direct_slots, "direct-slots");
857 SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
858 SCM_SYMBOL (sym_direct_methods, "direct-methods");
859 SCM_SYMBOL (sym_cpl, "cpl");
860 SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
861 SCM_SYMBOL (sym_slots, "slots");
862 SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
863 SCM_SYMBOL (sym_keyword_access, "keyword-access");
864 SCM_SYMBOL (sym_nfields, "nfields");
865 SCM_SYMBOL (sym_environment, "environment");
866
867
868 static SCM
869 build_class_class_slots ()
870 {
871 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
872 SCM_CLASS_CLASS_LAYOUT */
873 return scm_list_n (
874 scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
875 scm_list_3 (sym_flags, k_class, scm_class_hidden),
876 scm_list_3 (sym_self, k_class, scm_class_self),
877 scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden),
878 scm_list_1 (sym_print),
879 scm_list_3 (sym_name, k_class, scm_class_protected_hidden),
880 scm_list_3 (sym_reserved_0, k_class, scm_class_hidden),
881 scm_list_3 (sym_reserved_1, k_class, scm_class_hidden),
882 scm_list_1 (sym_redefined),
883 scm_list_3 (sym_h0, k_class, scm_class_int),
884 scm_list_3 (sym_h1, k_class, scm_class_int),
885 scm_list_3 (sym_h2, k_class, scm_class_int),
886 scm_list_3 (sym_h3, k_class, scm_class_int),
887 scm_list_3 (sym_h4, k_class, scm_class_int),
888 scm_list_3 (sym_h5, k_class, scm_class_int),
889 scm_list_3 (sym_h6, k_class, scm_class_int),
890 scm_list_3 (sym_h7, k_class, scm_class_int),
891 scm_list_1 (sym_direct_supers),
892 scm_list_1 (sym_direct_slots),
893 scm_list_1 (sym_direct_subclasses),
894 scm_list_1 (sym_direct_methods),
895 scm_list_1 (sym_cpl),
896 scm_list_1 (sym_default_slot_definition_class),
897 scm_list_1 (sym_slots),
898 scm_list_1 (sym_getters_n_setters),
899 scm_list_1 (sym_keyword_access),
900 scm_list_1 (sym_nfields),
901 scm_list_1 (sym_environment),
902 SCM_UNDEFINED);
903 }
904
905 static void
906 create_basic_classes (void)
907 {
908 /* SCM slots_of_class = build_class_class_slots (); */
909
910 /**** <class> ****/
911 SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
912 SCM name = scm_from_locale_symbol ("<class>");
913 scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
914 SCM_INUM0,
915 SCM_EOL));
916 SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
917 | SCM_CLASSF_METACLASS));
918
919 SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
920 SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
921 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
922 SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
923 SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
924 SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
925 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
926 SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
927 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
928 compute_getters_n_setters (slots_of_class)); */
929 SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
930 SCM_SET_SLOT (scm_class_class, scm_si_environment,
931 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
932
933 prep_hashsets (scm_class_class);
934
935 DEFVAR(name, scm_class_class);
936
937 /**** <scm_class_top> ****/
938 name = scm_from_locale_symbol ("<top>");
939 scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
940 name,
941 SCM_EOL,
942 SCM_EOL));
943
944 DEFVAR(name, scm_class_top);
945
946 /**** <scm_class_object> ****/
947 name = scm_from_locale_symbol ("<object>");
948 scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
949 name,
950 scm_list_1 (scm_class_top),
951 SCM_EOL));
952
953 DEFVAR (name, scm_class_object);
954
955 /* <top> <object> and <class> were partially initialized. Correct them here */
956 SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
957
958 SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object));
959 SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top));
960 }
961
962 /******************************************************************************/
963
964 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
965 (SCM obj),
966 "Return @code{#t} if @var{obj} is an instance.")
967 #define FUNC_NAME s_scm_instance_p
968 {
969 return scm_from_bool (SCM_INSTANCEP (obj));
970 }
971 #undef FUNC_NAME
972
973
974 /******************************************************************************
975 *
976 * Meta object accessors
977 *
978 ******************************************************************************/
979 SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
980 (SCM obj),
981 "Return the class name of @var{obj}.")
982 #define FUNC_NAME s_scm_class_name
983 {
984 SCM_VALIDATE_CLASS (1, obj);
985 return scm_slot_ref (obj, sym_name);
986 }
987 #undef FUNC_NAME
988
989 SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
990 (SCM obj),
991 "Return the direct superclasses of the class @var{obj}.")
992 #define FUNC_NAME s_scm_class_direct_supers
993 {
994 SCM_VALIDATE_CLASS (1, obj);
995 return scm_slot_ref (obj, sym_direct_supers);
996 }
997 #undef FUNC_NAME
998
999 SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
1000 (SCM obj),
1001 "Return the direct slots of the class @var{obj}.")
1002 #define FUNC_NAME s_scm_class_direct_slots
1003 {
1004 SCM_VALIDATE_CLASS (1, obj);
1005 return scm_slot_ref (obj, sym_direct_slots);
1006 }
1007 #undef FUNC_NAME
1008
1009 SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
1010 (SCM obj),
1011 "Return the direct subclasses of the class @var{obj}.")
1012 #define FUNC_NAME s_scm_class_direct_subclasses
1013 {
1014 SCM_VALIDATE_CLASS (1, obj);
1015 return scm_slot_ref(obj, sym_direct_subclasses);
1016 }
1017 #undef FUNC_NAME
1018
1019 SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
1020 (SCM obj),
1021 "Return the direct methods of the class @var{obj}")
1022 #define FUNC_NAME s_scm_class_direct_methods
1023 {
1024 SCM_VALIDATE_CLASS (1, obj);
1025 return scm_slot_ref (obj, sym_direct_methods);
1026 }
1027 #undef FUNC_NAME
1028
1029 SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
1030 (SCM obj),
1031 "Return the class precedence list of the class @var{obj}.")
1032 #define FUNC_NAME s_scm_class_precedence_list
1033 {
1034 SCM_VALIDATE_CLASS (1, obj);
1035 return scm_slot_ref (obj, sym_cpl);
1036 }
1037 #undef FUNC_NAME
1038
1039 SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
1040 (SCM obj),
1041 "Return the slot list of the class @var{obj}.")
1042 #define FUNC_NAME s_scm_class_slots
1043 {
1044 SCM_VALIDATE_CLASS (1, obj);
1045 return scm_slot_ref (obj, sym_slots);
1046 }
1047 #undef FUNC_NAME
1048
1049 SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
1050 (SCM obj),
1051 "Return the environment of the class @var{obj}.")
1052 #define FUNC_NAME s_scm_class_environment
1053 {
1054 SCM_VALIDATE_CLASS (1, obj);
1055 return scm_slot_ref(obj, sym_environment);
1056 }
1057 #undef FUNC_NAME
1058
1059
1060 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
1061 (SCM obj),
1062 "Return the name of the generic function @var{obj}.")
1063 #define FUNC_NAME s_scm_generic_function_name
1064 {
1065 SCM_VALIDATE_GENERIC (1, obj);
1066 return scm_procedure_property (obj, scm_sym_name);
1067 }
1068 #undef FUNC_NAME
1069
1070 SCM_SYMBOL (sym_methods, "methods");
1071 SCM_SYMBOL (sym_extended_by, "extended-by");
1072 SCM_SYMBOL (sym_extends, "extends");
1073
1074 static
1075 SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
1076 {
1077 SCM gfs = scm_slot_ref (gf, sym_extended_by);
1078 method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
1079 while (!scm_is_null (gfs))
1080 {
1081 method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
1082 gfs = SCM_CDR (gfs);
1083 }
1084 return method_lists;
1085 }
1086
1087 static
1088 SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
1089 {
1090 if (SCM_IS_A_P (gf, scm_class_extended_generic))
1091 {
1092 SCM gfs = scm_slot_ref (gf, sym_extends);
1093 while (!scm_is_null (gfs))
1094 {
1095 SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
1096 method_lists = fold_upward_gf_methods (scm_cons (methods,
1097 method_lists),
1098 SCM_CAR (gfs));
1099 gfs = SCM_CDR (gfs);
1100 }
1101 }
1102 return method_lists;
1103 }
1104
1105 SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
1106 (SCM obj),
1107 "Return the methods of the generic function @var{obj}.")
1108 #define FUNC_NAME s_scm_generic_function_methods
1109 {
1110 SCM methods;
1111 SCM_VALIDATE_GENERIC (1, obj);
1112 methods = fold_upward_gf_methods (SCM_EOL, obj);
1113 methods = fold_downward_gf_methods (methods, obj);
1114 return scm_append (methods);
1115 }
1116 #undef FUNC_NAME
1117
1118 SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
1119 (SCM obj),
1120 "Return the generic function for the method @var{obj}.")
1121 #define FUNC_NAME s_scm_method_generic_function
1122 {
1123 SCM_VALIDATE_METHOD (1, obj);
1124 return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
1125 }
1126 #undef FUNC_NAME
1127
1128 SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
1129 (SCM obj),
1130 "Return specializers of the method @var{obj}.")
1131 #define FUNC_NAME s_scm_method_specializers
1132 {
1133 SCM_VALIDATE_METHOD (1, obj);
1134 return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
1135 }
1136 #undef FUNC_NAME
1137
1138 SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
1139 (SCM obj),
1140 "Return the procedure of the method @var{obj}.")
1141 #define FUNC_NAME s_scm_method_procedure
1142 {
1143 SCM_VALIDATE_METHOD (1, obj);
1144 return scm_slot_ref (obj, sym_procedure);
1145 }
1146 #undef FUNC_NAME
1147
1148 SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
1149 (SCM obj),
1150 "Return the slot definition of the accessor @var{obj}.")
1151 #define FUNC_NAME s_scm_accessor_method_slot_definition
1152 {
1153 SCM_VALIDATE_ACCESSOR (1, obj);
1154 return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
1155 }
1156 #undef FUNC_NAME
1157
1158 /******************************************************************************
1159 *
1160 * S l o t a c c e s s
1161 *
1162 ******************************************************************************/
1163
1164 SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
1165 (),
1166 "Return the unbound value.")
1167 #define FUNC_NAME s_scm_make_unbound
1168 {
1169 return SCM_GOOPS_UNBOUND;
1170 }
1171 #undef FUNC_NAME
1172
1173 SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
1174 (SCM obj),
1175 "Return @code{#t} if @var{obj} is unbound.")
1176 #define FUNC_NAME s_scm_unbound_p
1177 {
1178 return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
1179 }
1180 #undef FUNC_NAME
1181
1182 SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
1183 (SCM value, SCM obj),
1184 "Return @var{value} if it is bound, and invoke the\n"
1185 "@var{slot-unbound} method of @var{obj} if it is not.")
1186 #define FUNC_NAME s_scm_assert_bound
1187 {
1188 if (SCM_GOOPS_UNBOUNDP (value))
1189 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
1190 return value;
1191 }
1192 #undef FUNC_NAME
1193
1194 SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
1195 (SCM obj, SCM index),
1196 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1197 "the value from @var{obj}.")
1198 #define FUNC_NAME s_scm_at_assert_bound_ref
1199 {
1200 SCM value = SCM_SLOT (obj, scm_to_int (index));
1201 if (SCM_GOOPS_UNBOUNDP (value))
1202 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
1203 return value;
1204 }
1205 #undef FUNC_NAME
1206
1207 SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
1208 (SCM obj, SCM index),
1209 "Return the slot value with index @var{index} from @var{obj}.")
1210 #define FUNC_NAME s_scm_sys_fast_slot_ref
1211 {
1212 unsigned long int i;
1213
1214 SCM_VALIDATE_INSTANCE (1, obj);
1215 i = scm_to_unsigned_integer (index, 0,
1216 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1217 scm_si_nfields))
1218 - 1);
1219 return SCM_SLOT (obj, i);
1220 }
1221 #undef FUNC_NAME
1222
1223 SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
1224 (SCM obj, SCM index, SCM value),
1225 "Set the slot with index @var{index} in @var{obj} to\n"
1226 "@var{value}.")
1227 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1228 {
1229 unsigned long int i;
1230
1231 SCM_VALIDATE_INSTANCE (1, obj);
1232 i = scm_to_unsigned_integer (index, 0,
1233 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1234 scm_si_nfields))
1235 - 1);
1236
1237 SCM_SET_SLOT (obj, i, value);
1238
1239 return SCM_UNSPECIFIED;
1240 }
1241 #undef FUNC_NAME
1242
1243
1244 \f
1245 /** Utilities **/
1246
1247 /* In the future, this function will return the effective slot
1248 * definition associated with SLOT_NAME. Now it just returns some of
1249 * the information which will be stored in the effective slot
1250 * definition.
1251 */
1252
1253 static SCM
1254 slot_definition_using_name (SCM class, SCM slot_name)
1255 {
1256 register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
1257 for (; !scm_is_null (slots); slots = SCM_CDR (slots))
1258 if (SCM_CAAR (slots) == slot_name)
1259 return SCM_CAR (slots);
1260 return SCM_BOOL_F;
1261 }
1262
1263 static SCM
1264 get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
1265 #define FUNC_NAME "%get-slot-value"
1266 {
1267 SCM access = SCM_CDDR (slotdef);
1268 /* Two cases here:
1269 * - access is an integer (the offset of this slot in the slots vector)
1270 * - otherwise (car access) is the getter function to apply
1271 *
1272 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1273 * we can just assume fixnums here.
1274 */
1275 if (SCM_I_INUMP (access))
1276 /* Don't poke at the slots directly, because scm_struct_ref handles the
1277 access bits for us. */
1278 return scm_struct_ref (obj, access);
1279 else
1280 {
1281 /* We must evaluate (apply (car access) (list obj))
1282 * where (car access) is known to be a closure of arity 1 */
1283 register SCM code, env;
1284
1285 code = SCM_CAR (access);
1286 if (!SCM_CLOSUREP (code))
1287 return scm_call_1 (code, obj);
1288 env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1289 scm_list_1 (obj),
1290 SCM_ENV (code));
1291 /* Evaluate the closure body */
1292 return scm_eval_body (SCM_CLOSURE_BODY (code), env);
1293 }
1294 }
1295 #undef FUNC_NAME
1296
1297 static SCM
1298 get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
1299 {
1300 SCM slotdef = slot_definition_using_name (class, slot_name);
1301 if (scm_is_true (slotdef))
1302 return get_slot_value (class, obj, slotdef);
1303 else
1304 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name);
1305 }
1306
1307 static SCM
1308 set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
1309 #define FUNC_NAME "%set-slot-value"
1310 {
1311 SCM access = SCM_CDDR (slotdef);
1312 /* Two cases here:
1313 * - access is an integer (the offset of this slot in the slots vector)
1314 * - otherwise (cadr access) is the setter function to apply
1315 *
1316 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1317 * we can just assume fixnums here.
1318 */
1319 if (SCM_I_INUMP (access))
1320 /* obey permissions bits via going through struct-set! */
1321 scm_struct_set_x (obj, access, value);
1322 else
1323 {
1324 /* We must evaluate (apply (cadr l) (list obj value))
1325 * where (cadr l) is known to be a closure of arity 2 */
1326 register SCM code, env;
1327
1328 code = SCM_CADR (access);
1329 if (!SCM_CLOSUREP (code))
1330 scm_call_2 (code, obj, value);
1331 else
1332 {
1333 env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1334 scm_list_2 (obj, value),
1335 SCM_ENV (code));
1336 /* Evaluate the closure body */
1337 scm_eval_body (SCM_CLOSURE_BODY (code), env);
1338 }
1339 }
1340 return SCM_UNSPECIFIED;
1341 }
1342 #undef FUNC_NAME
1343
1344 static SCM
1345 set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
1346 {
1347 SCM slotdef = slot_definition_using_name (class, slot_name);
1348 if (scm_is_true (slotdef))
1349 return set_slot_value (class, obj, slotdef, value);
1350 else
1351 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value);
1352 }
1353
1354 static SCM
1355 test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
1356 {
1357 register SCM l;
1358
1359 for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
1360 if (scm_is_eq (SCM_CAAR (l), slot_name))
1361 return SCM_BOOL_T;
1362
1363 return SCM_BOOL_F;
1364 }
1365
1366 /* ======================================== */
1367
1368 SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
1369 (SCM class, SCM obj, SCM slot_name),
1370 "")
1371 #define FUNC_NAME s_scm_slot_ref_using_class
1372 {
1373 SCM res;
1374
1375 SCM_VALIDATE_CLASS (1, class);
1376 SCM_VALIDATE_INSTANCE (2, obj);
1377 SCM_VALIDATE_SYMBOL (3, slot_name);
1378
1379 res = get_slot_value_using_name (class, obj, slot_name);
1380 if (SCM_GOOPS_UNBOUNDP (res))
1381 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
1382 return res;
1383 }
1384 #undef FUNC_NAME
1385
1386
1387 SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
1388 (SCM class, SCM obj, SCM slot_name, SCM value),
1389 "")
1390 #define FUNC_NAME s_scm_slot_set_using_class_x
1391 {
1392 SCM_VALIDATE_CLASS (1, class);
1393 SCM_VALIDATE_INSTANCE (2, obj);
1394 SCM_VALIDATE_SYMBOL (3, slot_name);
1395
1396 return set_slot_value_using_name (class, obj, slot_name, value);
1397 }
1398 #undef FUNC_NAME
1399
1400
1401 SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
1402 (SCM class, SCM obj, SCM slot_name),
1403 "")
1404 #define FUNC_NAME s_scm_slot_bound_using_class_p
1405 {
1406 SCM_VALIDATE_CLASS (1, class);
1407 SCM_VALIDATE_INSTANCE (2, obj);
1408 SCM_VALIDATE_SYMBOL (3, slot_name);
1409
1410 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name))
1411 ? SCM_BOOL_F
1412 : SCM_BOOL_T);
1413 }
1414 #undef FUNC_NAME
1415
1416 SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
1417 (SCM class, SCM obj, SCM slot_name),
1418 "")
1419 #define FUNC_NAME s_scm_slot_exists_using_class_p
1420 {
1421 SCM_VALIDATE_CLASS (1, class);
1422 SCM_VALIDATE_INSTANCE (2, obj);
1423 SCM_VALIDATE_SYMBOL (3, slot_name);
1424 return test_slot_existence (class, obj, slot_name);
1425 }
1426 #undef FUNC_NAME
1427
1428
1429 /* ======================================== */
1430
1431 SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
1432 (SCM obj, SCM slot_name),
1433 "Return the value from @var{obj}'s slot with the name\n"
1434 "@var{slot_name}.")
1435 #define FUNC_NAME s_scm_slot_ref
1436 {
1437 SCM res, class;
1438
1439 SCM_VALIDATE_INSTANCE (1, obj);
1440 TEST_CHANGE_CLASS (obj, class);
1441
1442 res = get_slot_value_using_name (class, obj, slot_name);
1443 if (SCM_GOOPS_UNBOUNDP (res))
1444 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
1445 return res;
1446 }
1447 #undef FUNC_NAME
1448
1449 SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
1450 (SCM obj, SCM slot_name, SCM value),
1451 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1452 #define FUNC_NAME s_scm_slot_set_x
1453 {
1454 SCM class;
1455
1456 SCM_VALIDATE_INSTANCE (1, obj);
1457 TEST_CHANGE_CLASS(obj, class);
1458
1459 return set_slot_value_using_name (class, obj, slot_name, value);
1460 }
1461 #undef FUNC_NAME
1462
1463 const char *scm_s_slot_set_x = s_scm_slot_set_x;
1464
1465 SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
1466 (SCM obj, SCM slot_name),
1467 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1468 "is bound.")
1469 #define FUNC_NAME s_scm_slot_bound_p
1470 {
1471 SCM class;
1472
1473 SCM_VALIDATE_INSTANCE (1, obj);
1474 TEST_CHANGE_CLASS(obj, class);
1475
1476 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1477 obj,
1478 slot_name))
1479 ? SCM_BOOL_F
1480 : SCM_BOOL_T);
1481 }
1482 #undef FUNC_NAME
1483
1484 SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
1485 (SCM obj, SCM slot_name),
1486 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1487 #define FUNC_NAME s_scm_slot_exists_p
1488 {
1489 SCM class;
1490
1491 SCM_VALIDATE_INSTANCE (1, obj);
1492 SCM_VALIDATE_SYMBOL (2, slot_name);
1493 TEST_CHANGE_CLASS (obj, class);
1494
1495 return test_slot_existence (class, obj, slot_name);
1496 }
1497 #undef FUNC_NAME
1498
1499
1500 /******************************************************************************
1501 *
1502 * %allocate-instance (the low level instance allocation primitive)
1503 *
1504 ******************************************************************************/
1505
1506 static void clear_method_cache (SCM);
1507
1508 static void
1509 goops_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
1510 {
1511 SCM obj = PTR2SCM (ptr);
1512 scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
1513
1514 if (finalize)
1515 finalize (obj);
1516 }
1517 SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
1518 (SCM class, SCM initargs),
1519 "Create a new instance of class @var{class} and initialize it\n"
1520 "from the arguments @var{initargs}.")
1521 #define FUNC_NAME s_scm_sys_allocate_instance
1522 {
1523 SCM obj;
1524 long n;
1525 long i;
1526 SCM layout;
1527
1528 SCM_VALIDATE_CLASS (1, class);
1529
1530 /* FIXME: duplicates some of scm_make_struct. */
1531
1532 n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
1533 obj = scm_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
1534
1535 layout = SCM_VTABLE_LAYOUT (class);
1536
1537 /* Set all SCM-holding slots to unbound */
1538 for (i = 0; i < n; i++)
1539 { scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
1540 if (c == 'p')
1541 SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
1542 else if (c == 's')
1543 SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
1544 else
1545 SCM_STRUCT_DATA (obj)[i] = 0;
1546 }
1547
1548 if (SCM_VTABLE_INSTANCE_FINALIZER (class))
1549 {
1550 /* Register a finalizer for the newly created instance. */
1551 GC_finalization_proc prev_finalizer;
1552 GC_PTR prev_finalizer_data;
1553 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj),
1554 goops_finalizer_trampoline,
1555 NULL,
1556 &prev_finalizer,
1557 &prev_finalizer_data);
1558 }
1559
1560 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
1561 clear_method_cache (obj);
1562
1563 /* Class objects */
1564 /* if ((SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1565 && (SCM_SUBCLASSP (class, scm_class_entity_class)))
1566 SCM_SET_CLASS_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE); */
1567
1568 return obj;
1569 }
1570 #undef FUNC_NAME
1571
1572 SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
1573 (SCM obj, SCM setter),
1574 "")
1575 #define FUNC_NAME s_scm_sys_set_object_setter_x
1576 {
1577 SCM_ASSERT (SCM_STRUCTP (obj)
1578 && (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC),
1579 obj,
1580 SCM_ARG1,
1581 FUNC_NAME);
1582 SCM_SET_GENERIC_SETTER (obj, setter);
1583 return SCM_UNSPECIFIED;
1584 }
1585 #undef FUNC_NAME
1586
1587 /******************************************************************************
1588 *
1589 * %modify-instance (used by change-class to modify in place)
1590 *
1591 ******************************************************************************/
1592
1593 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
1594 (SCM old, SCM new),
1595 "")
1596 #define FUNC_NAME s_scm_sys_modify_instance
1597 {
1598 SCM_VALIDATE_INSTANCE (1, old);
1599 SCM_VALIDATE_INSTANCE (2, new);
1600
1601 /* Exchange the data contained in old and new. We exchange rather than
1602 * scratch the old value with new to be correct with GC.
1603 * See "Class redefinition protocol above".
1604 */
1605 SCM_CRITICAL_SECTION_START;
1606 {
1607 scm_t_bits word0, word1;
1608 word0 = SCM_CELL_WORD_0 (old);
1609 word1 = SCM_CELL_WORD_1 (old);
1610 SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
1611 SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
1612 SCM_SET_CELL_WORD_0 (new, word0);
1613 SCM_SET_CELL_WORD_1 (new, word1);
1614 }
1615 SCM_CRITICAL_SECTION_END;
1616 return SCM_UNSPECIFIED;
1617 }
1618 #undef FUNC_NAME
1619
1620 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
1621 (SCM old, SCM new),
1622 "")
1623 #define FUNC_NAME s_scm_sys_modify_class
1624 {
1625 SCM_VALIDATE_CLASS (1, old);
1626 SCM_VALIDATE_CLASS (2, new);
1627
1628 SCM_CRITICAL_SECTION_START;
1629 {
1630 scm_t_bits word0, word1;
1631 word0 = SCM_CELL_WORD_0 (old);
1632 word1 = SCM_CELL_WORD_1 (old);
1633 SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
1634 SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
1635 SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
1636 SCM_SET_CELL_WORD_0 (new, word0);
1637 SCM_SET_CELL_WORD_1 (new, word1);
1638 SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
1639 }
1640 SCM_CRITICAL_SECTION_END;
1641 return SCM_UNSPECIFIED;
1642 }
1643 #undef FUNC_NAME
1644
1645 SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
1646 (SCM class),
1647 "")
1648 #define FUNC_NAME s_scm_sys_invalidate_class
1649 {
1650 SCM_VALIDATE_CLASS (1, class);
1651 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
1652 return SCM_UNSPECIFIED;
1653 }
1654 #undef FUNC_NAME
1655
1656 /* When instances change class, they finally get a new body, but
1657 * before that, they go through purgatory in hell. Odd as it may
1658 * seem, this data structure saves us from eternal suffering in
1659 * infinite recursions.
1660 */
1661
1662 static scm_t_bits **hell;
1663 static long n_hell = 1; /* one place for the evil one himself */
1664 static long hell_size = 4;
1665 static SCM hell_mutex;
1666
1667 static long
1668 burnin (SCM o)
1669 {
1670 long i;
1671 for (i = 1; i < n_hell; ++i)
1672 if (SCM_STRUCT_DATA (o) == hell[i])
1673 return i;
1674 return 0;
1675 }
1676
1677 static void
1678 go_to_hell (void *o)
1679 {
1680 SCM obj = SCM_PACK ((scm_t_bits) o);
1681 scm_lock_mutex (hell_mutex);
1682 if (n_hell >= hell_size)
1683 {
1684 hell_size *= 2;
1685 hell = scm_realloc (hell, hell_size * sizeof(*hell));
1686 }
1687 hell[n_hell++] = SCM_STRUCT_DATA (obj);
1688 scm_unlock_mutex (hell_mutex);
1689 }
1690
1691 static void
1692 go_to_heaven (void *o)
1693 {
1694 scm_lock_mutex (hell_mutex);
1695 hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
1696 scm_unlock_mutex (hell_mutex);
1697 }
1698
1699
1700 SCM_SYMBOL (scm_sym_change_class, "change-class");
1701
1702 static SCM
1703 purgatory (void *args)
1704 {
1705 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class),
1706 SCM_PACK ((scm_t_bits) args));
1707 }
1708
1709 /* This function calls the generic function change-class for all
1710 * instances which aren't currently undergoing class change.
1711 */
1712
1713 void
1714 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
1715 {
1716 if (!burnin (obj))
1717 scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
1718 (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
1719 (void *) SCM_UNPACK (obj));
1720 }
1721
1722 /******************************************************************************
1723 *
1724 * GGGG FFFFF
1725 * G F
1726 * G GG FFF
1727 * G G F
1728 * GGG E N E R I C F U N C T I O N S
1729 *
1730 * This implementation provides
1731 * - generic functions (with class specializers)
1732 * - multi-methods
1733 * - next-method
1734 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1735 *
1736 ******************************************************************************/
1737
1738 SCM_KEYWORD (k_name, "name");
1739
1740 SCM_SYMBOL (sym_no_method, "no-method");
1741
1742 static SCM list_of_no_method;
1743
1744 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
1745
1746
1747 /* The cache argument for scm_mcache_lookup_cmethod has one of two possible
1748 * formats:
1749 *
1750 * Format #1:
1751 * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
1752 * #((TYPE1 ... . CMETHOD) ...)
1753 * GF)
1754 *
1755 * Format #2:
1756 * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
1757 * #((TYPE1 ... CMETHOD) ...)
1758 * GF)
1759 *
1760 * ARGS is either a list of expressions, in which case they
1761 * are interpreted as the arguments of an application, or
1762 * a non-pair, which is interpreted as a single expression
1763 * yielding all arguments.
1764 *
1765 * SCM_IM_DISPATCH expressions in generic functions always
1766 * have ARGS = the symbol `args' or the iloc #@0-0.
1767 *
1768 * We should probably not complicate this mechanism by
1769 * introducing "optimizations" for getters and setters or
1770 * primitive methods. Getters and setter will normally be
1771 * compiled into @slot-[ref|set!] or a procedure call.
1772 * They rely on the dispatch performed before executing
1773 * the code which contains them.
1774 *
1775 * We might want to use a more efficient representation of
1776 * this form in the future, perhaps after we have introduced
1777 * low-level support for syntax-case macros.
1778 */
1779
1780 SCM
1781 scm_mcache_lookup_cmethod (SCM cache, SCM args)
1782 {
1783 unsigned long i, mask, n, end;
1784 SCM ls, methods, z = SCM_CDDR (cache);
1785 n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
1786 methods = SCM_CADR (z);
1787
1788 if (scm_is_simple_vector (methods))
1789 {
1790 /* cache format #1: prepare for linear search */
1791 mask = -1;
1792 i = 0;
1793 end = SCM_SIMPLE_VECTOR_LENGTH (methods);
1794 }
1795 else
1796 {
1797 /* cache format #2: compute a hash value */
1798 unsigned long hashset = scm_to_ulong (methods);
1799 long j = n;
1800 z = SCM_CDDR (z);
1801 mask = scm_to_ulong (SCM_CAR (z));
1802 methods = SCM_CADR (z);
1803 i = 0;
1804 ls = args;
1805 if (!scm_is_null (ls))
1806 do
1807 {
1808 i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
1809 [scm_si_hashsets + hashset];
1810 ls = SCM_CDR (ls);
1811 }
1812 while (j-- && !scm_is_null (ls));
1813 i &= mask;
1814 end = i;
1815 }
1816
1817 /* Search for match */
1818 do
1819 {
1820 long j = n;
1821 z = SCM_SIMPLE_VECTOR_REF (methods, i);
1822 ls = args; /* list of arguments */
1823 /* More arguments than specifiers => z = CMETHOD, not a pair.
1824 * Fewer arguments than specifiers => CAR != CLASS or `no-method'. */
1825 if (!scm_is_null (ls) && scm_is_pair (z))
1826 do
1827 {
1828 if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
1829 goto next_method;
1830 ls = SCM_CDR (ls);
1831 z = SCM_CDR (z);
1832 }
1833 while (j-- && !scm_is_null (ls) && scm_is_pair (z));
1834 if (!scm_is_pair (z))
1835 return z;
1836 next_method:
1837 i = (i + 1) & mask;
1838 } while (i != end);
1839 return SCM_BOOL_F;
1840 }
1841
1842 SCM
1843 scm_mcache_compute_cmethod (SCM cache, SCM args)
1844 {
1845 SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
1846 if (scm_is_false (cmethod))
1847 /* No match - memoize */
1848 return scm_memoize_method (cache, args);
1849 return cmethod;
1850 }
1851
1852 SCM
1853 scm_apply_generic (SCM gf, SCM args)
1854 {
1855 SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf), args);
1856 if (SCM_PROGRAM_P (cmethod))
1857 return scm_vm_apply (scm_the_vm (), cmethod, args);
1858 else if (scm_is_pair (cmethod))
1859 return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
1860 SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
1861 args,
1862 SCM_CMETHOD_ENV (cmethod)));
1863 else
1864 return scm_apply (cmethod, args, SCM_EOL);
1865 }
1866
1867 SCM
1868 scm_call_generic_0 (SCM gf)
1869 {
1870 return scm_apply_generic (gf, SCM_EOL);
1871 }
1872
1873 SCM
1874 scm_call_generic_1 (SCM gf, SCM a1)
1875 {
1876 return scm_apply_generic (gf, scm_list_1 (a1));
1877 }
1878
1879 SCM
1880 scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
1881 {
1882 return scm_apply_generic (gf, scm_list_2 (a1, a2));
1883 }
1884
1885 SCM
1886 scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
1887 {
1888 return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
1889 }
1890
1891 SCM
1892 scm_make_method_cache (SCM gf)
1893 {
1894 return scm_list_5 (SCM_IM_DISPATCH,
1895 scm_sym_args,
1896 scm_from_int (1),
1897 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
1898 list_of_no_method),
1899 gf);
1900 }
1901
1902 static void
1903 clear_method_cache (SCM gf)
1904 {
1905 SCM cache = scm_make_method_cache (gf);
1906 SCM_SET_GENERIC_METHOD_CACHE (gf, cache);
1907 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf, SCM_BOOL_F);
1908 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf);
1909 }
1910
1911 SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
1912 (SCM gf),
1913 "")
1914 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1915 {
1916 SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
1917 clear_method_cache (gf);
1918 /* The sign of n-specialized is a flag indicating rest args. */
1919 SCM_SET_MCACHE_N_SPECIALIZED (SCM_GENERIC_METHOD_CACHE (gf),
1920 SCM_SLOT (gf, scm_si_n_specialized));
1921 return SCM_UNSPECIFIED;
1922 }
1923 #undef FUNC_NAME
1924
1925 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
1926 (SCM proc),
1927 "")
1928 #define FUNC_NAME s_scm_generic_capability_p
1929 {
1930 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
1931 proc, SCM_ARG1, FUNC_NAME);
1932 return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
1933 ? SCM_BOOL_T
1934 : SCM_BOOL_F);
1935 }
1936 #undef FUNC_NAME
1937
1938 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
1939 (SCM subrs),
1940 "")
1941 #define FUNC_NAME s_scm_enable_primitive_generic_x
1942 {
1943 SCM_VALIDATE_REST_ARGUMENT (subrs);
1944 while (!scm_is_null (subrs))
1945 {
1946 SCM subr = SCM_CAR (subrs);
1947 SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
1948 subr, SCM_ARGn, FUNC_NAME);
1949 *SCM_SUBR_GENERIC (subr)
1950 = scm_make (scm_list_3 (scm_class_generic,
1951 k_name,
1952 SCM_SUBR_NAME (subr)));
1953 subrs = SCM_CDR (subrs);
1954 }
1955 return SCM_UNSPECIFIED;
1956 }
1957 #undef FUNC_NAME
1958
1959 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
1960 (SCM subr),
1961 "")
1962 #define FUNC_NAME s_scm_primitive_generic_generic
1963 {
1964 if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
1965 {
1966 if (!*SCM_SUBR_GENERIC (subr))
1967 scm_enable_primitive_generic_x (scm_list_1 (subr));
1968 return *SCM_SUBR_GENERIC (subr);
1969 }
1970 SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
1971 }
1972 #undef FUNC_NAME
1973
1974 typedef struct t_extension {
1975 struct t_extension *next;
1976 SCM extended;
1977 SCM extension;
1978 } t_extension;
1979
1980
1981 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1982 objects. */
1983 static const char extension_gc_hint[] = "GOOPS extension";
1984
1985 static t_extension *extensions = 0;
1986
1987 SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
1988
1989 void
1990 scm_c_extend_primitive_generic (SCM extended, SCM extension)
1991 {
1992 if (goops_loaded_p)
1993 {
1994 SCM gf, gext;
1995 if (!*SCM_SUBR_GENERIC (extended))
1996 scm_enable_primitive_generic_x (scm_list_1 (extended));
1997 gf = *SCM_SUBR_GENERIC (extended);
1998 gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
1999 gf,
2000 SCM_SUBR_NAME (extension));
2001 SCM_SET_SUBR_GENERIC (extension, gext);
2002 }
2003 else
2004 {
2005 t_extension *e = scm_gc_malloc (sizeof (t_extension),
2006 extension_gc_hint);
2007 t_extension **loc = &extensions;
2008 /* Make sure that extensions are placed before their own
2009 * extensions in the extensions list. O(N^2) algorithm, but
2010 * extensions of primitive generics are rare.
2011 */
2012 while (*loc && extension != (*loc)->extended)
2013 loc = &(*loc)->next;
2014 e->next = *loc;
2015 e->extended = extended;
2016 e->extension = extension;
2017 *loc = e;
2018 }
2019 }
2020
2021 static void
2022 setup_extended_primitive_generics ()
2023 {
2024 while (extensions)
2025 {
2026 t_extension *e = extensions;
2027 scm_c_extend_primitive_generic (e->extended, e->extension);
2028 extensions = e->next;
2029 }
2030 }
2031
2032 /******************************************************************************
2033 *
2034 * Protocol for calling a generic fumction
2035 * This protocol is roughly equivalent to (parameter are a little bit different
2036 * for efficiency reasons):
2037 *
2038 * + apply-generic (gf args)
2039 * + compute-applicable-methods (gf args ...)
2040 * + sort-applicable-methods (methods args)
2041 * + apply-methods (gf methods args)
2042 *
2043 * apply-methods calls make-next-method to build the "continuation" of a a
2044 * method. Applying a next-method will call apply-next-method which in
2045 * turn will call apply again to call effectively the following method.
2046 *
2047 ******************************************************************************/
2048
2049 static int
2050 applicablep (SCM actual, SCM formal)
2051 {
2052 /* We already know that the cpl is well formed. */
2053 return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
2054 }
2055
2056 static int
2057 more_specificp (SCM m1, SCM m2, SCM const *targs)
2058 {
2059 register SCM s1, s2;
2060 register long i;
2061 /*
2062 * Note:
2063 * m1 and m2 can have != length (i.e. one can be one element longer than the
2064 * other when we have a dotted parameter list). For instance, with the call
2065 * (M 1)
2066 * with
2067 * (define-method M (a . l) ....)
2068 * (define-method M (a) ....)
2069 *
2070 * we consider that the second method is more specific.
2071 *
2072 * BTW, targs is an array of types. We don't need it's size since
2073 * we already know that m1 and m2 are applicable (no risk to go past
2074 * the end of this array).
2075 *
2076 */
2077 for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
2078 if (scm_is_null(s1)) return 1;
2079 if (scm_is_null(s2)) return 0;
2080 if (SCM_CAR(s1) != SCM_CAR(s2)) {
2081 register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
2082
2083 for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
2084 if (cs1 == SCM_CAR(l))
2085 return 1;
2086 if (cs2 == SCM_CAR(l))
2087 return 0;
2088 }
2089 return 0;/* should not occur! */
2090 }
2091 }
2092 return 0; /* should not occur! */
2093 }
2094
2095 #define BUFFSIZE 32 /* big enough for most uses */
2096
2097 static SCM
2098 scm_i_vector2list (SCM l, long len)
2099 {
2100 long j;
2101 SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
2102
2103 for (j = 0; j < len; j++, l = SCM_CDR (l)) {
2104 SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
2105 }
2106 return z;
2107 }
2108
2109 static SCM
2110 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
2111 {
2112 long i, j, incr;
2113 SCM *v, vector = SCM_EOL;
2114 SCM buffer[BUFFSIZE];
2115 SCM save = method_list;
2116 scm_t_array_handle handle;
2117
2118 /* For reasonably sized method_lists we can try to avoid all the
2119 * consing and reorder the list in place...
2120 * This idea is due to David McClain <Dave_McClain@msn.com>
2121 */
2122 if (size <= BUFFSIZE)
2123 {
2124 for (i = 0; i < size; i++)
2125 {
2126 buffer[i] = SCM_CAR (method_list);
2127 method_list = SCM_CDR (method_list);
2128 }
2129 v = buffer;
2130 }
2131 else
2132 {
2133 /* Too many elements in method_list to keep everything locally */
2134 vector = scm_i_vector2list (save, size);
2135 v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
2136 }
2137
2138 /* Use a simple shell sort since it is generally faster than qsort on
2139 * small vectors (which is probably mostly the case when we have to
2140 * sort a list of applicable methods).
2141 */
2142 for (incr = size / 2; incr; incr /= 2)
2143 {
2144 for (i = incr; i < size; i++)
2145 {
2146 for (j = i - incr; j >= 0; j -= incr)
2147 {
2148 if (more_specificp (v[j], v[j+incr], targs))
2149 break;
2150 else
2151 {
2152 SCM tmp = v[j + incr];
2153 v[j + incr] = v[j];
2154 v[j] = tmp;
2155 }
2156 }
2157 }
2158 }
2159
2160 if (size <= BUFFSIZE)
2161 {
2162 /* We did it in locally, so restore the original list (reordered) in-place */
2163 for (i = 0, method_list = save; i < size; i++, v++)
2164 {
2165 SCM_SETCAR (method_list, *v);
2166 method_list = SCM_CDR (method_list);
2167 }
2168 return save;
2169 }
2170
2171 /* If we are here, that's that we did it the hard way... */
2172 scm_array_handle_release (&handle);
2173 return scm_vector_to_list (vector);
2174 }
2175
2176 SCM
2177 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
2178 {
2179 register long i;
2180 long count = 0;
2181 SCM l, fl, applicable = SCM_EOL;
2182 SCM save = args;
2183 SCM buffer[BUFFSIZE];
2184 SCM const *types;
2185 SCM *p;
2186 SCM tmp = SCM_EOL;
2187 scm_t_array_handle handle;
2188
2189 /* Build the list of arguments types */
2190 if (len >= BUFFSIZE)
2191 {
2192 tmp = scm_c_make_vector (len, SCM_UNDEFINED);
2193 types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
2194
2195 /*
2196 note that we don't have to work to reset the generation
2197 count. TMP is a new vector anyway, and it is found
2198 conservatively.
2199 */
2200 }
2201 else
2202 types = p = buffer;
2203
2204 for ( ; !scm_is_null (args); args = SCM_CDR (args))
2205 *p++ = scm_class_of (SCM_CAR (args));
2206
2207 /* Build a list of all applicable methods */
2208 for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
2209 {
2210 fl = SPEC_OF (SCM_CAR (l));
2211 /* Only accept accessors which match exactly in first arg. */
2212 if (SCM_ACCESSORP (SCM_CAR (l))
2213 && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
2214 continue;
2215 for (i = 0; ; i++, fl = SCM_CDR (fl))
2216 {
2217 if (SCM_INSTANCEP (fl)
2218 /* We have a dotted argument list */
2219 || (i >= len && scm_is_null (fl)))
2220 { /* both list exhausted */
2221 applicable = scm_cons (SCM_CAR (l), applicable);
2222 count += 1;
2223 break;
2224 }
2225 if (i >= len
2226 || scm_is_null (fl)
2227 || !applicablep (types[i], SCM_CAR (fl)))
2228 break;
2229 }
2230 }
2231
2232 if (len >= BUFFSIZE)
2233 scm_array_handle_release (&handle);
2234
2235 if (count == 0)
2236 {
2237 if (find_method_p)
2238 return SCM_BOOL_F;
2239 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save);
2240 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2241 return SCM_BOOL_F;
2242 }
2243
2244 return (count == 1
2245 ? applicable
2246 : sort_applicable_methods (applicable, count, types));
2247 }
2248
2249 #if 0
2250 SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
2251 #endif
2252
2253 static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
2254
2255 SCM
2256 scm_sys_compute_applicable_methods (SCM gf, SCM args)
2257 #define FUNC_NAME s_sys_compute_applicable_methods
2258 {
2259 long n;
2260 SCM_VALIDATE_GENERIC (1, gf);
2261 n = scm_ilength (args);
2262 SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
2263 return scm_compute_applicable_methods (gf, args, n, 1);
2264 }
2265 #undef FUNC_NAME
2266
2267 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
2268 SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
2269
2270 static void
2271 lock_cache_mutex (void *m)
2272 {
2273 SCM mutex = SCM_PACK ((scm_t_bits) m);
2274 scm_lock_mutex (mutex);
2275 }
2276
2277 static void
2278 unlock_cache_mutex (void *m)
2279 {
2280 SCM mutex = SCM_PACK ((scm_t_bits) m);
2281 scm_unlock_mutex (mutex);
2282 }
2283
2284 static SCM
2285 call_memoize_method (void *a)
2286 {
2287 SCM args = SCM_PACK ((scm_t_bits) a);
2288 SCM gf = SCM_CAR (args);
2289 SCM x = SCM_CADR (args);
2290 /* First check if another thread has inserted a method between
2291 * the cache miss and locking the mutex.
2292 */
2293 SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
2294 if (scm_is_true (cmethod))
2295 return cmethod;
2296
2297 if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
2298 var_memoize_method_x =
2299 scm_permanent_object
2300 (scm_module_variable (scm_module_goops, sym_memoize_method_x));
2301
2302 return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x);
2303 }
2304
2305 SCM
2306 scm_memoize_method (SCM x, SCM args)
2307 {
2308 SCM gf = SCM_CAR (scm_last_pair (x));
2309 return scm_internal_dynamic_wind (
2310 lock_cache_mutex,
2311 call_memoize_method,
2312 unlock_cache_mutex,
2313 (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
2314 (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
2315 }
2316
2317 /******************************************************************************
2318 *
2319 * A simple make (which will be redefined later in Scheme)
2320 * This version handles only creation of gf, methods and classes (no instances)
2321 *
2322 * Since this code will disappear when Goops will be fully booted,
2323 * no precaution is taken to be efficient.
2324 *
2325 ******************************************************************************/
2326
2327 SCM_KEYWORD (k_setter, "setter");
2328 SCM_KEYWORD (k_specializers, "specializers");
2329 SCM_KEYWORD (k_procedure, "procedure");
2330 SCM_KEYWORD (k_formals, "formals");
2331 SCM_KEYWORD (k_body, "body");
2332 SCM_KEYWORD (k_make_procedure, "make-procedure");
2333 SCM_KEYWORD (k_dsupers, "dsupers");
2334 SCM_KEYWORD (k_slots, "slots");
2335 SCM_KEYWORD (k_gf, "generic-function");
2336
2337 SCM_DEFINE (scm_make, "make", 0, 0, 1,
2338 (SCM args),
2339 "Make a new object. @var{args} must contain the class and\n"
2340 "all necessary initialization information.")
2341 #define FUNC_NAME s_scm_make
2342 {
2343 SCM class, z;
2344 long len = scm_ilength (args);
2345
2346 if (len <= 0 || (len & 1) == 0)
2347 SCM_WRONG_NUM_ARGS ();
2348
2349 class = SCM_CAR(args);
2350 args = SCM_CDR(args);
2351
2352 if (class == scm_class_generic || class == scm_class_accessor)
2353 {
2354 z = scm_make_struct (class, SCM_INUM0,
2355 scm_list_4 (SCM_EOL,
2356 SCM_INUM0,
2357 scm_make_mutex (),
2358 SCM_EOL));
2359 scm_set_procedure_property_x (z, scm_sym_name,
2360 scm_get_keyword (k_name,
2361 args,
2362 SCM_BOOL_F));
2363 clear_method_cache (z);
2364 if (class == scm_class_accessor)
2365 {
2366 SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
2367 if (scm_is_true (setter))
2368 scm_sys_set_object_setter_x (z, setter);
2369 }
2370 }
2371 else
2372 {
2373 z = scm_sys_allocate_instance (class, args);
2374
2375 if (class == scm_class_method
2376 || class == scm_class_simple_method
2377 || class == scm_class_accessor_method)
2378 {
2379 SCM_SET_SLOT (z, scm_si_generic_function,
2380 scm_i_get_keyword (k_gf,
2381 args,
2382 len - 1,
2383 SCM_BOOL_F,
2384 FUNC_NAME));
2385 SCM_SET_SLOT (z, scm_si_specializers,
2386 scm_i_get_keyword (k_specializers,
2387 args,
2388 len - 1,
2389 SCM_EOL,
2390 FUNC_NAME));
2391 SCM_SET_SLOT (z, scm_si_procedure,
2392 scm_i_get_keyword (k_procedure,
2393 args,
2394 len - 1,
2395 SCM_BOOL_F,
2396 FUNC_NAME));
2397 SCM_SET_SLOT (z, scm_si_formals,
2398 scm_i_get_keyword (k_formals,
2399 args,
2400 len - 1,
2401 SCM_EOL,
2402 FUNC_NAME));
2403 SCM_SET_SLOT (z, scm_si_body,
2404 scm_i_get_keyword (k_body,
2405 args,
2406 len - 1,
2407 SCM_EOL,
2408 FUNC_NAME));
2409 SCM_SET_SLOT (z, scm_si_make_procedure,
2410 scm_i_get_keyword (k_make_procedure,
2411 args,
2412 len - 1,
2413 SCM_BOOL_F,
2414 FUNC_NAME));
2415 }
2416 else
2417 {
2418 /* In all the others case, make a new class .... No instance here */
2419 SCM_SET_SLOT (z, scm_vtable_index_name,
2420 scm_i_get_keyword (k_name,
2421 args,
2422 len - 1,
2423 scm_from_locale_symbol ("???"),
2424 FUNC_NAME));
2425 SCM_SET_SLOT (z, scm_si_direct_supers,
2426 scm_i_get_keyword (k_dsupers,
2427 args,
2428 len - 1,
2429 SCM_EOL,
2430 FUNC_NAME));
2431 SCM_SET_SLOT (z, scm_si_direct_slots,
2432 scm_i_get_keyword (k_slots,
2433 args,
2434 len - 1,
2435 SCM_EOL,
2436 FUNC_NAME));
2437 }
2438 }
2439 return z;
2440 }
2441 #undef FUNC_NAME
2442
2443 SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
2444 (SCM l),
2445 "")
2446 #define FUNC_NAME s_scm_find_method
2447 {
2448 SCM gf;
2449 long len = scm_ilength (l);
2450
2451 if (len == 0)
2452 SCM_WRONG_NUM_ARGS ();
2453
2454 gf = SCM_CAR(l); l = SCM_CDR(l);
2455 SCM_VALIDATE_GENERIC (1, gf);
2456 if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
2457 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
2458
2459 return scm_compute_applicable_methods (gf, l, len - 1, 1);
2460 }
2461 #undef FUNC_NAME
2462
2463 SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
2464 (SCM m1, SCM m2, SCM targs),
2465 "Return true if method @var{m1} is more specific than @var{m2} "
2466 "given the argument types (classes) listed in @var{targs}.")
2467 #define FUNC_NAME s_scm_sys_method_more_specific_p
2468 {
2469 SCM l, v, result;
2470 SCM *v_elts;
2471 long i, len, m1_specs, m2_specs;
2472 scm_t_array_handle handle;
2473
2474 SCM_VALIDATE_METHOD (1, m1);
2475 SCM_VALIDATE_METHOD (2, m2);
2476
2477 len = scm_ilength (targs);
2478 m1_specs = scm_ilength (SPEC_OF (m1));
2479 m2_specs = scm_ilength (SPEC_OF (m2));
2480 SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
2481 targs, SCM_ARG3, FUNC_NAME);
2482
2483 /* Verify that all the arguments of TARGS are classes and place them
2484 in a vector. */
2485
2486 v = scm_c_make_vector (len, SCM_EOL);
2487 v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
2488
2489 for (i = 0, l = targs;
2490 i < len && scm_is_pair (l);
2491 i++, l = SCM_CDR (l))
2492 {
2493 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
2494 v_elts[i] = SCM_CAR (l);
2495 }
2496 result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
2497
2498 scm_array_handle_release (&handle);
2499
2500 return result;
2501 }
2502 #undef FUNC_NAME
2503
2504
2505
2506 /******************************************************************************
2507 *
2508 * Initializations
2509 *
2510 ******************************************************************************/
2511
2512 static void
2513 fix_cpl (SCM c, SCM before, SCM after)
2514 {
2515 SCM cpl = SCM_SLOT (c, scm_si_cpl);
2516 SCM ls = scm_c_memq (after, cpl);
2517 SCM tail = scm_delq1_x (before, SCM_CDR (ls));
2518 if (scm_is_false (ls))
2519 /* if this condition occurs, fix_cpl should not be applied this way */
2520 abort ();
2521 SCM_SETCAR (ls, before);
2522 SCM_SETCDR (ls, scm_cons (after, tail));
2523 {
2524 SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
2525 SCM slots = build_slots_list (maplist (dslots), cpl);
2526 SCM g_n_s = compute_getters_n_setters (slots);
2527 SCM_SET_SLOT (c, scm_si_slots, slots);
2528 SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
2529 }
2530 }
2531
2532
2533 static void
2534 make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
2535 {
2536 SCM tmp = scm_from_locale_symbol (name);
2537
2538 *var = scm_permanent_object (scm_basic_make_class (meta,
2539 tmp,
2540 scm_is_pair (super)
2541 ? super
2542 : scm_list_1 (super),
2543 slots));
2544 DEFVAR(tmp, *var);
2545 }
2546
2547
2548 SCM_KEYWORD (k_slot_definition, "slot-definition");
2549
2550 static void
2551 create_standard_classes (void)
2552 {
2553 SCM slots;
2554 SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
2555 scm_from_locale_symbol ("specializers"),
2556 sym_procedure,
2557 scm_from_locale_symbol ("formals"),
2558 scm_from_locale_symbol ("body"),
2559 scm_from_locale_symbol ("make-procedure"),
2560 SCM_UNDEFINED);
2561 SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2562 k_init_keyword,
2563 k_slot_definition));
2564 SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2565 SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2566 SCM_EOL,
2567 mutex_slot),
2568 SCM_EOL);
2569 SCM gf_slots = scm_list_n (scm_from_locale_symbol ("methods"),
2570 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2571 k_init_value,
2572 SCM_INUM0),
2573 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2574 k_init_thunk,
2575 mutex_closure),
2576 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2577 k_init_value,
2578 SCM_EOL),
2579 scm_from_locale_symbol ("%cache"),
2580 scm_from_locale_symbol ("dispatch-procedure"),
2581 scm_from_locale_symbol ("effective-methods"),
2582 SCM_UNDEFINED);
2583 SCM setter_slots = scm_list_1 (sym_setter);
2584 SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2585 k_init_value,
2586 SCM_EOL));
2587 /* Foreign class slot classes */
2588 make_stdcls (&scm_class_foreign_slot, "<foreign-slot>",
2589 scm_class_class, scm_class_top, SCM_EOL);
2590 make_stdcls (&scm_class_protected, "<protected-slot>",
2591 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2592 make_stdcls (&scm_class_hidden, "<hidden-slot>",
2593 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2594 make_stdcls (&scm_class_opaque, "<opaque-slot>",
2595 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2596 make_stdcls (&scm_class_read_only, "<read-only-slot>",
2597 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2598 make_stdcls (&scm_class_self, "<self-slot>",
2599 scm_class_class, scm_class_read_only, SCM_EOL);
2600 make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
2601 scm_class_class,
2602 scm_list_2 (scm_class_protected, scm_class_opaque),
2603 SCM_EOL);
2604 make_stdcls (&scm_class_protected_hidden, "<protected-hidden-slot>",
2605 scm_class_class,
2606 scm_list_2 (scm_class_protected, scm_class_hidden),
2607 SCM_EOL);
2608 make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
2609 scm_class_class,
2610 scm_list_2 (scm_class_protected, scm_class_read_only),
2611 SCM_EOL);
2612 make_stdcls (&scm_class_scm, "<scm-slot>",
2613 scm_class_class, scm_class_protected, SCM_EOL);
2614 make_stdcls (&scm_class_int, "<int-slot>",
2615 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2616 make_stdcls (&scm_class_float, "<float-slot>",
2617 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2618 make_stdcls (&scm_class_double, "<double-slot>",
2619 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2620
2621 /* Continue initialization of class <class> */
2622
2623 slots = build_class_class_slots ();
2624 SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
2625 SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
2626 SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
2627 compute_getters_n_setters (slots));
2628
2629 make_stdcls (&scm_class_foreign_class, "<foreign-class>",
2630 scm_class_class, scm_class_class,
2631 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2632 k_class,
2633 scm_class_opaque),
2634 scm_list_3 (scm_from_locale_symbol ("destructor"),
2635 k_class,
2636 scm_class_opaque)));
2637 make_stdcls (&scm_class_foreign_object, "<foreign-object>",
2638 scm_class_foreign_class, scm_class_object, SCM_EOL);
2639 SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
2640
2641 /* scm_class_generic functions classes */
2642 make_stdcls (&scm_class_procedure_class, "<procedure-class>",
2643 scm_class_class, scm_class_class, SCM_EOL);
2644 make_stdcls (&scm_class_entity_class, "<entity-class>",
2645 scm_class_class, scm_class_procedure_class, SCM_EOL);
2646 make_stdcls (&scm_class_method, "<method>",
2647 scm_class_class, scm_class_object, method_slots);
2648 make_stdcls (&scm_class_simple_method, "<simple-method>",
2649 scm_class_class, scm_class_method, SCM_EOL);
2650 SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
2651 make_stdcls (&scm_class_accessor_method, "<accessor-method>",
2652 scm_class_class, scm_class_simple_method, amethod_slots);
2653 SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
2654 make_stdcls (&scm_class_applicable, "<applicable>",
2655 scm_class_class, scm_class_top, SCM_EOL);
2656 make_stdcls (&scm_class_entity, "<entity>",
2657 scm_class_entity_class,
2658 scm_list_2 (scm_class_object, scm_class_applicable),
2659 SCM_EOL);
2660 make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
2661 scm_class_entity_class, scm_class_entity, SCM_EOL);
2662 make_stdcls (&scm_class_generic, "<generic>",
2663 scm_class_entity_class, scm_class_entity, gf_slots);
2664 SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
2665 make_stdcls (&scm_class_extended_generic, "<extended-generic>",
2666 scm_class_entity_class, scm_class_generic, egf_slots);
2667 SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
2668 make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
2669 scm_class_entity_class,
2670 scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
2671 setter_slots);
2672 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
2673 make_stdcls (&scm_class_accessor, "<accessor>",
2674 scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
2675 SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
2676 make_stdcls (&scm_class_extended_generic_with_setter,
2677 "<extended-generic-with-setter>",
2678 scm_class_entity_class,
2679 scm_list_2 (scm_class_generic_with_setter,
2680 scm_class_extended_generic),
2681 SCM_EOL);
2682 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
2683 SCM_CLASSF_PURE_GENERIC);
2684 make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
2685 scm_class_entity_class,
2686 scm_list_2 (scm_class_accessor,
2687 scm_class_extended_generic_with_setter),
2688 SCM_EOL);
2689 fix_cpl (scm_class_extended_accessor,
2690 scm_class_extended_generic, scm_class_generic);
2691 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
2692
2693 /* Primitive types classes */
2694 make_stdcls (&scm_class_boolean, "<boolean>",
2695 scm_class_class, scm_class_top, SCM_EOL);
2696 make_stdcls (&scm_class_char, "<char>",
2697 scm_class_class, scm_class_top, SCM_EOL);
2698 make_stdcls (&scm_class_list, "<list>",
2699 scm_class_class, scm_class_top, SCM_EOL);
2700 make_stdcls (&scm_class_pair, "<pair>",
2701 scm_class_class, scm_class_list, SCM_EOL);
2702 make_stdcls (&scm_class_null, "<null>",
2703 scm_class_class, scm_class_list, SCM_EOL);
2704 make_stdcls (&scm_class_string, "<string>",
2705 scm_class_class, scm_class_top, SCM_EOL);
2706 make_stdcls (&scm_class_symbol, "<symbol>",
2707 scm_class_class, scm_class_top, SCM_EOL);
2708 make_stdcls (&scm_class_vector, "<vector>",
2709 scm_class_class, scm_class_top, SCM_EOL);
2710 make_stdcls (&scm_class_number, "<number>",
2711 scm_class_class, scm_class_top, SCM_EOL);
2712 make_stdcls (&scm_class_complex, "<complex>",
2713 scm_class_class, scm_class_number, SCM_EOL);
2714 make_stdcls (&scm_class_real, "<real>",
2715 scm_class_class, scm_class_complex, SCM_EOL);
2716 make_stdcls (&scm_class_integer, "<integer>",
2717 scm_class_class, scm_class_real, SCM_EOL);
2718 make_stdcls (&scm_class_fraction, "<fraction>",
2719 scm_class_class, scm_class_real, SCM_EOL);
2720 make_stdcls (&scm_class_keyword, "<keyword>",
2721 scm_class_class, scm_class_top, SCM_EOL);
2722 make_stdcls (&scm_class_unknown, "<unknown>",
2723 scm_class_class, scm_class_top, SCM_EOL);
2724 make_stdcls (&scm_class_procedure, "<procedure>",
2725 scm_class_procedure_class, scm_class_applicable, SCM_EOL);
2726 make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
2727 scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2728 make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
2729 scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2730 make_stdcls (&scm_class_port, "<port>",
2731 scm_class_class, scm_class_top, SCM_EOL);
2732 make_stdcls (&scm_class_input_port, "<input-port>",
2733 scm_class_class, scm_class_port, SCM_EOL);
2734 make_stdcls (&scm_class_output_port, "<output-port>",
2735 scm_class_class, scm_class_port, SCM_EOL);
2736 make_stdcls (&scm_class_input_output_port, "<input-output-port>",
2737 scm_class_class,
2738 scm_list_2 (scm_class_input_port, scm_class_output_port),
2739 SCM_EOL);
2740 }
2741
2742 /**********************************************************************
2743 *
2744 * Smob classes
2745 *
2746 **********************************************************************/
2747
2748 static SCM
2749 make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
2750 {
2751 SCM class, name;
2752 if (type_name)
2753 {
2754 char buffer[100];
2755 sprintf (buffer, template, type_name);
2756 name = scm_from_locale_symbol (buffer);
2757 }
2758 else
2759 name = SCM_GOOPS_UNBOUND;
2760
2761 class = scm_permanent_object (scm_basic_make_class (applicablep
2762 ? scm_class_procedure_class
2763 : scm_class_class,
2764 name,
2765 supers,
2766 SCM_EOL));
2767
2768 /* Only define name if doesn't already exist. */
2769 if (!SCM_GOOPS_UNBOUNDP (name)
2770 && scm_is_false (scm_module_variable (scm_module_goops, name)))
2771 DEFVAR (name, class);
2772 return class;
2773 }
2774
2775 static SCM
2776 make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
2777 {
2778 SCM class, name;
2779 if (type_name_sym != SCM_BOOL_F)
2780 {
2781 name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2782 scm_symbol_to_string (type_name_sym),
2783 scm_from_locale_string (">")));
2784 name = scm_string_to_symbol (name);
2785 }
2786 else
2787 name = SCM_GOOPS_UNBOUND;
2788
2789 class = scm_permanent_object (scm_basic_make_class (applicablep
2790 ? scm_class_procedure_class
2791 : scm_class_class,
2792 name,
2793 supers,
2794 SCM_EOL));
2795
2796 /* Only define name if doesn't already exist. */
2797 if (!SCM_GOOPS_UNBOUNDP (name)
2798 && scm_is_false (scm_module_variable (scm_module_goops, name)))
2799 DEFVAR (name, class);
2800 return class;
2801 }
2802
2803 SCM
2804 scm_make_extended_class (char const *type_name, int applicablep)
2805 {
2806 return make_class_from_template ("<%s>",
2807 type_name,
2808 scm_list_1 (applicablep
2809 ? scm_class_applicable
2810 : scm_class_top),
2811 applicablep);
2812 }
2813
2814 static SCM
2815 scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep)
2816 {
2817 return make_class_from_symbol (type_name_sym,
2818 scm_list_1 (applicablep
2819 ? scm_class_applicable
2820 : scm_class_top),
2821 applicablep);
2822 }
2823
2824 void
2825 scm_i_inherit_applicable (SCM c)
2826 {
2827 if (!SCM_SUBCLASSP (c, scm_class_applicable))
2828 {
2829 SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
2830 SCM cpl = SCM_SLOT (c, scm_si_cpl);
2831 /* patch scm_class_applicable into direct-supers */
2832 SCM top = scm_c_memq (scm_class_top, dsupers);
2833 if (scm_is_false (top))
2834 dsupers = scm_append (scm_list_2 (dsupers,
2835 scm_list_1 (scm_class_applicable)));
2836 else
2837 {
2838 SCM_SETCAR (top, scm_class_applicable);
2839 SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2840 }
2841 SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
2842 /* patch scm_class_applicable into cpl */
2843 top = scm_c_memq (scm_class_top, cpl);
2844 if (scm_is_false (top))
2845 abort ();
2846 else
2847 {
2848 SCM_SETCAR (top, scm_class_applicable);
2849 SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2850 }
2851 /* add class to direct-subclasses of scm_class_applicable */
2852 SCM_SET_SLOT (scm_class_applicable,
2853 scm_si_direct_subclasses,
2854 scm_cons (c, SCM_SLOT (scm_class_applicable,
2855 scm_si_direct_subclasses)));
2856 }
2857 }
2858
2859 static void
2860 create_smob_classes (void)
2861 {
2862 long i;
2863
2864 for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
2865 scm_smob_class[i] = 0;
2866
2867 scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
2868
2869 for (i = 0; i < scm_numsmob; ++i)
2870 if (!scm_smob_class[i])
2871 scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
2872 scm_smobs[i].apply != 0);
2873 }
2874
2875 void
2876 scm_make_port_classes (long ptobnum, char *type_name)
2877 {
2878 SCM c, class = make_class_from_template ("<%s-port>",
2879 type_name,
2880 scm_list_1 (scm_class_port),
2881 0);
2882 scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
2883 = make_class_from_template ("<%s-input-port>",
2884 type_name,
2885 scm_list_2 (class, scm_class_input_port),
2886 0);
2887 scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
2888 = make_class_from_template ("<%s-output-port>",
2889 type_name,
2890 scm_list_2 (class, scm_class_output_port),
2891 0);
2892 scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
2893 = c
2894 = make_class_from_template ("<%s-input-output-port>",
2895 type_name,
2896 scm_list_2 (class, scm_class_input_output_port),
2897 0);
2898 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2899 SCM_SET_SLOT (c, scm_si_cpl,
2900 scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
2901 }
2902
2903 static void
2904 create_port_classes (void)
2905 {
2906 long i;
2907
2908 for (i = 0; i < scm_numptob; ++i)
2909 scm_make_port_classes (i, SCM_PTOBNAME (i));
2910 }
2911
2912 static SCM
2913 make_struct_class (void *closure SCM_UNUSED,
2914 SCM vtable, SCM data, SCM prev SCM_UNUSED)
2915 {
2916 SCM sym = SCM_STRUCT_TABLE_NAME (data);
2917 if (scm_is_true (sym))
2918 {
2919 int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
2920
2921 SCM_SET_STRUCT_TABLE_CLASS (data,
2922 scm_make_extended_class_from_symbol (sym, applicablep));
2923 }
2924
2925 scm_remember_upto_here_2 (data, vtable);
2926 return SCM_UNSPECIFIED;
2927 }
2928
2929 static void
2930 create_struct_classes (void)
2931 {
2932 scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
2933 }
2934
2935 /**********************************************************************
2936 *
2937 * C interface
2938 *
2939 **********************************************************************/
2940
2941 void
2942 scm_load_goops ()
2943 {
2944 if (!goops_loaded_p)
2945 scm_c_resolve_module ("oop goops");
2946 }
2947
2948
2949 SCM_SYMBOL (sym_o, "o");
2950 SCM_SYMBOL (sym_x, "x");
2951
2952 SCM_KEYWORD (k_accessor, "accessor");
2953 SCM_KEYWORD (k_getter, "getter");
2954
2955 SCM
2956 scm_ensure_accessor (SCM name)
2957 {
2958 SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
2959 if (!SCM_IS_A_P (gf, scm_class_accessor))
2960 {
2961 gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
2962 gf = scm_make (scm_list_5 (scm_class_accessor,
2963 k_name, name, k_setter, gf));
2964 }
2965 return gf;
2966 }
2967
2968 SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
2969
2970 void
2971 scm_add_method (SCM gf, SCM m)
2972 {
2973 scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
2974 }
2975
2976 #ifdef GUILE_DEBUG
2977 /*
2978 * Debugging utilities
2979 */
2980
2981 SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
2982 (SCM obj),
2983 "Return @code{#t} if @var{obj} is a pure generic.")
2984 #define FUNC_NAME s_scm_pure_generic_p
2985 {
2986 return scm_from_bool (SCM_PUREGENERICP (obj));
2987 }
2988 #undef FUNC_NAME
2989
2990 #endif /* GUILE_DEBUG */
2991
2992 /*
2993 * Initialization
2994 */
2995
2996 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
2997 (),
2998 "Announce that GOOPS is loaded and perform initialization\n"
2999 "on the C level which depends on the loaded GOOPS modules.")
3000 #define FUNC_NAME s_scm_sys_goops_loaded
3001 {
3002 goops_loaded_p = 1;
3003 var_compute_applicable_methods =
3004 scm_permanent_object
3005 (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
3006 var_slot_unbound =
3007 scm_permanent_object
3008 (scm_module_variable (scm_module_goops, sym_slot_unbound));
3009 var_slot_missing =
3010 scm_permanent_object
3011 (scm_module_variable (scm_module_goops, sym_slot_missing));
3012 var_compute_cpl =
3013 scm_permanent_object
3014 (scm_module_variable (scm_module_goops, sym_compute_cpl));
3015 var_no_applicable_method =
3016 scm_permanent_object
3017 (scm_module_variable (scm_module_goops, sym_no_applicable_method));
3018 var_change_class =
3019 scm_permanent_object
3020 (scm_module_variable (scm_module_goops, sym_change_class));
3021 setup_extended_primitive_generics ();
3022 return SCM_UNSPECIFIED;
3023 }
3024 #undef FUNC_NAME
3025
3026 SCM scm_module_goops;
3027
3028 SCM
3029 scm_init_goops_builtins (void)
3030 {
3031 scm_module_goops = scm_current_module ();
3032
3033 /* Not really necessary right now, but who knows...
3034 */
3035 scm_permanent_object (scm_module_goops);
3036
3037 goops_rstate = scm_c_make_rstate ("GOOPS", 5);
3038
3039 #include "libguile/goops.x"
3040
3041 list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
3042
3043 hell = scm_calloc (hell_size * sizeof (*hell));
3044 hell_mutex = scm_permanent_object (scm_make_mutex ());
3045
3046 create_basic_classes ();
3047 create_standard_classes ();
3048 create_smob_classes ();
3049 create_struct_classes ();
3050 create_port_classes ();
3051
3052 {
3053 SCM name = scm_from_locale_symbol ("no-applicable-method");
3054 scm_no_applicable_method
3055 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
3056 k_name,
3057 name)));
3058 DEFVAR (name, scm_no_applicable_method);
3059 }
3060
3061 return SCM_UNSPECIFIED;
3062 }
3063
3064 void
3065 scm_init_goops ()
3066 {
3067 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3068 scm_init_goops_builtins);
3069 }
3070
3071 /*
3072 Local Variables:
3073 c-file-style: "gnu"
3074 End:
3075 */