HCoop / bpt / guile.git / blob
? search:


1ea7a94f4b50bc133d3ccc3198d1ce3ada3c23b3
[bpt/guile.git] / libguile / goops.c
1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
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 "libguile/_scm.h"
33 #include "libguile/async.h"
34 #include "libguile/chars.h"
35 #include "libguile/dynwind.h"
36 #include "libguile/eval.h"
37 #include "libguile/gsubr.h"
38 #include "libguile/hashtab.h"
39 #include "libguile/keywords.h"
40 #include "libguile/macros.h"
41 #include "libguile/modules.h"
42 #include "libguile/ports.h"
43 #include "libguile/procprop.h"
44 #include "libguile/programs.h"
45 #include "libguile/smob.h"
46 #include "libguile/strings.h"
47 #include "libguile/strports.h"
48 #include "libguile/vectors.h"
49
50 #include "libguile/validate.h"
51 #include "libguile/goops.h"
52
53 /* Port classes */
54 #define SCM_IN_PCLASS_INDEX 0
55 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
56 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
57
58 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
59 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
60
61 /* Objects have identity, so references to classes and instances are by
62 value, not by reference. Redefinition of a class or modification of
63 an instance causes in-place update; you can think of GOOPS as
64 building in its own indirection, and for that reason referring to
65 GOOPS values by variable reference is unnecessary.
66
67 References to ordinary procedures is by reference (by variable),
68 though, as in the rest of Guile. */
69
70 static int goops_loaded_p = 0;
71
72 static SCM var_make_standard_class = SCM_BOOL_F;
73 static SCM var_change_class = SCM_BOOL_F;
74 static SCM var_make = SCM_BOOL_F;
75 static SCM var_class_name = SCM_BOOL_F;
76 static SCM var_class_direct_supers = SCM_BOOL_F;
77 static SCM var_class_direct_slots = SCM_BOOL_F;
78 static SCM var_class_direct_subclasses = SCM_BOOL_F;
79 static SCM var_class_direct_methods = SCM_BOOL_F;
80 static SCM var_class_precedence_list = SCM_BOOL_F;
81 static SCM var_class_slots = SCM_BOOL_F;
82
83 static SCM var_generic_function_methods = SCM_BOOL_F;
84 static SCM var_method_generic_function = SCM_BOOL_F;
85 static SCM var_method_specializers = SCM_BOOL_F;
86 static SCM var_method_procedure = SCM_BOOL_F;
87
88 static SCM var_slot_ref_using_class = SCM_BOOL_F;
89 static SCM var_slot_set_using_class_x = SCM_BOOL_F;
90 static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
91 static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
92
93 static SCM var_slot_ref = SCM_BOOL_F;
94 static SCM var_slot_set_x = SCM_BOOL_F;
95 static SCM var_slot_bound_p = SCM_BOOL_F;
96 static SCM var_slot_exists_p = SCM_BOOL_F;
97
98 /* These variables are filled in by the object system when loaded. */
99 static SCM class_boolean, class_char, class_pair;
100 static SCM class_procedure, class_string, class_symbol;
101 static SCM class_primitive_generic;
102 static SCM class_vector, class_null;
103 static SCM class_integer, class_real, class_complex, class_fraction;
104 static SCM class_unknown;
105 static SCM class_top, class_object, class_class;
106 static SCM class_applicable;
107 static SCM class_applicable_struct, class_applicable_struct_with_setter;
108 static SCM class_generic, class_generic_with_setter;
109 static SCM class_accessor;
110 static SCM class_extended_generic, class_extended_generic_with_setter;
111 static SCM class_extended_accessor;
112 static SCM class_method;
113 static SCM class_accessor_method;
114 static SCM class_procedure_class;
115 static SCM class_applicable_struct_class;
116 static SCM class_applicable_struct_with_setter_class;
117 static SCM class_number, class_list;
118 static SCM class_keyword;
119 static SCM class_port, class_input_output_port;
120 static SCM class_input_port, class_output_port;
121 static SCM class_foreign_slot;
122 static SCM class_self, class_protected;
123 static SCM class_hidden, class_opaque, class_read_only;
124 static SCM class_protected_hidden, class_protected_opaque, class_protected_read_only;
125 static SCM class_scm;
126 static SCM class_int, class_float, class_double;
127
128 static SCM class_foreign;
129 static SCM class_hashtable;
130 static SCM class_fluid;
131 static SCM class_dynamic_state;
132 static SCM class_frame;
133 static SCM class_vm_cont;
134 static SCM class_bytevector;
135 static SCM class_uvec;
136 static SCM class_array;
137 static SCM class_bitvector;
138
139 static SCM vtable_class_map = SCM_BOOL_F;
140
141 /* Port classes. Allocate 3 times the maximum number of port types so that
142 input ports, output ports, and in/out ports can be stored at different
143 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
144 SCM scm_i_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
145
146 /* SMOB classes. */
147 SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
148
149 static SCM scm_make_unbound (void);
150 static SCM scm_unbound_p (SCM obj);
151 static SCM scm_class_p (SCM obj);
152 static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable,
153 SCM setter);
154 static SCM scm_sys_make_root_class (SCM name, SCM dslots,
155 SCM getters_n_setters);
156 static SCM scm_sys_init_layout_x (SCM class, SCM layout);
157 static SCM scm_sys_goops_early_init (void);
158 static SCM scm_sys_goops_loaded (void);
159
160
161 /* This function is used for efficient type dispatch. */
162 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
163 (SCM x),
164 "Return the class of @var{x}.")
165 #define FUNC_NAME s_scm_class_of
166 {
167 switch (SCM_ITAG3 (x))
168 {
169 case scm_tc3_int_1:
170 case scm_tc3_int_2:
171 return class_integer;
172
173 case scm_tc3_imm24:
174 if (SCM_CHARP (x))
175 return class_char;
176 else if (scm_is_bool (x))
177 return class_boolean;
178 else if (scm_is_null (x))
179 return class_null;
180 else
181 return class_unknown;
182
183 case scm_tc3_cons:
184 switch (SCM_TYP7 (x))
185 {
186 case scm_tcs_cons_nimcar:
187 return class_pair;
188 case scm_tc7_symbol:
189 return class_symbol;
190 case scm_tc7_vector:
191 case scm_tc7_wvect:
192 return class_vector;
193 case scm_tc7_pointer:
194 return class_foreign;
195 case scm_tc7_hashtable:
196 return class_hashtable;
197 case scm_tc7_fluid:
198 return class_fluid;
199 case scm_tc7_dynamic_state:
200 return class_dynamic_state;
201 case scm_tc7_frame:
202 return class_frame;
203 case scm_tc7_keyword:
204 return class_keyword;
205 case scm_tc7_vm_cont:
206 return class_vm_cont;
207 case scm_tc7_bytevector:
208 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
209 return class_bytevector;
210 else
211 return class_uvec;
212 case scm_tc7_array:
213 return class_array;
214 case scm_tc7_bitvector:
215 return class_bitvector;
216 case scm_tc7_string:
217 return class_string;
218 case scm_tc7_number:
219 switch SCM_TYP16 (x) {
220 case scm_tc16_big:
221 return class_integer;
222 case scm_tc16_real:
223 return class_real;
224 case scm_tc16_complex:
225 return class_complex;
226 case scm_tc16_fraction:
227 return class_fraction;
228 }
229 case scm_tc7_program:
230 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
231 && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
232 return class_primitive_generic;
233 else
234 return class_procedure;
235
236 case scm_tc7_smob:
237 {
238 scm_t_bits type = SCM_TYP16 (x);
239 if (type != scm_tc16_port_with_ps)
240 return scm_i_smob_class[SCM_TC2SMOBNUM (type)];
241 x = SCM_PORT_WITH_PS_PORT (x);
242 /* fall through to ports */
243 }
244 case scm_tc7_port:
245 return scm_i_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
246 ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
247 ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
248 : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
249 : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
250 case scm_tcs_struct:
251 if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
252 return SCM_CLASS_OF (x);
253 else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
254 {
255 /* Goops object */
256 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
257 scm_change_object_class (x,
258 SCM_CLASS_OF (x), /* old */
259 SCM_OBJ_CLASS_REDEF (x)); /* new */
260 return SCM_CLASS_OF (x);
261 }
262 else
263 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
264 default:
265 if (scm_is_pair (x))
266 return class_pair;
267 else
268 return class_unknown;
269 }
270
271 case scm_tc3_struct:
272 case scm_tc3_tc7_1:
273 case scm_tc3_tc7_2:
274 /* case scm_tc3_unused: */
275 /* Never reached */
276 break;
277 }
278 return class_unknown;
279 }
280 #undef FUNC_NAME
281
282 SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
283 (SCM class, SCM layout),
284 "")
285 #define FUNC_NAME s_scm_sys_init_layout_x
286 {
287 SCM_VALIDATE_INSTANCE (1, class);
288 SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME);
289 SCM_VALIDATE_STRING (2, layout);
290
291 SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout));
292 return SCM_UNSPECIFIED;
293 }
294 #undef FUNC_NAME
295
296 SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
297 (SCM class, SCM dsupers),
298 "")
299 #define FUNC_NAME s_scm_sys_inherit_magic_x
300 {
301 SCM_VALIDATE_INSTANCE (1, class);
302 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
303 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
304
305 return SCM_UNSPECIFIED;
306 }
307 #undef FUNC_NAME
308
309 /******************************************************************************/
310
311 SCM
312 scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
313 {
314 return scm_call_4 (scm_variable_ref (var_make_standard_class),
315 meta, name, dsupers, dslots);
316 }
317
318 /******************************************************************************/
319
320 SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0,
321 (SCM name, SCM dslots, SCM getters_n_setters),
322 "")
323 #define FUNC_NAME s_scm_sys_make_root_class
324 {
325 SCM cs, z;
326
327 cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
328 z = scm_i_make_vtable_vtable (cs);
329 SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID
330 | SCM_CLASSF_METACLASS));
331
332 SCM_SET_SLOT (z, scm_vtable_index_name, name);
333 SCM_SET_SLOT (z, scm_si_direct_supers, SCM_EOL); /* will be changed */
334 SCM_SET_SLOT (z, scm_si_direct_slots, dslots); /* will be changed */
335 SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
336 SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
337 SCM_SET_SLOT (z, scm_si_cpl, SCM_EOL); /* will be changed */
338 SCM_SET_SLOT (z, scm_si_slots, dslots); /* will be changed */
339 SCM_SET_SLOT (z, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
340 SCM_SET_SLOT (z, scm_si_getters_n_setters, getters_n_setters); /* will be changed */
341 SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
342
343 return z;
344 }
345 #undef FUNC_NAME
346
347 /******************************************************************************/
348
349 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
350 (SCM obj),
351 "Return @code{#t} if @var{obj} is an instance.")
352 #define FUNC_NAME s_scm_instance_p
353 {
354 return scm_from_bool (SCM_INSTANCEP (obj));
355 }
356 #undef FUNC_NAME
357
358 SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
359 (SCM obj),
360 "Return @code{#t} if @var{obj} is a class.")
361 #define FUNC_NAME s_scm_class_p
362 {
363 return scm_from_bool (SCM_CLASSP (obj));
364 }
365 #undef FUNC_NAME
366
367 int
368 scm_is_generic (SCM x)
369 {
370 return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic);
371 }
372
373 int
374 scm_is_method (SCM x)
375 {
376 return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method);
377 }
378
379 /******************************************************************************
380 *
381 * Meta object accessors
382 *
383 ******************************************************************************/
384
385 SCM
386 scm_class_name (SCM obj)
387 {
388 return scm_call_1 (scm_variable_ref (var_class_name), obj);
389 }
390
391 SCM
392 scm_class_direct_supers (SCM obj)
393 {
394 return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
395 }
396
397 SCM
398 scm_class_direct_slots (SCM obj)
399 {
400 return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
401 }
402
403 SCM
404 scm_class_direct_subclasses (SCM obj)
405 {
406 return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
407 }
408
409 SCM
410 scm_class_direct_methods (SCM obj)
411 {
412 return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
413 }
414
415 SCM
416 scm_class_precedence_list (SCM obj)
417 {
418 return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
419 }
420
421 SCM
422 scm_class_slots (SCM obj)
423 {
424 return scm_call_1 (scm_variable_ref (var_class_slots), obj);
425 }
426
427 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
428 (SCM obj),
429 "Return the name of the generic function @var{obj}.")
430 #define FUNC_NAME s_scm_generic_function_name
431 {
432 SCM_VALIDATE_GENERIC (1, obj);
433 return scm_procedure_property (obj, scm_sym_name);
434 }
435 #undef FUNC_NAME
436
437 SCM
438 scm_generic_function_methods (SCM obj)
439 {
440 return scm_call_1 (scm_variable_ref (var_generic_function_methods), obj);
441 }
442
443 SCM
444 scm_method_generic_function (SCM obj)
445 {
446 return scm_call_1 (scm_variable_ref (var_method_generic_function), obj);
447 }
448
449 SCM
450 scm_method_specializers (SCM obj)
451 {
452 return scm_call_1 (scm_variable_ref (var_method_specializers), obj);
453 }
454
455 SCM
456 scm_method_procedure (SCM obj)
457 {
458 return scm_call_1 (scm_variable_ref (var_method_procedure), obj);
459 }
460
461 /******************************************************************************
462 *
463 * S l o t a c c e s s
464 *
465 ******************************************************************************/
466
467 SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
468 (),
469 "Return the unbound value.")
470 #define FUNC_NAME s_scm_make_unbound
471 {
472 return SCM_GOOPS_UNBOUND;
473 }
474 #undef FUNC_NAME
475
476 SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
477 (SCM obj),
478 "Return @code{#t} if @var{obj} is unbound.")
479 #define FUNC_NAME s_scm_unbound_p
480 {
481 return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
482 }
483 #undef FUNC_NAME
484
485
486 \f
487
488 SCM
489 scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
490 {
491 return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
492 class, obj, slot_name);
493 }
494
495 SCM
496 scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
497 {
498 return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
499 class, obj, slot_name, value);
500 }
501
502 SCM
503 scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
504 {
505 return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
506 class, obj, slot_name);
507 }
508
509 SCM
510 scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
511 {
512 return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
513 class, obj, slot_name);
514 }
515
516 SCM
517 scm_slot_ref (SCM obj, SCM slot_name)
518 {
519 return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
520 }
521
522 SCM
523 scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
524 {
525 return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
526 }
527
528 SCM
529 scm_slot_bound_p (SCM obj, SCM slot_name)
530 {
531 return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
532 }
533
534 SCM
535 scm_slot_exists_p (SCM obj, SCM slot_name)
536 {
537 return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
538 }
539
540
541 /******************************************************************************
542 *
543 * %allocate-instance (the low level instance allocation primitive)
544 *
545 ******************************************************************************/
546
547 SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
548 (SCM class, SCM initargs),
549 "Create a new instance of class @var{class} and initialize it\n"
550 "from the arguments @var{initargs}.")
551 #define FUNC_NAME s_scm_sys_allocate_instance
552 {
553 SCM obj;
554 scm_t_signed_bits n, i;
555 SCM layout;
556
557 SCM_VALIDATE_CLASS (1, class);
558
559 /* FIXME: duplicates some of scm_make_struct. */
560
561 n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
562 obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
563
564 layout = SCM_VTABLE_LAYOUT (class);
565
566 /* Set all SCM-holding slots to unbound */
567 for (i = 0; i < n; i++)
568 {
569 scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
570 if (c == 'p')
571 SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
572 else if (c == 's')
573 SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
574 else
575 SCM_STRUCT_DATA (obj)[i] = 0;
576 }
577
578 return obj;
579 }
580 #undef FUNC_NAME
581
582 /******************************************************************************
583 *
584 * %modify-instance (used by change-class to modify in place)
585 *
586 ******************************************************************************/
587
588 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
589 (SCM old, SCM new),
590 "")
591 #define FUNC_NAME s_scm_sys_modify_instance
592 {
593 SCM_VALIDATE_INSTANCE (1, old);
594 SCM_VALIDATE_INSTANCE (2, new);
595
596 /* Exchange the data contained in old and new. We exchange rather than
597 * scratch the old value with new to be correct with GC.
598 * See "Class redefinition protocol above".
599 */
600 SCM_CRITICAL_SECTION_START;
601 {
602 scm_t_bits word0, word1;
603 word0 = SCM_CELL_WORD_0 (old);
604 word1 = SCM_CELL_WORD_1 (old);
605 SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
606 SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
607 SCM_SET_CELL_WORD_0 (new, word0);
608 SCM_SET_CELL_WORD_1 (new, word1);
609 }
610 SCM_CRITICAL_SECTION_END;
611 return SCM_UNSPECIFIED;
612 }
613 #undef FUNC_NAME
614
615 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
616 (SCM old, SCM new),
617 "")
618 #define FUNC_NAME s_scm_sys_modify_class
619 {
620 SCM_VALIDATE_CLASS (1, old);
621 SCM_VALIDATE_CLASS (2, new);
622
623 SCM_CRITICAL_SECTION_START;
624 {
625 scm_t_bits word0, word1;
626 word0 = SCM_CELL_WORD_0 (old);
627 word1 = SCM_CELL_WORD_1 (old);
628 SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
629 SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
630 SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
631 SCM_SET_CELL_WORD_0 (new, word0);
632 SCM_SET_CELL_WORD_1 (new, word1);
633 SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
634 }
635 SCM_CRITICAL_SECTION_END;
636 return SCM_UNSPECIFIED;
637 }
638 #undef FUNC_NAME
639
640 SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
641 (SCM class),
642 "")
643 #define FUNC_NAME s_scm_sys_invalidate_class
644 {
645 SCM_VALIDATE_CLASS (1, class);
646 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
647 return SCM_UNSPECIFIED;
648 }
649 #undef FUNC_NAME
650
651 /* When instances change class, they finally get a new body, but
652 * before that, they go through purgatory in hell. Odd as it may
653 * seem, this data structure saves us from eternal suffering in
654 * infinite recursions.
655 */
656
657 static scm_t_bits **hell;
658 static long n_hell = 1; /* one place for the evil one himself */
659 static long hell_size = 4;
660 static SCM hell_mutex;
661
662 static long
663 burnin (SCM o)
664 {
665 long i;
666 for (i = 1; i < n_hell; ++i)
667 if (SCM_STRUCT_DATA (o) == hell[i])
668 return i;
669 return 0;
670 }
671
672 static void
673 go_to_hell (void *o)
674 {
675 SCM obj = *(SCM*)o;
676 scm_lock_mutex (hell_mutex);
677 if (n_hell >= hell_size)
678 {
679 hell_size *= 2;
680 hell = scm_realloc (hell, hell_size * sizeof(*hell));
681 }
682 hell[n_hell++] = SCM_STRUCT_DATA (obj);
683 scm_unlock_mutex (hell_mutex);
684 }
685
686 static void
687 go_to_heaven (void *o)
688 {
689 SCM obj = *(SCM*)o;
690 scm_lock_mutex (hell_mutex);
691 hell[burnin (obj)] = hell[--n_hell];
692 scm_unlock_mutex (hell_mutex);
693 }
694
695
696 static SCM
697 purgatory (SCM obj, SCM new_class)
698 {
699 return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
700 }
701
702 /* This function calls the generic function change-class for all
703 * instances which aren't currently undergoing class change.
704 */
705
706 void
707 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
708 {
709 if (!burnin (obj))
710 {
711 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
712 scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
713 scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
714 purgatory (obj, new_class);
715 scm_dynwind_end ();
716 }
717 }
718
719 /******************************************************************************
720 *
721 * GGGG FFFFF
722 * G F
723 * G GG FFF
724 * G G F
725 * GGG E N E R I C F U N C T I O N S
726 *
727 * This implementation provides
728 * - generic functions (with class specializers)
729 * - multi-methods
730 * - next-method
731 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
732 *
733 ******************************************************************************/
734
735 SCM_KEYWORD (k_name, "name");
736 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
737
738 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
739 (SCM proc),
740 "")
741 #define FUNC_NAME s_scm_generic_capability_p
742 {
743 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
744 proc, SCM_ARG1, FUNC_NAME);
745 return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
746 }
747 #undef FUNC_NAME
748
749 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
750 (SCM subrs),
751 "")
752 #define FUNC_NAME s_scm_enable_primitive_generic_x
753 {
754 SCM_VALIDATE_REST_ARGUMENT (subrs);
755 while (!scm_is_null (subrs))
756 {
757 SCM subr = SCM_CAR (subrs);
758 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
759 SCM_SET_SUBR_GENERIC (subr,
760 scm_make (scm_list_3 (class_generic,
761 k_name,
762 SCM_SUBR_NAME (subr))));
763 subrs = SCM_CDR (subrs);
764 }
765 return SCM_UNSPECIFIED;
766 }
767 #undef FUNC_NAME
768
769 SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
770 (SCM subr, SCM generic),
771 "")
772 #define FUNC_NAME s_scm_set_primitive_generic_x
773 {
774 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
775 SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
776 SCM_SET_SUBR_GENERIC (subr, generic);
777 return SCM_UNSPECIFIED;
778 }
779 #undef FUNC_NAME
780
781 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
782 (SCM subr),
783 "")
784 #define FUNC_NAME s_scm_primitive_generic_generic
785 {
786 if (SCM_PRIMITIVE_GENERIC_P (subr))
787 {
788 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
789 scm_enable_primitive_generic_x (scm_list_1 (subr));
790 return *SCM_SUBR_GENERIC (subr);
791 }
792 SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
793 }
794 #undef FUNC_NAME
795
796 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
797 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
798 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
799 */
800
801 SCM
802 scm_wta_dispatch_0 (SCM gf, const char *subr)
803 {
804 if (!SCM_UNPACK (gf))
805 scm_error_num_args_subr (subr);
806
807 return scm_call_0 (gf);
808 }
809
810 SCM
811 scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
812 {
813 if (!SCM_UNPACK (gf))
814 scm_wrong_type_arg (subr, pos, a1);
815
816 return scm_call_1 (gf, a1);
817 }
818
819 SCM
820 scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
821 {
822 if (!SCM_UNPACK (gf))
823 scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
824
825 return scm_call_2 (gf, a1, a2);
826 }
827
828 SCM
829 scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
830 {
831 if (!SCM_UNPACK (gf))
832 scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
833
834 return scm_apply_0 (gf, args);
835 }
836
837 /******************************************************************************
838 *
839 * Protocol for calling a generic fumction
840 * This protocol is roughly equivalent to (parameter are a little bit different
841 * for efficiency reasons):
842 *
843 * + apply-generic (gf args)
844 * + compute-applicable-methods (gf args ...)
845 * + sort-applicable-methods (methods args)
846 * + apply-methods (gf methods args)
847 *
848 * apply-methods calls make-next-method to build the "continuation" of a a
849 * method. Applying a next-method will call apply-next-method which in
850 * turn will call apply again to call effectively the following method.
851 *
852 ******************************************************************************/
853
854 SCM_DEFINE (scm_make, "make", 0, 0, 1,
855 (SCM args),
856 "Make a new object. @var{args} must contain the class and\n"
857 "all necessary initialization information.")
858 #define FUNC_NAME s_scm_make
859 {
860 return scm_apply_0 (scm_variable_ref (var_make), args);
861 }
862 #undef FUNC_NAME
863
864
865 /**********************************************************************
866 *
867 * Smob classes
868 *
869 **********************************************************************/
870
871 static SCM
872 make_class_name (const char *prefix, const char *type_name, const char *suffix)
873 {
874 if (!type_name)
875 type_name = "";
876 return scm_string_to_symbol (scm_string_append
877 (scm_list_3 (scm_from_utf8_string (prefix),
878 scm_from_utf8_string (type_name),
879 scm_from_utf8_string (suffix))));
880 }
881
882 SCM
883 scm_make_extended_class (char const *type_name, int applicablep)
884 {
885 SCM name, meta, supers;
886
887 name = make_class_name ("<", type_name, ">");
888 meta = class_class;
889
890 if (applicablep)
891 supers = scm_list_1 (class_applicable);
892 else
893 supers = scm_list_1 (class_top);
894
895 return scm_make_standard_class (meta, name, supers, SCM_EOL);
896 }
897
898 void
899 scm_i_inherit_applicable (SCM c)
900 {
901 if (!SCM_SUBCLASSP (c, class_applicable))
902 {
903 SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
904 SCM cpl = SCM_SLOT (c, scm_si_cpl);
905 /* patch class_applicable into direct-supers */
906 SCM top = scm_c_memq (class_top, dsupers);
907 if (scm_is_false (top))
908 dsupers = scm_append (scm_list_2 (dsupers,
909 scm_list_1 (class_applicable)));
910 else
911 {
912 SCM_SETCAR (top, class_applicable);
913 SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
914 }
915 SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
916 /* patch class_applicable into cpl */
917 top = scm_c_memq (class_top, cpl);
918 if (scm_is_false (top))
919 abort ();
920 else
921 {
922 SCM_SETCAR (top, class_applicable);
923 SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
924 }
925 /* add class to direct-subclasses of class_applicable */
926 SCM_SET_SLOT (class_applicable,
927 scm_si_direct_subclasses,
928 scm_cons (c, SCM_SLOT (class_applicable,
929 scm_si_direct_subclasses)));
930 }
931 }
932
933 static void
934 create_smob_classes (void)
935 {
936 long i;
937
938 for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
939 scm_i_smob_class[i] = SCM_BOOL_F;
940
941 for (i = 0; i < scm_numsmob; ++i)
942 if (scm_is_false (scm_i_smob_class[i]))
943 scm_i_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
944 scm_smobs[i].apply != 0);
945 }
946
947 void
948 scm_make_port_classes (long ptobnum, char *type_name)
949 {
950 SCM name, meta, super, supers;
951
952 meta = class_class;
953
954 name = make_class_name ("<", type_name, "-port>");
955 supers = scm_list_1 (class_port);
956 super = scm_make_standard_class (meta, name, supers, SCM_EOL);
957
958 name = make_class_name ("<", type_name, "-input-port>");
959 supers = scm_list_2 (super, class_input_port);
960 scm_i_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
961 = scm_make_standard_class (meta, name, supers, SCM_EOL);
962
963 name = make_class_name ("<", type_name, "-output-port>");
964 supers = scm_list_2 (super, class_output_port);
965 scm_i_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
966 = scm_make_standard_class (meta, name, supers, SCM_EOL);
967
968 name = make_class_name ("<", type_name, "-input-output-port>");
969 supers = scm_list_2 (super, class_input_output_port);
970 scm_i_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
971 = scm_make_standard_class (meta, name, supers, SCM_EOL);
972 }
973
974 static void
975 create_port_classes (void)
976 {
977 long i;
978
979 for (i = scm_c_num_port_types () - 1; i >= 0; i--)
980 scm_make_port_classes (i, SCM_PTOBNAME (i));
981 }
982
983 SCM
984 scm_i_define_class_for_vtable (SCM vtable)
985 {
986 SCM class;
987
988 scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
989 if (scm_is_false (vtable_class_map))
990 vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
991 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
992
993 if (scm_is_false (scm_struct_vtable_p (vtable)))
994 abort ();
995
996 class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
997
998 if (scm_is_false (class))
999 {
1000 if (SCM_UNPACK (class_class))
1001 {
1002 SCM name, meta, supers;
1003
1004 name = SCM_VTABLE_NAME (vtable);
1005 if (scm_is_symbol (name))
1006 name = scm_string_to_symbol
1007 (scm_string_append
1008 (scm_list_3 (scm_from_latin1_string ("<"),
1009 scm_symbol_to_string (name),
1010 scm_from_latin1_string (">"))));
1011 else
1012 name = scm_from_latin1_symbol ("<>");
1013
1014 if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER))
1015 {
1016 meta = class_applicable_struct_with_setter_class;
1017 supers = scm_list_1 (class_applicable_struct_with_setter);
1018 }
1019 else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable,
1020 SCM_VTABLE_FLAG_APPLICABLE))
1021 {
1022 meta = class_applicable_struct_class;
1023 supers = scm_list_1 (class_applicable_struct);
1024 }
1025 else
1026 {
1027 meta = class_class;
1028 supers = scm_list_1 (class_top);
1029 }
1030
1031 return scm_make_standard_class (meta, name, supers, SCM_EOL);
1032 }
1033 else
1034 /* `create_struct_classes' will fill this in later. */
1035 class = SCM_BOOL_F;
1036
1037 /* Don't worry about races. This only happens when creating a
1038 vtable, which happens by definition in one thread. */
1039 scm_weak_table_putq_x (vtable_class_map, vtable, class);
1040 }
1041
1042 return class;
1043 }
1044
1045 static SCM
1046 make_struct_class (void *closure SCM_UNUSED,
1047 SCM vtable, SCM data, SCM prev SCM_UNUSED)
1048 {
1049 if (scm_is_false (data))
1050 scm_i_define_class_for_vtable (vtable);
1051 return SCM_UNSPECIFIED;
1052 }
1053
1054 static void
1055 create_struct_classes (void)
1056 {
1057 /* FIXME: take the vtable_class_map while initializing goops? */
1058 scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
1059 vtable_class_map);
1060 }
1061
1062 /**********************************************************************
1063 *
1064 * C interface
1065 *
1066 **********************************************************************/
1067
1068 void
1069 scm_load_goops ()
1070 {
1071 if (!goops_loaded_p)
1072 scm_c_resolve_module ("oop goops");
1073 }
1074
1075
1076 SCM_KEYWORD (k_setter, "setter");
1077
1078 SCM
1079 scm_ensure_accessor (SCM name)
1080 {
1081 SCM var, gf;
1082
1083 var = scm_module_variable (scm_current_module (), name);
1084 if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
1085 gf = SCM_VARIABLE_REF (var);
1086 else
1087 gf = SCM_BOOL_F;
1088
1089 if (!SCM_IS_A_P (gf, class_accessor))
1090 {
1091 gf = scm_make (scm_list_3 (class_generic, k_name, name));
1092 gf = scm_make (scm_list_5 (class_accessor,
1093 k_name, name, k_setter, gf));
1094 }
1095
1096 return gf;
1097 }
1098
1099 /*
1100 * Initialization
1101 */
1102
1103 SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0,
1104 (SCM applicable, SCM setter),
1105 "")
1106 #define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
1107 {
1108 SCM_VALIDATE_CLASS (1, applicable);
1109 SCM_VALIDATE_CLASS (2, setter);
1110 SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
1111 SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE);
1112 return SCM_UNSPECIFIED;
1113 }
1114 #undef FUNC_NAME
1115
1116 SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
1117 (),
1118 "")
1119 #define FUNC_NAME s_scm_sys_goops_early_init
1120 {
1121 var_make_standard_class = scm_c_lookup ("make-standard-class");
1122 var_make = scm_c_lookup ("make");
1123
1124 var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
1125 var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
1126 var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
1127 var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
1128
1129 var_slot_ref = scm_c_lookup ("slot-ref");
1130 var_slot_set_x = scm_c_lookup ("slot-set!");
1131 var_slot_bound_p = scm_c_lookup ("slot-bound?");
1132 var_slot_exists_p = scm_c_lookup ("slot-exists?");
1133
1134 class_class = scm_variable_ref (scm_c_lookup ("<class>"));
1135 class_top = scm_variable_ref (scm_c_lookup ("<top>"));
1136 class_object = scm_variable_ref (scm_c_lookup ("<object>"));
1137
1138 class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
1139 class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
1140 class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
1141 class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
1142 class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
1143 class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
1144 class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
1145 class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
1146 class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
1147 class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
1148 class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
1149 class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
1150 class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
1151
1152 /* Applicables */
1153 class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
1154 class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
1155 class_applicable_struct_with_setter_class =
1156 scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
1157
1158 class_method = scm_variable_ref (scm_c_lookup ("<method>"));
1159 class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
1160 class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
1161 class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
1162 class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
1163 class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
1164 class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
1165 class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
1166 class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
1167 class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
1168 class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
1169
1170 /* Primitive types classes */
1171 class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
1172 class_char = scm_variable_ref (scm_c_lookup ("<char>"));
1173 class_list = scm_variable_ref (scm_c_lookup ("<list>"));
1174 class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
1175 class_null = scm_variable_ref (scm_c_lookup ("<null>"));
1176 class_string = scm_variable_ref (scm_c_lookup ("<string>"));
1177 class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
1178 class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
1179 class_foreign = scm_variable_ref (scm_c_lookup ("<foreign>"));
1180 class_hashtable = scm_variable_ref (scm_c_lookup ("<hashtable>"));
1181 class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
1182 class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
1183 class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
1184 class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
1185 class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
1186 class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
1187 class_array = scm_variable_ref (scm_c_lookup ("<array>"));
1188 class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
1189 class_number = scm_variable_ref (scm_c_lookup ("<number>"));
1190 class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
1191 class_real = scm_variable_ref (scm_c_lookup ("<real>"));
1192 class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
1193 class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
1194 class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
1195 class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
1196 class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
1197 class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1198 class_port = scm_variable_ref (scm_c_lookup ("<port>"));
1199 class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
1200 class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
1201 class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1202
1203 create_smob_classes ();
1204 create_struct_classes ();
1205 create_port_classes ();
1206
1207 return SCM_UNSPECIFIED;
1208 }
1209 #undef FUNC_NAME
1210
1211 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
1212 (),
1213 "Announce that GOOPS is loaded and perform initialization\n"
1214 "on the C level which depends on the loaded GOOPS modules.")
1215 #define FUNC_NAME s_scm_sys_goops_loaded
1216 {
1217 goops_loaded_p = 1;
1218 var_class_name = scm_c_lookup ("class-name");
1219 var_class_direct_supers = scm_c_lookup ("class-direct-supers");
1220 var_class_direct_slots = scm_c_lookup ("class-direct-slots");
1221 var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
1222 var_class_direct_methods = scm_c_lookup ("class-direct-methods");
1223 var_class_precedence_list = scm_c_lookup ("class-precedence-list");
1224 var_class_slots = scm_c_lookup ("class-slots");
1225
1226 var_generic_function_methods = scm_c_lookup ("generic-function-methods");
1227 var_method_generic_function = scm_c_lookup ("method-generic-function");
1228 var_method_specializers = scm_c_lookup ("method-specializers");
1229 var_method_procedure = scm_c_lookup ("method-procedure");
1230
1231 var_change_class = scm_c_lookup ("change-class");
1232
1233 #if (SCM_ENABLE_DEPRECATED == 1)
1234 scm_init_deprecated_goops ();
1235 #endif
1236
1237 return SCM_UNSPECIFIED;
1238 }
1239 #undef FUNC_NAME
1240
1241 SCM scm_module_goops;
1242
1243 static void
1244 scm_init_goops_builtins (void *unused)
1245 {
1246 scm_module_goops = scm_current_module ();
1247
1248 hell = scm_calloc (hell_size * sizeof (*hell));
1249 hell_mutex = scm_make_mutex ();
1250
1251 #include "libguile/goops.x"
1252 }
1253
1254 void
1255 scm_init_goops ()
1256 {
1257 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1258 "scm_init_goops_builtins", scm_init_goops_builtins,
1259 NULL);
1260 }
1261
1262 /*
1263 Local Variables:
1264 c-file-style: "gnu"
1265 End:
1266 */
Unnamed repository; edit this file 'description' to name the repository.