1 /* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
43 /* This software is a derivative work of other copyrighted softwares; the
44 * copyright notices of these softwares are placed in the file COPYRIGHTS
46 * This file is based upon stklos.c from the STk distribution by
47 * Erick Gallesio <eg@unice.fr>.
52 #include "libguile/_scm.h"
53 #include "libguile/alist.h"
54 #include "libguile/debug.h"
55 #include "libguile/dynl.h"
56 #include "libguile/dynwind.h"
57 #include "libguile/eval.h"
58 #include "libguile/hashtab.h"
59 #include "libguile/keywords.h"
60 #include "libguile/macros.h"
61 #include "libguile/modules.h"
62 #include "libguile/objects.h"
63 #include "libguile/ports.h"
64 #include "libguile/procprop.h"
65 #include "libguile/random.h"
66 #include "libguile/root.h"
67 #include "libguile/smob.h"
68 #include "libguile/strings.h"
69 #include "libguile/strports.h"
70 #include "libguile/vectors.h"
71 #include "libguile/weaks.h"
73 #include "libguile/validate.h"
74 #include "libguile/goops.h"
76 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
78 #define DEFVAR(v, val) \
79 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
81 /* Temporary hack until we get the new module system */
82 /*fixme* Should optimize by keeping track of the variable object itself */
83 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
86 /* Fixme: Should use already interned symbols */
87 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
89 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
91 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
93 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
96 /* Class redefinition protocol:
98 A class is represented by a heap header h1 which points to a
99 malloc:ed memory block m1.
101 When a new version of a class is created, a new header h2 and
102 memory block m2 are allocated. The headers h1 and h2 then switch
103 pointers so that h1 refers to m2 and h2 to m1. In this way, names
104 bound to h1 will point to the new class at the same time as h2 will
105 be a handle which the GC will us to free m1.
107 The `redefined' slot of m1 will be set to point to h1. An old
108 instance will have it's class pointer (the CAR of the heap header)
109 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
110 the class modification and the new class pointer can be found via
114 /* The following definition is located in libguile/objects.h:
115 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
118 #define TEST_CHANGE_CLASS(obj, class) \
120 class = SCM_CLASS_OF (obj); \
121 if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
122 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
125 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
126 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
128 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
129 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
131 static int goops_loaded_p
= 0;
132 static scm_t_rstate
*goops_rstate
;
134 static SCM scm_goops_lookup_closure
;
136 /* Some classes are defined in libguile/objects.c. */
137 SCM scm_class_top
, scm_class_object
, scm_class_class
;
138 SCM scm_class_entity
, scm_class_entity_with_setter
;
139 SCM scm_class_generic
, scm_class_generic_with_setter
;
140 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
141 SCM scm_class_method
;
142 SCM scm_class_simple_method
, scm_class_accessor
;
143 SCM scm_class_procedure_class
;
144 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
145 SCM scm_class_entity_class
;
146 SCM scm_class_number
, scm_class_list
;
147 SCM scm_class_keyword
;
148 SCM scm_class_port
, scm_class_input_output_port
;
149 SCM scm_class_input_port
, scm_class_output_port
;
150 SCM scm_class_foreign_class
, scm_class_foreign_object
;
151 SCM scm_class_foreign_slot
;
152 SCM scm_class_self
, scm_class_protected
;
153 SCM scm_class_opaque
, scm_class_read_only
;
154 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
156 SCM scm_class_int
, scm_class_float
, scm_class_double
;
158 SCM_SYMBOL (scm_sym_define_public
, "define-public");
160 static SCM
scm_make_unbound (void);
161 static SCM
scm_unbound_p (SCM obj
);
162 static SCM
scm_assert_bound (SCM value
, SCM obj
);
163 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
164 static SCM
scm_sys_goops_loaded (void);
166 /******************************************************************************
170 * This version doesn't fully handle multiple-inheritance. It serves
171 * only for booting classes and will be overloaded in Scheme
173 ******************************************************************************/
176 map (SCM (*proc
) (SCM
), SCM ls
)
182 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
185 while (!SCM_NULLP (ls
))
187 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
199 while (!SCM_NULLP (ls
))
201 SCM el
= SCM_CAR (ls
);
202 if (SCM_FALSEP (scm_c_memq (el
, res
)))
203 res
= scm_cons (el
, res
);
210 compute_cpl (SCM
class)
213 return CALL_GF1 ("compute-cpl", class);
216 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
217 SCM ls
= scm_append (scm_acons (class, supers
,
218 map (compute_cpl
, supers
)));
219 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
223 /******************************************************************************
227 ******************************************************************************/
230 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
238 if (!SCM_SYMBOLP (tmp
))
239 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
241 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
242 res
= scm_cons (SCM_CAR (l
), res
);
243 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
246 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
250 build_slots_list (SCM dslots
, SCM cpl
)
252 register SCM res
= dslots
;
254 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
255 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
256 scm_si_direct_slots
),
259 /* res contains a list of slots. Remove slots which appears more than once */
260 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
267 while (!SCM_NULLP (ls
))
269 if (!SCM_CONSP (SCM_CAR (ls
)))
270 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
277 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
279 "Return a list consisting of the names of all slots belonging to\n"
280 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
282 #define FUNC_NAME s_scm_sys_compute_slots
284 SCM_VALIDATE_CLASS (1, class);
285 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
286 SCM_SLOT (class, scm_si_cpl
));
291 /******************************************************************************
293 * compute-getters-n-setters
295 * This version doesn't handle slot options. It serves only for booting
296 * classes and will be overloaded in Scheme.
298 ******************************************************************************/
300 SCM_KEYWORD (k_init_value
, "init-value");
301 SCM_KEYWORD (k_init_thunk
, "init-thunk");
304 compute_getters_n_setters (SCM slots
)
310 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
312 SCM init
= SCM_BOOL_F
;
313 SCM options
= SCM_CDAR (slots
);
314 if (!SCM_NULLP (options
))
316 init
= scm_get_keyword (k_init_value
, options
, 0);
318 init
= scm_closure (scm_list_2 (SCM_EOL
,
319 scm_list_2 (scm_sym_quote
, init
)),
322 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
324 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
328 cdrloc
= SCM_CDRLOC (*cdrloc
);
333 /******************************************************************************
337 ******************************************************************************/
339 /*fixme* Manufacture keywords in advance */
341 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
345 for (i
= 0; i
!= len
; i
+= 2)
347 SCM obj
= SCM_CAR (l
);
349 if (!SCM_KEYWORDP (obj
))
350 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
351 else if (SCM_EQ_P (obj
, key
))
357 return default_value
;
361 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
362 (SCM key
, SCM l
, SCM default_value
),
363 "Determine an associated value for the keyword @var{key} from\n"
364 "the list @var{l}. The list @var{l} has to consist of an even\n"
365 "number of elements, where, starting with the first, every\n"
366 "second element is a keyword, followed by its associated value.\n"
367 "If @var{l} does not hold a value for @var{key}, the value\n"
368 "@var{default_value} is returned.")
369 #define FUNC_NAME s_scm_get_keyword
373 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
374 len
= scm_ilength (l
);
375 if (len
< 0 || len
% 2 == 1)
376 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
378 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
383 SCM_KEYWORD (k_init_keyword
, "init-keyword");
385 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
386 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
388 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
389 (SCM obj
, SCM initargs
),
390 "Initialize the object @var{obj} with the given arguments\n"
392 #define FUNC_NAME s_scm_sys_initialize_object
394 SCM tmp
, get_n_set
, slots
;
395 SCM
class = SCM_CLASS_OF (obj
);
398 SCM_VALIDATE_INSTANCE (1, obj
);
399 n_initargs
= scm_ilength (initargs
);
400 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
402 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
403 slots
= SCM_SLOT (class, scm_si_slots
);
405 /* See for each slot how it must be initialized */
408 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
410 SCM slot_name
= SCM_CAR (slots
);
413 if (!SCM_NULLP (SCM_CDR (slot_name
)))
415 /* This slot admits (perhaps) to be initialized at creation time */
416 long n
= scm_ilength (SCM_CDR (slot_name
));
417 if (n
& 1) /* odd or -1 */
418 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
419 scm_list_1 (slot_name
));
420 tmp
= scm_i_get_keyword (k_init_keyword
,
425 slot_name
= SCM_CAR (slot_name
);
428 /* an initarg was provided for this slot */
429 if (!SCM_KEYWORDP (tmp
))
430 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
432 slot_value
= scm_i_get_keyword (tmp
,
441 /* set slot to provided value */
442 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
445 /* set slot to its :init-form if it exists */
446 tmp
= SCM_CADAR (get_n_set
);
447 if (tmp
!= SCM_BOOL_F
)
449 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
450 if (SCM_GOOPS_UNBOUNDP (slot_value
))
452 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
453 set_slot_value (class,
456 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
467 SCM_KEYWORD (k_class
, "class");
468 SCM_KEYWORD (k_allocation
, "allocation");
469 SCM_KEYWORD (k_instance
, "instance");
471 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
474 #define FUNC_NAME s_scm_sys_prep_layout_x
477 unsigned long int n
, i
;
480 SCM_VALIDATE_INSTANCE (1, class);
481 slots
= SCM_SLOT (class, scm_si_slots
);
482 nfields
= SCM_SLOT (class, scm_si_nfields
);
483 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
484 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
485 scm_list_1 (nfields
));
486 n
= 2 * SCM_INUM (nfields
);
487 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
488 && SCM_SUBCLASSP (class, scm_class_class
))
489 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
490 scm_list_1 (nfields
));
492 s
= n
> 0 ? scm_malloc (n
) : 0;
493 for (i
= 0; i
< n
; i
+= 2)
496 SCM type
, allocation
;
499 if (!SCM_CONSP (slots
))
500 SCM_MISC_ERROR ("too few slot definitions", SCM_EOL
);
501 len
= scm_ilength (SCM_CDAR (slots
));
502 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
503 len
, k_instance
, FUNC_NAME
);
504 while (!SCM_EQ_P (allocation
, k_instance
))
506 slots
= SCM_CDR (slots
);
507 len
= scm_ilength (SCM_CDAR (slots
));
508 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
509 len
, k_instance
, FUNC_NAME
);
511 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
512 len
, SCM_BOOL_F
, FUNC_NAME
);
513 if (SCM_FALSEP (type
))
520 if (!SCM_CLASSP (type
))
521 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
522 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
524 if (SCM_SUBCLASSP (type
, scm_class_self
))
526 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
531 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
533 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
546 slots
= SCM_CDR (slots
);
548 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
551 return SCM_UNSPECIFIED
;
555 static void prep_hashsets (SCM
);
557 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
558 (SCM
class, SCM dsupers
),
560 #define FUNC_NAME s_scm_sys_inherit_magic_x
564 SCM_VALIDATE_INSTANCE (1, class);
565 while (!SCM_NULLP (ls
))
567 SCM_ASSERT (SCM_CONSP (ls
)
568 && SCM_INSTANCEP (SCM_CAR (ls
)),
572 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
575 flags
&= SCM_CLASSF_INHERIT
;
576 if (flags
& SCM_CLASSF_ENTITY
)
577 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
580 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
583 * We could avoid calling scm_gc_malloc in the allocation code
584 * (in which case the following two lines are needed). Instead
585 * we make 0-slot instances non-light, so that the light case
586 * can be handled without special cases.
589 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
591 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
593 /* NOTE: The following depends on scm_struct_i_size. */
594 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
595 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
598 SCM_SET_CLASS_FLAGS (class, flags
);
600 prep_hashsets (class);
602 return SCM_UNSPECIFIED
;
607 prep_hashsets (SCM
class)
611 for (i
= 0; i
< 7; ++i
)
612 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
615 /******************************************************************************/
618 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
620 SCM z
, cpl
, slots
, nfields
, g_n_s
;
622 /* Allocate one instance */
623 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
625 /* Initialize its slots */
626 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
627 cpl
= compute_cpl (z
);
628 slots
= build_slots_list (maplist (dslots
), cpl
);
629 nfields
= SCM_MAKINUM (scm_ilength (slots
));
630 g_n_s
= compute_getters_n_setters (slots
);
632 SCM_SET_SLOT (z
, scm_si_name
, name
);
633 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
634 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
635 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
636 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
637 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
638 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
639 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
640 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
641 SCM_SET_SLOT (z
, scm_si_environment
,
642 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
644 /* Add this class in the direct-subclasses slot of dsupers */
647 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
648 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
649 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
650 scm_si_direct_subclasses
)));
653 /* Support for the underlying structs: */
654 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
655 ? (SCM_CLASSF_GOOPS_OR_VALID
656 | SCM_CLASSF_OPERATOR
658 : class == scm_class_operator_class
659 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
660 : SCM_CLASSF_GOOPS_OR_VALID
));
665 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
667 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
668 scm_sys_inherit_magic_x (z
, dsupers
);
669 scm_sys_prep_layout_x (z
);
673 /******************************************************************************/
675 SCM_SYMBOL (sym_layout
, "layout");
676 SCM_SYMBOL (sym_vcell
, "vcell");
677 SCM_SYMBOL (sym_vtable
, "vtable");
678 SCM_SYMBOL (sym_print
, "print");
679 SCM_SYMBOL (sym_procedure
, "procedure");
680 SCM_SYMBOL (sym_setter
, "setter");
681 SCM_SYMBOL (sym_redefined
, "redefined");
682 SCM_SYMBOL (sym_h0
, "h0");
683 SCM_SYMBOL (sym_h1
, "h1");
684 SCM_SYMBOL (sym_h2
, "h2");
685 SCM_SYMBOL (sym_h3
, "h3");
686 SCM_SYMBOL (sym_h4
, "h4");
687 SCM_SYMBOL (sym_h5
, "h5");
688 SCM_SYMBOL (sym_h6
, "h6");
689 SCM_SYMBOL (sym_h7
, "h7");
690 SCM_SYMBOL (sym_name
, "name");
691 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
692 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
693 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
694 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
695 SCM_SYMBOL (sym_cpl
, "cpl");
696 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
697 SCM_SYMBOL (sym_slots
, "slots");
698 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
699 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
700 SCM_SYMBOL (sym_nfields
, "nfields");
701 SCM_SYMBOL (sym_environment
, "environment");
705 build_class_class_slots ()
708 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
709 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
710 scm_list_1 (sym_print
),
711 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
712 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
713 scm_list_1 (sym_redefined
),
714 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
715 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
716 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
717 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
718 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
719 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
720 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
721 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
722 scm_list_1 (sym_name
),
723 scm_list_1 (sym_direct_supers
),
724 scm_list_1 (sym_direct_slots
),
725 scm_list_1 (sym_direct_subclasses
),
726 scm_list_1 (sym_direct_methods
),
727 scm_list_1 (sym_cpl
),
728 scm_list_1 (sym_default_slot_definition_class
),
729 scm_list_1 (sym_slots
),
730 scm_list_1 (sym_getters_n_setters
),
731 scm_list_1 (sym_keyword_access
),
732 scm_list_1 (sym_nfields
),
733 scm_list_1 (sym_environment
),
738 create_basic_classes (void)
740 /* SCM slots_of_class = build_class_class_slots (); */
742 /**** <scm_class_class> ****/
743 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
744 + 2 * scm_vtable_offset_user
);
745 SCM name
= scm_str2symbol ("<class>");
746 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
749 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
750 | SCM_CLASSF_METACLASS
));
752 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
753 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
754 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
755 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
756 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
757 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
758 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
759 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
760 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
761 compute_getters_n_setters (slots_of_class)); */
762 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
763 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
764 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
766 prep_hashsets (scm_class_class
);
768 DEFVAR(name
, scm_class_class
);
770 /**** <scm_class_top> ****/
771 name
= scm_str2symbol ("<top>");
772 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
777 DEFVAR(name
, scm_class_top
);
779 /**** <scm_class_object> ****/
780 name
= scm_str2symbol ("<object>");
781 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
783 scm_list_1 (scm_class_top
),
786 DEFVAR (name
, scm_class_object
);
788 /* <top> <object> and <class> were partially initialized. Correct them here */
789 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
791 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
792 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
795 /******************************************************************************/
797 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
799 "Return @code{#t} if @var{obj} is an instance.")
800 #define FUNC_NAME s_scm_instance_p
802 return SCM_BOOL (SCM_INSTANCEP (obj
));
807 /******************************************************************************
809 * Meta object accessors
811 ******************************************************************************/
812 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
814 "Return the class name of @var{obj}.")
815 #define FUNC_NAME s_scm_class_name
817 SCM_VALIDATE_CLASS (1, obj
);
818 return scm_slot_ref (obj
, sym_name
);
822 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
824 "Return the direct superclasses of the class @var{obj}.")
825 #define FUNC_NAME s_scm_class_direct_supers
827 SCM_VALIDATE_CLASS (1, obj
);
828 return scm_slot_ref (obj
, sym_direct_supers
);
832 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
834 "Return the direct slots of the class @var{obj}.")
835 #define FUNC_NAME s_scm_class_direct_slots
837 SCM_VALIDATE_CLASS (1, obj
);
838 return scm_slot_ref (obj
, sym_direct_slots
);
842 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
844 "Return the direct subclasses of the class @var{obj}.")
845 #define FUNC_NAME s_scm_class_direct_subclasses
847 SCM_VALIDATE_CLASS (1, obj
);
848 return scm_slot_ref(obj
, sym_direct_subclasses
);
852 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
854 "Return the direct methods of the class @var{obj}")
855 #define FUNC_NAME s_scm_class_direct_methods
857 SCM_VALIDATE_CLASS (1, obj
);
858 return scm_slot_ref (obj
, sym_direct_methods
);
862 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
864 "Return the class precedence list of the class @var{obj}.")
865 #define FUNC_NAME s_scm_class_precedence_list
867 SCM_VALIDATE_CLASS (1, obj
);
868 return scm_slot_ref (obj
, sym_cpl
);
872 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
874 "Return the slot list of the class @var{obj}.")
875 #define FUNC_NAME s_scm_class_slots
877 SCM_VALIDATE_CLASS (1, obj
);
878 return scm_slot_ref (obj
, sym_slots
);
882 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
884 "Return the environment of the class @var{obj}.")
885 #define FUNC_NAME s_scm_class_environment
887 SCM_VALIDATE_CLASS (1, obj
);
888 return scm_slot_ref(obj
, sym_environment
);
893 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
895 "Return the name of the generic function @var{obj}.")
896 #define FUNC_NAME s_scm_generic_function_name
898 SCM_VALIDATE_GENERIC (1, obj
);
899 return scm_procedure_property (obj
, scm_sym_name
);
903 SCM_SYMBOL (sym_methods
, "methods");
904 SCM_SYMBOL (sym_extended_by
, "extended-by");
905 SCM_SYMBOL (sym_extends
, "extends");
908 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
910 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
911 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
912 while (!SCM_NULLP (gfs
))
914 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
921 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
923 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
925 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
926 while (!SCM_NULLP (gfs
))
928 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
929 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
938 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
940 "Return the methods of the generic function @var{obj}.")
941 #define FUNC_NAME s_scm_generic_function_methods
944 SCM_VALIDATE_GENERIC (1, obj
);
945 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
946 methods
= fold_downward_gf_methods (methods
, obj
);
947 return scm_append (methods
);
951 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
953 "Return the generic function for the method @var{obj}.")
954 #define FUNC_NAME s_scm_method_generic_function
956 SCM_VALIDATE_METHOD (1, obj
);
957 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
961 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
963 "Return specializers of the method @var{obj}.")
964 #define FUNC_NAME s_scm_method_specializers
966 SCM_VALIDATE_METHOD (1, obj
);
967 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
971 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
973 "Return the procedure of the method @var{obj}.")
974 #define FUNC_NAME s_scm_method_procedure
976 SCM_VALIDATE_METHOD (1, obj
);
977 return scm_slot_ref (obj
, sym_procedure
);
981 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
983 "Return the slot definition of the accessor @var{obj}.")
984 #define FUNC_NAME s_scm_accessor_method_slot_definition
986 SCM_VALIDATE_ACCESSOR (1, obj
);
987 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
991 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
993 "Internal GOOPS magic---don't use this function!")
994 #define FUNC_NAME s_scm_sys_tag_body
996 return scm_cons (SCM_IM_LAMBDA
, body
);
1000 /******************************************************************************
1002 * S l o t a c c e s s
1004 ******************************************************************************/
1006 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1008 "Return the unbound value.")
1009 #define FUNC_NAME s_scm_make_unbound
1011 return SCM_GOOPS_UNBOUND
;
1015 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1017 "Return @code{#t} if @var{obj} is unbound.")
1018 #define FUNC_NAME s_scm_unbound_p
1020 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1024 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1025 (SCM value
, SCM obj
),
1026 "Return @var{value} if it is bound, and invoke the\n"
1027 "@var{slot-unbound} method of @var{obj} if it is not.")
1028 #define FUNC_NAME s_scm_assert_bound
1030 if (SCM_GOOPS_UNBOUNDP (value
))
1031 return CALL_GF1 ("slot-unbound", obj
);
1036 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1037 (SCM obj
, SCM index
),
1038 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1039 "the value from @var{obj}.")
1040 #define FUNC_NAME s_scm_at_assert_bound_ref
1042 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1043 if (SCM_GOOPS_UNBOUNDP (value
))
1044 return CALL_GF1 ("slot-unbound", obj
);
1049 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1050 (SCM obj
, SCM index
),
1051 "Return the slot value with index @var{index} from @var{obj}.")
1052 #define FUNC_NAME s_scm_sys_fast_slot_ref
1054 unsigned long int i
;
1056 SCM_VALIDATE_INSTANCE (1, obj
);
1057 SCM_VALIDATE_INUM (2, index
);
1058 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1059 i
= SCM_INUM (index
);
1060 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1062 return scm_at_assert_bound_ref (obj
, index
);
1066 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1067 (SCM obj
, SCM index
, SCM value
),
1068 "Set the slot with index @var{index} in @var{obj} to\n"
1070 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1072 unsigned long int i
;
1074 SCM_VALIDATE_INSTANCE (1, obj
);
1075 SCM_VALIDATE_INUM (2, index
);
1076 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1077 i
= SCM_INUM (index
);
1078 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1080 SCM_SET_SLOT (obj
, i
, value
);
1082 return SCM_UNSPECIFIED
;
1089 /* In the future, this function will return the effective slot
1090 * definition associated with SLOT_NAME. Now it just returns some of
1091 * the information which will be stored in the effective slot
1096 slot_definition_using_name (SCM
class, SCM slot_name
)
1098 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1099 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1100 if (SCM_CAAR (slots
) == slot_name
)
1101 return SCM_CAR (slots
);
1106 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1108 SCM access
= SCM_CDDR (slotdef
);
1110 * - access is an integer (the offset of this slot in the slots vector)
1111 * - otherwise (car access) is the getter function to apply
1113 if (SCM_INUMP (access
))
1114 return SCM_SLOT (obj
, SCM_INUM (access
));
1117 /* We must evaluate (apply (car access) (list obj))
1118 * where (car access) is known to be a closure of arity 1 */
1119 register SCM code
, env
;
1121 code
= SCM_CAR (access
);
1122 if (!SCM_CLOSUREP (code
))
1123 return SCM_SUBRF (code
) (obj
);
1124 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1127 /* Evaluate the closure body */
1128 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1133 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1135 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1136 if (!SCM_FALSEP (slotdef
))
1137 return get_slot_value (class, obj
, slotdef
);
1139 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1143 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1145 SCM access
= SCM_CDDR (slotdef
);
1147 * - access is an integer (the offset of this slot in the slots vector)
1148 * - otherwise (cadr access) is the setter function to apply
1150 if (SCM_INUMP (access
))
1151 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1154 /* We must evaluate (apply (cadr l) (list obj value))
1155 * where (cadr l) is known to be a closure of arity 2 */
1156 register SCM code
, env
;
1158 code
= SCM_CADR (access
);
1159 if (!SCM_CLOSUREP (code
))
1160 SCM_SUBRF (code
) (obj
, value
);
1163 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1164 scm_list_2 (obj
, value
),
1166 /* Evaluate the closure body */
1167 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1170 return SCM_UNSPECIFIED
;
1174 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1176 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1177 if (!SCM_FALSEP (slotdef
))
1178 return set_slot_value (class, obj
, slotdef
, value
);
1180 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1184 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1188 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1189 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1195 /* ======================================== */
1197 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1198 (SCM
class, SCM obj
, SCM slot_name
),
1200 #define FUNC_NAME s_scm_slot_ref_using_class
1204 SCM_VALIDATE_CLASS (1, class);
1205 SCM_VALIDATE_INSTANCE (2, obj
);
1206 SCM_VALIDATE_SYMBOL (3, slot_name
);
1208 res
= get_slot_value_using_name (class, obj
, slot_name
);
1209 if (SCM_GOOPS_UNBOUNDP (res
))
1210 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1216 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1217 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1219 #define FUNC_NAME s_scm_slot_set_using_class_x
1221 SCM_VALIDATE_CLASS (1, class);
1222 SCM_VALIDATE_INSTANCE (2, obj
);
1223 SCM_VALIDATE_SYMBOL (3, slot_name
);
1225 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1230 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1231 (SCM
class, SCM obj
, SCM slot_name
),
1233 #define FUNC_NAME s_scm_slot_bound_using_class_p
1235 SCM_VALIDATE_CLASS (1, class);
1236 SCM_VALIDATE_INSTANCE (2, obj
);
1237 SCM_VALIDATE_SYMBOL (3, slot_name
);
1239 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1245 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1246 (SCM
class, SCM obj
, SCM slot_name
),
1248 #define FUNC_NAME s_scm_slot_exists_using_class_p
1250 SCM_VALIDATE_CLASS (1, class);
1251 SCM_VALIDATE_INSTANCE (2, obj
);
1252 SCM_VALIDATE_SYMBOL (3, slot_name
);
1253 return test_slot_existence (class, obj
, slot_name
);
1258 /* ======================================== */
1260 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1261 (SCM obj
, SCM slot_name
),
1262 "Return the value from @var{obj}'s slot with the name\n"
1264 #define FUNC_NAME s_scm_slot_ref
1268 SCM_VALIDATE_INSTANCE (1, obj
);
1269 TEST_CHANGE_CLASS (obj
, class);
1271 res
= get_slot_value_using_name (class, obj
, slot_name
);
1272 if (SCM_GOOPS_UNBOUNDP (res
))
1273 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1278 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1279 (SCM obj
, SCM slot_name
, SCM value
),
1280 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1281 #define FUNC_NAME s_scm_slot_set_x
1285 SCM_VALIDATE_INSTANCE (1, obj
);
1286 TEST_CHANGE_CLASS(obj
, class);
1288 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1292 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1294 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1295 (SCM obj
, SCM slot_name
),
1296 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1298 #define FUNC_NAME s_scm_slot_bound_p
1302 SCM_VALIDATE_INSTANCE (1, obj
);
1303 TEST_CHANGE_CLASS(obj
, class);
1305 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1313 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1314 (SCM obj
, SCM slot_name
),
1315 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1316 #define FUNC_NAME s_scm_slot_exists_p
1320 SCM_VALIDATE_INSTANCE (1, obj
);
1321 SCM_VALIDATE_SYMBOL (2, slot_name
);
1322 TEST_CHANGE_CLASS (obj
, class);
1324 return test_slot_existence (class, obj
, slot_name
);
1329 /******************************************************************************
1331 * %allocate-instance (the low level instance allocation primitive)
1333 ******************************************************************************/
1335 static void clear_method_cache (SCM
);
1338 wrap_init (SCM
class, SCM
*m
, long n
)
1342 /* Set all slots to unbound */
1343 for (i
= 0; i
< n
; i
++)
1344 m
[i
] = SCM_GOOPS_UNBOUND
;
1346 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1348 (scm_t_bits
) m
, 0, 0);
1351 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1352 (SCM
class, SCM initargs
),
1353 "Create a new instance of class @var{class} and initialize it\n"
1354 "from the arguments @var{initargs}.")
1355 #define FUNC_NAME s_scm_sys_allocate_instance
1360 SCM_VALIDATE_CLASS (1, class);
1362 /* Most instances */
1363 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1365 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1366 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1367 return wrap_init (class, m
, n
);
1370 /* Foreign objects */
1371 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1372 return scm_make_foreign_object (class, initargs
);
1374 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1377 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1379 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1381 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1382 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1383 /* Generic functions */
1384 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1386 SCM gf
= wrap_init (class, m
, n
);
1387 clear_method_cache (gf
);
1391 return wrap_init (class, m
, n
);
1395 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1399 /* allocate class object */
1400 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1402 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1403 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1404 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1406 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1407 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1408 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1409 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1414 /* Non-light instances */
1416 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1417 return wrap_init (class, m
, n
);
1422 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1423 (SCM obj
, SCM setter
),
1425 #define FUNC_NAME s_scm_sys_set_object_setter_x
1427 SCM_ASSERT (SCM_STRUCTP (obj
)
1428 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1429 || SCM_I_ENTITYP (obj
)),
1433 if (SCM_I_ENTITYP (obj
))
1434 SCM_SET_ENTITY_SETTER (obj
, setter
);
1436 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1437 return SCM_UNSPECIFIED
;
1441 /******************************************************************************
1443 * %modify-instance (used by change-class to modify in place)
1445 ******************************************************************************/
1447 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1450 #define FUNC_NAME s_scm_sys_modify_instance
1452 SCM_VALIDATE_INSTANCE (1, old
);
1453 SCM_VALIDATE_INSTANCE (2, new);
1455 /* Exchange the data contained in old and new. We exchange rather than
1456 * scratch the old value with new to be correct with GC.
1457 * See "Class redefinition protocol above".
1461 SCM car
= SCM_CAR (old
);
1462 SCM cdr
= SCM_CDR (old
);
1463 SCM_SETCAR (old
, SCM_CAR (new));
1464 SCM_SETCDR (old
, SCM_CDR (new));
1465 SCM_SETCAR (new, car
);
1466 SCM_SETCDR (new, cdr
);
1469 return SCM_UNSPECIFIED
;
1473 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1476 #define FUNC_NAME s_scm_sys_modify_class
1478 SCM_VALIDATE_CLASS (1, old
);
1479 SCM_VALIDATE_CLASS (2, new);
1483 SCM car
= SCM_CAR (old
);
1484 SCM cdr
= SCM_CDR (old
);
1485 SCM_SETCAR (old
, SCM_CAR (new));
1486 SCM_SETCDR (old
, SCM_CDR (new));
1487 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1488 SCM_SETCAR (new, car
);
1489 SCM_SETCDR (new, cdr
);
1490 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1493 return SCM_UNSPECIFIED
;
1497 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1500 #define FUNC_NAME s_scm_sys_invalidate_class
1502 SCM_VALIDATE_CLASS (1, class);
1503 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1504 return SCM_UNSPECIFIED
;
1508 /* When instances change class, they finally get a new body, but
1509 * before that, they go through purgatory in hell. Odd as it may
1510 * seem, this data structure saves us from eternal suffering in
1511 * infinite recursions.
1514 static scm_t_bits
**hell
;
1515 static long n_hell
= 1; /* one place for the evil one himself */
1516 static long hell_size
= 4;
1517 static SCM hell_mutex
;
1523 for (i
= 1; i
< n_hell
; ++i
)
1524 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1530 go_to_hell (void *o
)
1532 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1533 scm_lock_mutex (hell_mutex
);
1534 if (n_hell
== hell_size
)
1536 long new_size
= 2 * hell_size
;
1537 hell
= scm_realloc (hell
, new_size
);
1538 hell_size
= new_size
;
1540 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1541 scm_unlock_mutex (hell_mutex
);
1545 go_to_heaven (void *o
)
1547 scm_lock_mutex (hell_mutex
);
1548 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1549 scm_unlock_mutex (hell_mutex
);
1553 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1556 purgatory (void *args
)
1558 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1559 SCM_PACK ((scm_t_bits
) args
));
1562 /* This function calls the generic function change-class for all
1563 * instances which aren't currently undergoing class change.
1567 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1570 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1571 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1572 (void *) SCM_UNPACK (obj
));
1575 /******************************************************************************
1581 * GGG E N E R I C F U N C T I O N S
1583 * This implementation provides
1584 * - generic functions (with class specializers)
1587 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1589 ******************************************************************************/
1591 SCM_KEYWORD (k_name
, "name");
1593 SCM_SYMBOL (sym_no_method
, "no-method");
1595 static SCM list_of_no_method
;
1597 SCM_SYMBOL (scm_sym_args
, "args");
1600 scm_make_method_cache (SCM gf
)
1602 return scm_list_5 (SCM_IM_DISPATCH
,
1605 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1611 clear_method_cache (SCM gf
)
1613 SCM cache
= scm_make_method_cache (gf
);
1614 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1615 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1618 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1621 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1624 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1625 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1626 if (!SCM_FALSEP (used_by
))
1628 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1629 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1630 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1631 clear_method_cache (gf
);
1632 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1633 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1636 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1637 /* The sign of n is a flag indicating rest args. */
1638 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1640 return SCM_UNSPECIFIED
;
1644 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1647 #define FUNC_NAME s_scm_generic_capability_p
1649 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1650 proc
, SCM_ARG1
, FUNC_NAME
);
1651 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1657 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1660 #define FUNC_NAME s_scm_enable_primitive_generic_x
1662 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1663 while (!SCM_NULLP (subrs
))
1665 SCM subr
= SCM_CAR (subrs
);
1666 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1667 subr
, SCM_ARGn
, FUNC_NAME
);
1668 *SCM_SUBR_GENERIC (subr
)
1669 = scm_make (scm_list_3 (scm_class_generic
,
1672 subrs
= SCM_CDR (subrs
);
1674 return SCM_UNSPECIFIED
;
1678 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1681 #define FUNC_NAME s_scm_primitive_generic_generic
1683 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1685 if (!*SCM_SUBR_GENERIC (subr
))
1686 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1687 return *SCM_SUBR_GENERIC (subr
);
1689 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1693 typedef struct t_extension
{
1694 struct t_extension
*next
;
1699 static t_extension
*extensions
= 0;
1701 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1704 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1709 if (!*SCM_SUBR_GENERIC (extended
))
1710 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1711 gf
= *SCM_SUBR_GENERIC (extended
);
1712 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1714 SCM_SNAME (extension
));
1715 *SCM_SUBR_GENERIC (extension
) = gext
;
1719 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1720 t_extension
**loc
= &extensions
;
1721 /* Make sure that extensions are placed before their own
1722 * extensions in the extensions list. O(N^2) algorithm, but
1723 * extensions of primitive generics are rare.
1725 while (*loc
&& extension
!= (*loc
)->extended
)
1726 loc
= &(*loc
)->next
;
1728 e
->extended
= extended
;
1729 e
->extension
= extension
;
1735 setup_extended_primitive_generics ()
1739 t_extension
*e
= extensions
;
1740 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1741 extensions
= e
->next
;
1746 /******************************************************************************
1748 * Protocol for calling a generic fumction
1749 * This protocol is roughly equivalent to (parameter are a little bit different
1750 * for efficiency reasons):
1752 * + apply-generic (gf args)
1753 * + compute-applicable-methods (gf args ...)
1754 * + sort-applicable-methods (methods args)
1755 * + apply-methods (gf methods args)
1757 * apply-methods calls make-next-method to build the "continuation" of a a
1758 * method. Applying a next-method will call apply-next-method which in
1759 * turn will call apply again to call effectively the following method.
1761 ******************************************************************************/
1764 applicablep (SCM actual
, SCM formal
)
1766 /* We already know that the cpl is well formed. */
1767 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1771 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1773 register SCM s1
, s2
;
1777 * m1 and m2 can have != length (i.e. one can be one element longer than the
1778 * other when we have a dotted parameter list). For instance, with the call
1781 * (define-method M (a . l) ....)
1782 * (define-method M (a) ....)
1784 * we consider that the second method is more specific.
1786 * BTW, targs is an array of types. We don't need it's size since
1787 * we already know that m1 and m2 are applicable (no risk to go past
1788 * the end of this array).
1791 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1792 if (SCM_NULLP(s1
)) return 1;
1793 if (SCM_NULLP(s2
)) return 0;
1794 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1795 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1797 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1798 if (cs1
== SCM_CAR(l
))
1800 if (cs2
== SCM_CAR(l
))
1803 return 0;/* should not occur! */
1806 return 0; /* should not occur! */
1809 #define BUFFSIZE 32 /* big enough for most uses */
1812 scm_i_vector2list (SCM l
, long len
)
1815 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1817 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1818 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1824 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1827 SCM
*v
, vector
= SCM_EOL
;
1828 SCM buffer
[BUFFSIZE
];
1829 SCM save
= method_list
;
1831 /* For reasonably sized method_lists we can try to avoid all the
1832 * consing and reorder the list in place...
1833 * This idea is due to David McClain <Dave_McClain@msn.com>
1835 if (size
<= BUFFSIZE
)
1837 for (i
= 0; i
< size
; i
++)
1839 buffer
[i
] = SCM_CAR (method_list
);
1840 method_list
= SCM_CDR (method_list
);
1846 /* Too many elements in method_list to keep everything locally */
1847 vector
= scm_i_vector2list (save
, size
);
1850 This is a new vector. Don't worry about the write barrier.
1851 We're not allocating elements in this routine, so this should
1854 v
= SCM_WRITABLE_VELTS (vector
);
1857 /* Use a simple shell sort since it is generally faster than qsort on
1858 * small vectors (which is probably mostly the case when we have to
1859 * sort a list of applicable methods).
1861 for (incr
= size
/ 2; incr
; incr
/= 2)
1863 for (i
= incr
; i
< size
; i
++)
1865 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1867 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1871 SCM tmp
= v
[j
+ incr
];
1879 if (size
<= BUFFSIZE
)
1881 /* We did it in locally, so restore the original list (reordered) in-place */
1882 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1884 SCM_SETCAR (method_list
, *v
);
1885 method_list
= SCM_CDR (method_list
);
1889 /* If we are here, that's that we did it the hard way... */
1890 return scm_vector_to_list (vector
);
1894 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1898 SCM l
, fl
, applicable
= SCM_EOL
;
1900 SCM buffer
[BUFFSIZE
];
1905 /* Build the list of arguments types */
1906 if (len
>= BUFFSIZE
) {
1907 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1908 /* NOTE: Using pointers to malloced memory won't work if we
1909 1. have preemtive threading, and,
1910 2. have a GC which moves objects. */
1911 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1914 note that we don't have to work to reset the generation
1915 count. TMP is a new vector anyway, and it is found
1922 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1923 *p
++ = scm_class_of (SCM_CAR (args
));
1925 /* Build a list of all applicable methods */
1926 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1928 fl
= SPEC_OF (SCM_CAR (l
));
1929 /* Only accept accessors which match exactly in first arg. */
1930 if (SCM_ACCESSORP (SCM_CAR (l
))
1931 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1933 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1935 if (SCM_INSTANCEP (fl
)
1936 /* We have a dotted argument list */
1937 || (i
>= len
&& SCM_NULLP (fl
)))
1938 { /* both list exhausted */
1939 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1945 || !applicablep (types
[i
], SCM_CAR (fl
)))
1954 CALL_GF2 ("no-applicable-method", gf
, save
);
1955 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1959 scm_remember_upto_here_1 (tmp
);
1962 : sort_applicable_methods (applicable
, count
, types
));
1966 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1969 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1972 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1973 #define FUNC_NAME s_sys_compute_applicable_methods
1976 SCM_VALIDATE_GENERIC (1, gf
);
1977 n
= scm_ilength (args
);
1978 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1979 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1983 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1984 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
));
1986 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1989 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1990 #define FUNC_NAME s_atslot_ref
1992 SCM x
= SCM_CDR (xorig
);
1993 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1994 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1995 return scm_cons (SCM_IM_SLOT_REF
, x
);
2000 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
2003 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
2004 #define FUNC_NAME s_atslot_set_x
2006 SCM x
= SCM_CDR (xorig
);
2007 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
2008 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
2009 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
2014 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
2016 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
2019 scm_m_atdispatch (SCM xorig
, SCM env
)
2020 #define FUNC_NAME s_atdispatch
2022 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
2023 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
2025 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
2026 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
2028 n
= SCM_XEVALCAR (x
, env
);
2029 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
2030 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
2032 v
= SCM_XEVALCAR (x
, env
);
2033 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
2035 gf
= SCM_XEVALCAR (x
, env
);
2036 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
2037 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
2043 lock_cache_mutex (void *m
)
2045 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2046 scm_lock_mutex (mutex
);
2050 unlock_cache_mutex (void *m
)
2052 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2053 scm_unlock_mutex (mutex
);
2057 call_memoize_method (void *a
)
2059 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2060 SCM gf
= SCM_CAR (args
);
2061 SCM x
= SCM_CADR (args
);
2062 /* First check if another thread has inserted a method between
2063 * the cache miss and locking the mutex.
2065 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2066 if (!SCM_FALSEP (cmethod
))
2068 /*fixme* Use scm_apply */
2069 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2073 scm_memoize_method (SCM x
, SCM args
)
2075 SCM gf
= SCM_CAR (scm_last_pair (x
));
2076 return scm_internal_dynamic_wind (
2078 call_memoize_method
,
2080 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2081 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2084 /******************************************************************************
2086 * A simple make (which will be redefined later in Scheme)
2087 * This version handles only creation of gf, methods and classes (no instances)
2089 * Since this code will disappear when Goops will be fully booted,
2090 * no precaution is taken to be efficient.
2092 ******************************************************************************/
2094 SCM_KEYWORD (k_setter
, "setter");
2095 SCM_KEYWORD (k_specializers
, "specializers");
2096 SCM_KEYWORD (k_procedure
, "procedure");
2097 SCM_KEYWORD (k_dsupers
, "dsupers");
2098 SCM_KEYWORD (k_slots
, "slots");
2099 SCM_KEYWORD (k_gf
, "generic-function");
2101 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2103 "Make a new object. @var{args} must contain the class and\n"
2104 "all necessary initialization information.")
2105 #define FUNC_NAME s_scm_make
2108 long len
= scm_ilength (args
);
2110 if (len
<= 0 || (len
& 1) == 0)
2111 SCM_WRONG_NUM_ARGS ();
2113 class = SCM_CAR(args
);
2114 args
= SCM_CDR(args
);
2116 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
2118 z
= scm_make_struct (class, SCM_INUM0
,
2119 scm_list_5 (SCM_EOL
,
2124 scm_set_procedure_property_x (z
, scm_sym_name
,
2125 scm_get_keyword (k_name
,
2128 clear_method_cache (z
);
2129 if (class == scm_class_generic_with_setter
)
2131 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2132 if (!SCM_FALSEP (setter
))
2133 scm_sys_set_object_setter_x (z
, setter
);
2138 z
= scm_sys_allocate_instance (class, args
);
2140 if (class == scm_class_method
2141 || class == scm_class_simple_method
2142 || class == scm_class_accessor
)
2144 SCM_SET_SLOT (z
, scm_si_generic_function
,
2145 scm_i_get_keyword (k_gf
,
2150 SCM_SET_SLOT (z
, scm_si_specializers
,
2151 scm_i_get_keyword (k_specializers
,
2156 SCM_SET_SLOT (z
, scm_si_procedure
,
2157 scm_i_get_keyword (k_procedure
,
2162 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2166 /* In all the others case, make a new class .... No instance here */
2167 SCM_SET_SLOT (z
, scm_si_name
,
2168 scm_i_get_keyword (k_name
,
2171 scm_str2symbol ("???"),
2173 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2174 scm_i_get_keyword (k_dsupers
,
2179 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2180 scm_i_get_keyword (k_slots
,
2191 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2194 #define FUNC_NAME s_scm_find_method
2197 long len
= scm_ilength (l
);
2200 SCM_WRONG_NUM_ARGS ();
2202 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2203 SCM_VALIDATE_GENERIC (1, gf
);
2204 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2205 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2207 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2211 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2212 (SCM m1
, SCM m2
, SCM targs
),
2214 #define FUNC_NAME s_scm_sys_method_more_specific_p
2219 SCM_VALIDATE_METHOD (1, m1
);
2220 SCM_VALIDATE_METHOD (2, m2
);
2221 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2223 /* Verify that all the arguments of targs are classes and place them in a vector*/
2224 v
= scm_c_make_vector (len
, SCM_EOL
);
2226 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2227 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2228 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2230 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2236 /******************************************************************************
2240 ******************************************************************************/
2244 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2246 SCM tmp
= scm_str2symbol (name
);
2248 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2252 : scm_list_1 (super
),
2258 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2261 create_standard_classes (void)
2264 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2265 scm_str2symbol ("specializers"),
2267 scm_str2symbol ("code-table"));
2268 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2270 k_slot_definition
));
2271 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2272 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2273 scm_list_3 (scm_str2symbol ("n-specialized"),
2276 scm_list_3 (scm_str2symbol ("used-by"),
2279 scm_list_3 (scm_str2symbol ("cache-mutex"),
2281 scm_closure (scm_list_2 (SCM_EOL
,
2284 scm_list_3 (scm_str2symbol ("extended-by"),
2287 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2290 /* Foreign class slot classes */
2291 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2292 scm_class_class
, scm_class_top
, SCM_EOL
);
2293 make_stdcls (&scm_class_protected
, "<protected-slot>",
2294 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2295 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2296 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2297 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2298 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2299 make_stdcls (&scm_class_self
, "<self-slot>",
2301 scm_list_2 (scm_class_foreign_slot
, scm_class_read_only
),
2303 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2305 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2307 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2309 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2311 make_stdcls (&scm_class_scm
, "<scm-slot>",
2312 scm_class_class
, scm_class_protected
, SCM_EOL
);
2313 make_stdcls (&scm_class_int
, "<int-slot>",
2314 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2315 make_stdcls (&scm_class_float
, "<float-slot>",
2316 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2317 make_stdcls (&scm_class_double
, "<double-slot>",
2318 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2320 /* Continue initialization of class <class> */
2322 slots
= build_class_class_slots ();
2323 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2324 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2325 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2326 compute_getters_n_setters (slots
));
2328 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2329 scm_class_class
, scm_class_class
,
2330 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2333 scm_list_3 (scm_str2symbol ("destructor"),
2335 scm_class_opaque
)));
2336 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2337 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2338 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2340 /* scm_class_generic functions classes */
2341 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2342 scm_class_class
, scm_class_class
, SCM_EOL
);
2343 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2344 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2345 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2346 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2347 make_stdcls (&scm_class_operator_with_setter_class
,
2348 "<operator-with-setter-class>",
2349 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2350 make_stdcls (&scm_class_method
, "<method>",
2351 scm_class_class
, scm_class_object
, method_slots
);
2352 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2353 scm_class_class
, scm_class_method
, SCM_EOL
);
2354 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2355 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2356 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2357 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2358 make_stdcls (&scm_class_entity
, "<entity>",
2359 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2360 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2361 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2362 make_stdcls (&scm_class_generic
, "<generic>",
2363 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2364 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2365 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2366 scm_class_entity_class
,
2367 scm_list_1 (scm_class_generic
),
2369 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2370 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2371 scm_class_entity_class
,
2372 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2374 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2375 make_stdcls (&scm_class_extended_generic_with_setter
,
2376 "<extended-generic-with-setter>",
2377 scm_class_entity_class
,
2378 scm_list_2 (scm_class_extended_generic
,
2379 scm_class_entity_with_setter
),
2381 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2382 SCM_CLASSF_PURE_GENERIC
);
2384 /* Primitive types classes */
2385 make_stdcls (&scm_class_boolean
, "<boolean>",
2386 scm_class_class
, scm_class_top
, SCM_EOL
);
2387 make_stdcls (&scm_class_char
, "<char>",
2388 scm_class_class
, scm_class_top
, SCM_EOL
);
2389 make_stdcls (&scm_class_list
, "<list>",
2390 scm_class_class
, scm_class_top
, SCM_EOL
);
2391 make_stdcls (&scm_class_pair
, "<pair>",
2392 scm_class_class
, scm_class_list
, SCM_EOL
);
2393 make_stdcls (&scm_class_null
, "<null>",
2394 scm_class_class
, scm_class_list
, SCM_EOL
);
2395 make_stdcls (&scm_class_string
, "<string>",
2396 scm_class_class
, scm_class_top
, SCM_EOL
);
2397 make_stdcls (&scm_class_symbol
, "<symbol>",
2398 scm_class_class
, scm_class_top
, SCM_EOL
);
2399 make_stdcls (&scm_class_vector
, "<vector>",
2400 scm_class_class
, scm_class_top
, SCM_EOL
);
2401 make_stdcls (&scm_class_number
, "<number>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_complex
, "<complex>",
2404 scm_class_class
, scm_class_number
, SCM_EOL
);
2405 make_stdcls (&scm_class_real
, "<real>",
2406 scm_class_class
, scm_class_complex
, SCM_EOL
);
2407 make_stdcls (&scm_class_integer
, "<integer>",
2408 scm_class_class
, scm_class_real
, SCM_EOL
);
2409 make_stdcls (&scm_class_keyword
, "<keyword>",
2410 scm_class_class
, scm_class_top
, SCM_EOL
);
2411 make_stdcls (&scm_class_unknown
, "<unknown>",
2412 scm_class_class
, scm_class_top
, SCM_EOL
);
2413 make_stdcls (&scm_class_procedure
, "<procedure>",
2414 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2415 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2416 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2417 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2418 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2419 make_stdcls (&scm_class_port
, "<port>",
2420 scm_class_class
, scm_class_top
, SCM_EOL
);
2421 make_stdcls (&scm_class_input_port
, "<input-port>",
2422 scm_class_class
, scm_class_port
, SCM_EOL
);
2423 make_stdcls (&scm_class_output_port
, "<output-port>",
2424 scm_class_class
, scm_class_port
, SCM_EOL
);
2425 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2427 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2431 /**********************************************************************
2435 **********************************************************************/
2438 make_class_from_template (char *template, char *type_name
, SCM supers
)
2444 sprintf (buffer
, template, type_name
);
2445 name
= scm_str2symbol (buffer
);
2448 name
= SCM_GOOPS_UNBOUND
;
2450 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2455 /* Only define name if doesn't already exist. */
2456 if (!SCM_GOOPS_UNBOUNDP (name
)
2457 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2458 DEFVAR (name
, class);
2463 scm_make_extended_class (char *type_name
)
2465 return make_class_from_template ("<%s>",
2467 scm_list_1 (scm_class_top
));
2471 create_smob_classes (void)
2475 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2476 for (i
= 0; i
< 255; ++i
)
2477 scm_smob_class
[i
] = 0;
2479 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2480 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2481 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2482 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2484 for (i
= 0; i
< scm_numsmob
; ++i
)
2485 if (!scm_smob_class
[i
])
2486 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2490 scm_make_port_classes (long ptobnum
, char *type_name
)
2492 SCM c
, class = make_class_from_template ("<%s-port>",
2494 scm_list_1 (scm_class_port
));
2495 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2496 = make_class_from_template ("<%s-input-port>",
2498 scm_list_2 (class, scm_class_input_port
));
2499 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2500 = make_class_from_template ("<%s-output-port>",
2502 scm_list_2 (class, scm_class_output_port
));
2503 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2505 = make_class_from_template ("<%s-input-output-port>",
2507 scm_list_2 (class, scm_class_input_output_port
));
2508 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2509 SCM_SET_SLOT (c
, scm_si_cpl
,
2510 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2514 create_port_classes (void)
2518 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2519 for (i
= 0; i
< 3 * 256; ++i
)
2520 scm_port_class
[i
] = 0;
2522 for (i
= 0; i
< scm_numptob
; ++i
)
2523 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2527 make_struct_class (void *closure SCM_UNUSED
, SCM key SCM_UNUSED
,
2528 SCM data
, SCM prev SCM_UNUSED
)
2530 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2531 SCM_SET_STRUCT_TABLE_CLASS (data
,
2532 scm_make_extended_class
2533 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2534 return SCM_UNSPECIFIED
;
2538 create_struct_classes (void)
2540 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2543 /**********************************************************************
2547 **********************************************************************/
2552 if (!goops_loaded_p
)
2553 scm_c_resolve_module ("oop goops");
2558 scm_make_foreign_object (SCM
class, SCM initargs
)
2559 #define FUNC_NAME s_scm_make
2561 void * (*constructor
) (SCM
)
2562 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2563 if (constructor
== 0)
2564 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2565 return scm_wrap_object (class, constructor (initargs
));
2571 scm_free_foreign_object (SCM
*class, SCM
*data
)
2573 size_t (*destructor
) (void *)
2574 = (size_t (*) (void *)) class[scm_si_destructor
];
2575 return destructor (data
);
2579 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2580 void * (*constructor
) (SCM initargs
),
2581 size_t (*destructor
) (void *))
2584 name
= scm_str2symbol (s_name
);
2585 if (SCM_NULLP (supers
))
2586 supers
= scm_list_1 (scm_class_foreign_object
);
2587 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2588 scm_sys_inherit_magic_x (class, supers
);
2590 if (destructor
!= 0)
2592 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2593 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2597 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2598 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2601 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2602 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2607 SCM_SYMBOL (sym_o
, "o");
2608 SCM_SYMBOL (sym_x
, "x");
2610 SCM_KEYWORD (k_accessor
, "accessor");
2611 SCM_KEYWORD (k_getter
, "getter");
2614 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2616 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2621 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2622 SCM (*getter
) (SCM obj
),
2623 SCM (*setter
) (SCM obj
, SCM x
),
2624 char *accessor_name
)
2627 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2628 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2629 setter
? setter
: default_setter
);
2630 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2631 scm_list_2 (get
, sym_o
)),
2633 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2634 scm_list_3 (set
, sym_o
, sym_x
)),
2637 SCM name
= scm_str2symbol (slot_name
);
2638 SCM aname
= scm_str2symbol (accessor_name
);
2639 SCM gf
= scm_ensure_accessor (aname
);
2640 SCM slot
= scm_list_5 (name
,
2643 setter
? k_accessor
: k_getter
,
2645 SCM gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2647 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor
,
2652 scm_add_method (scm_setter (gf
),
2653 scm_make (scm_list_5 (scm_class_accessor
,
2655 scm_list_2 (class, scm_class_top
),
2660 SCM_SET_SLOT (class, scm_si_slots
,
2661 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2662 scm_list_1 (slot
))));
2663 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2664 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2665 scm_list_1 (gns
))));
2669 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2671 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2676 scm_wrap_object (SCM
class, void *data
)
2678 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2686 scm_wrap_component (SCM
class, SCM container
, void *data
)
2688 SCM obj
= scm_wrap_object (class, data
);
2689 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2695 SCM_SETCDR (handle
, container
);
2700 scm_ensure_accessor (SCM name
)
2702 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2703 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2705 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2706 gf
= scm_make (scm_list_5 (scm_class_generic_with_setter
,
2707 k_name
, name
, k_setter
, gf
));
2712 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2715 scm_add_method (SCM gf
, SCM m
)
2717 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2722 * Debugging utilities
2725 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2727 "Return @code{#t} if @var{obj} is a pure generic.")
2728 #define FUNC_NAME s_scm_pure_generic_p
2730 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2734 #endif /* GUILE_DEBUG */
2740 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2742 "Announce that GOOPS is loaded and perform initialization\n"
2743 "on the C level which depends on the loaded GOOPS modules.")
2744 #define FUNC_NAME s_scm_sys_goops_loaded
2747 var_compute_applicable_methods
=
2748 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2750 setup_extended_primitive_generics ();
2751 return SCM_UNSPECIFIED
;
2755 SCM scm_module_goops
;
2758 scm_init_goops_builtins (void)
2760 scm_module_goops
= scm_current_module ();
2761 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2763 /* Not really necessary right now, but who knows...
2765 scm_permanent_object (scm_module_goops
);
2766 scm_permanent_object (scm_goops_lookup_closure
);
2768 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2769 (SCM_MAKINUM (37)));
2771 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2773 #include "libguile/goops.x"
2775 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2777 hell
= scm_malloc (hell_size
);
2778 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2780 create_basic_classes ();
2781 create_standard_classes ();
2782 create_smob_classes ();
2783 create_struct_classes ();
2784 create_port_classes ();
2787 SCM name
= scm_str2symbol ("no-applicable-method");
2788 scm_no_applicable_method
2789 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2792 DEFVAR (name
, scm_no_applicable_method
);
2795 return SCM_UNSPECIFIED
;
2801 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2802 scm_init_goops_builtins
);