1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but 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.
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 02110-1301 USA
20 /* This software is a derivative work of other copyrighted softwares; the
21 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 * This file is based upon stklos.c from the STk distribution by
24 * Erick Gallesio <eg@unice.fr>.
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/chars.h"
38 #include "libguile/debug.h"
39 #include "libguile/dynl.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eval.h"
42 #include "libguile/hashtab.h"
43 #include "libguile/keywords.h"
44 #include "libguile/macros.h"
45 #include "libguile/modules.h"
46 #include "libguile/objects.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/random.h"
50 #include "libguile/root.h"
51 #include "libguile/smob.h"
52 #include "libguile/strings.h"
53 #include "libguile/strports.h"
54 #include "libguile/vectors.h"
55 #include "libguile/weaks.h"
57 #include "libguile/validate.h"
58 #include "libguile/goops.h"
60 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
62 #define DEFVAR(v, val) \
63 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
65 /* Temporary hack until we get the new module system */
66 /*fixme* Should optimize by keeping track of the variable object itself */
67 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
70 /* Fixme: Should use already interned symbols */
72 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
74 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
76 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
78 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
81 /* Class redefinition protocol:
83 A class is represented by a heap header h1 which points to a
84 malloc:ed memory block m1.
86 When a new version of a class is created, a new header h2 and
87 memory block m2 are allocated. The headers h1 and h2 then switch
88 pointers so that h1 refers to m2 and h2 to m1. In this way, names
89 bound to h1 will point to the new class at the same time as h2 will
90 be a handle which the GC will use to free m1.
92 The `redefined' slot of m1 will be set to point to h1. An old
93 instance will have its class pointer (the CAR of the heap header)
94 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
95 the class modification and the new class pointer can be found via
99 /* The following definition is located in libguile/objects.h:
100 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
103 #define TEST_CHANGE_CLASS(obj, class) \
105 class = SCM_CLASS_OF (obj); \
106 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
108 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
109 class = SCM_CLASS_OF (obj); \
113 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
114 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
116 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
117 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
119 static int goops_loaded_p = 0;
120 static scm_t_rstate *goops_rstate;
122 static SCM scm_goops_lookup_closure;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean, scm_class_char, scm_class_pair;
126 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
127 SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
128 SCM scm_class_vector, scm_class_null;
129 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
130 SCM scm_class_unknown;
131 SCM scm_class_top, scm_class_object, scm_class_class;
132 SCM scm_class_applicable;
133 SCM scm_class_entity, scm_class_entity_with_setter;
134 SCM scm_class_generic, scm_class_generic_with_setter;
135 SCM scm_class_accessor;
136 SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
137 SCM scm_class_extended_accessor;
138 SCM scm_class_method;
139 SCM scm_class_simple_method, scm_class_accessor_method;
140 SCM scm_class_procedure_class;
141 SCM scm_class_operator_class, scm_class_operator_with_setter_class;
142 SCM scm_class_entity_class;
143 SCM scm_class_number, scm_class_list;
144 SCM scm_class_keyword;
145 SCM scm_class_port, scm_class_input_output_port;
146 SCM scm_class_input_port, scm_class_output_port;
147 SCM scm_class_foreign_class, scm_class_foreign_object;
148 SCM scm_class_foreign_slot;
149 SCM scm_class_self, scm_class_protected;
150 SCM scm_class_opaque, scm_class_read_only;
151 SCM scm_class_protected_opaque, scm_class_protected_read_only;
153 SCM scm_class_int, scm_class_float, scm_class_double;
155 SCM *scm_port_class = 0;
156 SCM *scm_smob_class = 0;
158 SCM scm_no_applicable_method;
160 SCM_SYMBOL (scm_sym_define_public, "define-public");
162 static SCM scm_make_unbound (void);
163 static SCM scm_unbound_p (SCM obj);
164 static SCM scm_assert_bound (SCM value, SCM obj);
165 static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
166 static SCM scm_sys_goops_loaded (void);
168 /* This function is used for efficient type dispatch. */
169 SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
171 "Return the class of @var{x}.")
172 #define FUNC_NAME s_scm_class_of
174 switch (SCM_ITAG3 (x))
178 return scm_class_integer;
182 return scm_class_char;
183 else if (scm_is_bool (x))
184 return scm_class_boolean;
185 else if (scm_is_null (x))
186 return scm_class_null;
188 return scm_class_unknown;
191 switch (SCM_TYP7 (x))
193 case scm_tcs_cons_nimcar:
194 return scm_class_pair;
195 case scm_tcs_closures:
196 return scm_class_procedure;
198 return scm_class_symbol;
201 return scm_class_vector;
203 return scm_class_string;
205 switch SCM_TYP16 (x) {
207 return scm_class_integer;
209 return scm_class_real;
210 case scm_tc16_complex:
211 return scm_class_complex;
212 case scm_tc16_fraction:
213 return scm_class_fraction;
223 case scm_tc7_subr_1o:
224 case scm_tc7_subr_2o:
225 case scm_tc7_lsubr_2:
227 if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
228 return scm_class_primitive_generic;
230 return scm_class_procedure;
232 return scm_class_procedure;
234 return scm_class_procedure_with_setter;
238 scm_t_bits type = SCM_TYP16 (x);
239 if (type != scm_tc16_port_with_ps)
240 return scm_smob_class[SCM_TC2SMOBNUM (type)];
241 x = SCM_PORT_WITH_PS_PORT (x);
242 /* fall through to ports */
245 return scm_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))];
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)
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);
264 /* ordinary struct */
265 SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
266 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
267 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
270 SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
271 SCM class = scm_make_extended_class (scm_is_true (name)
272 ? scm_i_symbol_chars (name)
274 SCM_I_OPERATORP (x));
275 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
281 return scm_class_pair;
283 return scm_class_unknown;
289 case scm_tc3_closure:
293 return scm_class_unknown;
297 /******************************************************************************
301 * This version doesn't fully handle multiple-inheritance. It serves
302 * only for booting classes and will be overloaded in Scheme
304 ******************************************************************************/
307 map (SCM (*proc) (SCM), SCM ls)
309 if (scm_is_null (ls))
313 SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
316 while (!scm_is_null (ls))
318 SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
330 while (!scm_is_null (ls))
332 SCM el = SCM_CAR (ls);
333 if (scm_is_false (scm_c_memq (el, res)))
334 res = scm_cons (el, res);
341 compute_cpl (SCM class)
344 return CALL_GF1 ("compute-cpl", class);
347 SCM supers = SCM_SLOT (class, scm_si_direct_supers);
348 SCM ls = scm_append (scm_acons (class, supers,
349 map (compute_cpl, supers)));
350 return scm_reverse_x (filter_cpl (ls), SCM_EOL);
354 /******************************************************************************
358 ******************************************************************************/
361 remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
369 if (!scm_is_symbol (tmp))
370 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
372 if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
373 res = scm_cons (SCM_CAR (l), res);
374 slots_already_seen = scm_cons (tmp, slots_already_seen);
377 return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
381 build_slots_list (SCM dslots, SCM cpl)
383 register SCM res = dslots;
385 for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
386 res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
387 scm_si_direct_slots),
390 /* res contains a list of slots. Remove slots which appears more than once */
391 return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
398 while (!scm_is_null (ls))
400 if (!scm_is_pair (SCM_CAR (ls)))
401 SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
408 SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
410 "Return a list consisting of the names of all slots belonging to\n"
411 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
413 #define FUNC_NAME s_scm_sys_compute_slots
415 SCM_VALIDATE_CLASS (1, class);
416 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
417 SCM_SLOT (class, scm_si_cpl));
422 /******************************************************************************
424 * compute-getters-n-setters
426 * This version doesn't handle slot options. It serves only for booting
427 * classes and will be overloaded in Scheme.
429 ******************************************************************************/
431 SCM_KEYWORD (k_init_value, "init-value");
432 SCM_KEYWORD (k_init_thunk, "init-thunk");
435 compute_getters_n_setters (SCM slots)
441 for ( ; !scm_is_null (slots); slots = SCM_CDR (slots))
443 SCM init = SCM_BOOL_F;
444 SCM options = SCM_CDAR (slots);
445 if (!scm_is_null (options))
447 init = scm_get_keyword (k_init_value, options, 0);
450 init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
452 scm_list_2 (scm_sym_quote,
457 init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
459 *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
461 scm_from_int (i++))),
463 cdrloc = SCM_CDRLOC (*cdrloc);
468 /******************************************************************************
472 ******************************************************************************/
474 /*fixme* Manufacture keywords in advance */
476 scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
480 for (i = 0; i != len; i += 2)
482 SCM obj = SCM_CAR (l);
484 if (!scm_is_keyword (obj))
485 scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
486 else if (scm_is_eq (obj, key))
492 return default_value;
496 SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
497 (SCM key, SCM l, SCM default_value),
498 "Determine an associated value for the keyword @var{key} from\n"
499 "the list @var{l}. The list @var{l} has to consist of an even\n"
500 "number of elements, where, starting with the first, every\n"
501 "second element is a keyword, followed by its associated value.\n"
502 "If @var{l} does not hold a value for @var{key}, the value\n"
503 "@var{default_value} is returned.")
504 #define FUNC_NAME s_scm_get_keyword
508 SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
509 len = scm_ilength (l);
510 if (len < 0 || len % 2 == 1)
511 scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
513 return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
518 SCM_KEYWORD (k_init_keyword, "init-keyword");
520 static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
521 static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
523 SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
524 (SCM obj, SCM initargs),
525 "Initialize the object @var{obj} with the given arguments\n"
527 #define FUNC_NAME s_scm_sys_initialize_object
529 SCM tmp, get_n_set, slots;
530 SCM class = SCM_CLASS_OF (obj);
533 SCM_VALIDATE_INSTANCE (1, obj);
534 n_initargs = scm_ilength (initargs);
535 SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
537 get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
538 slots = SCM_SLOT (class, scm_si_slots);
540 /* See for each slot how it must be initialized */
542 !scm_is_null (slots);
543 get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
545 SCM slot_name = SCM_CAR (slots);
548 if (!scm_is_null (SCM_CDR (slot_name)))
550 /* This slot admits (perhaps) to be initialized at creation time */
551 long n = scm_ilength (SCM_CDR (slot_name));
552 if (n & 1) /* odd or -1 */
553 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
554 scm_list_1 (slot_name));
555 tmp = scm_i_get_keyword (k_init_keyword,
560 slot_name = SCM_CAR (slot_name);
563 /* an initarg was provided for this slot */
564 if (!scm_is_keyword (tmp))
565 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
567 slot_value = scm_i_get_keyword (tmp,
576 /* set slot to provided value */
577 set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
580 /* set slot to its :init-form if it exists */
581 tmp = SCM_CADAR (get_n_set);
582 if (scm_is_true (tmp))
584 slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
585 if (SCM_GOOPS_UNBOUNDP (slot_value))
587 SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
588 set_slot_value (class,
591 scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
601 /* NOTE: The following macros are interdependent with code
602 * in goops.scm:compute-getters-n-setters
604 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
605 (SCM_I_INUMP (SCM_CDDR (gns)) \
606 || (scm_is_pair (SCM_CDDR (gns)) \
607 && scm_is_pair (SCM_CDDDR (gns)) \
608 && scm_is_pair (SCM_CDDDDR (gns))))
609 #define SCM_GNS_INDEX(gns) \
610 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 ? SCM_I_INUM (SCM_CDDR (gns)) \
612 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
613 #define SCM_GNS_SIZE(gns) \
614 (SCM_I_INUMP (SCM_CDDR (gns)) \
616 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
618 SCM_KEYWORD (k_class, "class");
619 SCM_KEYWORD (k_allocation, "allocation");
620 SCM_KEYWORD (k_instance, "instance");
622 SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
625 #define FUNC_NAME s_scm_sys_prep_layout_x
627 SCM slots, getters_n_setters, nfields;
628 unsigned long int n, i;
632 SCM_VALIDATE_INSTANCE (1, class);
633 slots = SCM_SLOT (class, scm_si_slots);
634 getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
635 nfields = SCM_SLOT (class, scm_si_nfields);
636 if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
637 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
638 scm_list_1 (nfields));
639 n = 2 * SCM_I_INUM (nfields);
640 if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
641 && SCM_SUBCLASSP (class, scm_class_class))
642 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
643 scm_list_1 (nfields));
645 layout = scm_i_make_string (n, &s);
647 while (scm_is_pair (getters_n_setters))
649 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
652 int len, index, size;
655 if (i >= n || !scm_is_pair (slots))
658 /* extract slot type */
659 len = scm_ilength (SCM_CDAR (slots));
660 type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
661 len, SCM_BOOL_F, FUNC_NAME);
662 /* determine slot GC protection and access mode */
663 if (scm_is_false (type))
670 if (!SCM_CLASSP (type))
671 SCM_MISC_ERROR ("bad slot class", SCM_EOL);
672 else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
674 if (SCM_SUBCLASSP (type, scm_class_self))
676 else if (SCM_SUBCLASSP (type, scm_class_protected))
681 if (SCM_SUBCLASSP (type, scm_class_opaque))
683 else if (SCM_SUBCLASSP (type, scm_class_read_only))
695 index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
696 if (index != (i >> 1))
698 size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
706 slots = SCM_CDR (slots);
707 getters_n_setters = SCM_CDR (getters_n_setters);
709 if (!scm_is_null (slots))
712 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
714 SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
715 return SCM_UNSPECIFIED;
719 static void prep_hashsets (SCM);
721 SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
722 (SCM class, SCM dsupers),
724 #define FUNC_NAME s_scm_sys_inherit_magic_x
728 SCM_VALIDATE_INSTANCE (1, class);
729 while (!scm_is_null (ls))
731 SCM_ASSERT (scm_is_pair (ls)
732 && SCM_INSTANCEP (SCM_CAR (ls)),
736 flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
739 flags &= SCM_CLASSF_INHERIT;
740 if (flags & SCM_CLASSF_ENTITY)
741 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
744 long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
747 * We could avoid calling scm_gc_malloc in the allocation code
748 * (in which case the following two lines are needed). Instead
749 * we make 0-slot instances non-light, so that the light case
750 * can be handled without special cases.
753 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
755 if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
757 /* NOTE: The following depends on scm_struct_i_size. */
758 flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */
759 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
762 SCM_SET_CLASS_FLAGS (class, flags);
764 prep_hashsets (class);
766 return SCM_UNSPECIFIED;
771 prep_hashsets (SCM class)
775 for (i = 0; i < 7; ++i)
776 SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
779 /******************************************************************************/
782 scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
784 SCM z, cpl, slots, nfields, g_n_s;
786 /* Allocate one instance */
787 z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
789 /* Initialize its slots */
790 SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
791 cpl = compute_cpl (z);
792 slots = build_slots_list (maplist (dslots), cpl);
793 nfields = scm_from_int (scm_ilength (slots));
794 g_n_s = compute_getters_n_setters (slots);
796 SCM_SET_SLOT (z, scm_si_name, name);
797 SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
798 SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
799 SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
800 SCM_SET_SLOT (z, scm_si_cpl, cpl);
801 SCM_SET_SLOT (z, scm_si_slots, slots);
802 SCM_SET_SLOT (z, scm_si_nfields, nfields);
803 SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
804 SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
805 SCM_SET_SLOT (z, scm_si_environment,
806 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
808 /* Add this class in the direct-subclasses slot of dsupers */
811 for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp))
812 SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
813 scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
814 scm_si_direct_subclasses)));
817 /* Support for the underlying structs: */
818 SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
819 ? (SCM_CLASSF_GOOPS_OR_VALID
820 | SCM_CLASSF_OPERATOR
822 : class == scm_class_operator_class
823 ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR
824 : SCM_CLASSF_GOOPS_OR_VALID));
829 scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
831 SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
832 scm_sys_inherit_magic_x (z, dsupers);
833 scm_sys_prep_layout_x (z);
837 /******************************************************************************/
839 SCM_SYMBOL (sym_layout, "layout");
840 SCM_SYMBOL (sym_vcell, "vcell");
841 SCM_SYMBOL (sym_vtable, "vtable");
842 SCM_SYMBOL (sym_print, "print");
843 SCM_SYMBOL (sym_procedure, "procedure");
844 SCM_SYMBOL (sym_setter, "setter");
845 SCM_SYMBOL (sym_redefined, "redefined");
846 SCM_SYMBOL (sym_h0, "h0");
847 SCM_SYMBOL (sym_h1, "h1");
848 SCM_SYMBOL (sym_h2, "h2");
849 SCM_SYMBOL (sym_h3, "h3");
850 SCM_SYMBOL (sym_h4, "h4");
851 SCM_SYMBOL (sym_h5, "h5");
852 SCM_SYMBOL (sym_h6, "h6");
853 SCM_SYMBOL (sym_h7, "h7");
854 SCM_SYMBOL (sym_name, "name");
855 SCM_SYMBOL (sym_direct_supers, "direct-supers");
856 SCM_SYMBOL (sym_direct_slots, "direct-slots");
857 SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
858 SCM_SYMBOL (sym_direct_methods, "direct-methods");
859 SCM_SYMBOL (sym_cpl, "cpl");
860 SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
861 SCM_SYMBOL (sym_slots, "slots");
862 SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
863 SCM_SYMBOL (sym_keyword_access, "keyword-access");
864 SCM_SYMBOL (sym_nfields, "nfields");
865 SCM_SYMBOL (sym_environment, "environment");
869 build_class_class_slots ()
872 scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
873 scm_list_3 (sym_vtable, k_class, scm_class_self),
874 scm_list_1 (sym_print),
875 scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
876 scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
877 scm_list_1 (sym_redefined),
878 scm_list_3 (sym_h0, k_class, scm_class_int),
879 scm_list_3 (sym_h1, k_class, scm_class_int),
880 scm_list_3 (sym_h2, k_class, scm_class_int),
881 scm_list_3 (sym_h3, k_class, scm_class_int),
882 scm_list_3 (sym_h4, k_class, scm_class_int),
883 scm_list_3 (sym_h5, k_class, scm_class_int),
884 scm_list_3 (sym_h6, k_class, scm_class_int),
885 scm_list_3 (sym_h7, k_class, scm_class_int),
886 scm_list_1 (sym_name),
887 scm_list_1 (sym_direct_supers),
888 scm_list_1 (sym_direct_slots),
889 scm_list_1 (sym_direct_subclasses),
890 scm_list_1 (sym_direct_methods),
891 scm_list_1 (sym_cpl),
892 scm_list_1 (sym_default_slot_definition_class),
893 scm_list_1 (sym_slots),
894 scm_list_1 (sym_getters_n_setters),
895 scm_list_1 (sym_keyword_access),
896 scm_list_1 (sym_nfields),
897 scm_list_1 (sym_environment),
902 create_basic_classes (void)
904 /* SCM slots_of_class = build_class_class_slots (); */
906 /**** <scm_class_class> ****/
907 SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
908 + 2 * scm_vtable_offset_user);
909 SCM name = scm_from_locale_symbol ("<class>");
910 scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
913 SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
914 | SCM_CLASSF_METACLASS));
916 SCM_SET_SLOT (scm_class_class, scm_si_name, name);
917 SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
918 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
919 SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
920 SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
921 SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
922 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
923 SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
924 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
925 compute_getters_n_setters (slots_of_class)); */
926 SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
927 SCM_SET_SLOT (scm_class_class, scm_si_environment,
928 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
930 prep_hashsets (scm_class_class);
932 DEFVAR(name, scm_class_class);
934 /**** <scm_class_top> ****/
935 name = scm_from_locale_symbol ("<top>");
936 scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
941 DEFVAR(name, scm_class_top);
943 /**** <scm_class_object> ****/
944 name = scm_from_locale_symbol ("<object>");
945 scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
947 scm_list_1 (scm_class_top),
950 DEFVAR (name, scm_class_object);
952 /* <top> <object> and <class> were partially initialized. Correct them here */
953 SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
955 SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object));
956 SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top));
959 /******************************************************************************/
961 SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
963 "Return @code{#t} if @var{obj} is an instance.")
964 #define FUNC_NAME s_scm_instance_p
966 return scm_from_bool (SCM_INSTANCEP (obj));
971 /******************************************************************************
973 * Meta object accessors
975 ******************************************************************************/
976 SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
978 "Return the class name of @var{obj}.")
979 #define FUNC_NAME s_scm_class_name
981 SCM_VALIDATE_CLASS (1, obj);
982 return scm_slot_ref (obj, sym_name);
986 SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
988 "Return the direct superclasses of the class @var{obj}.")
989 #define FUNC_NAME s_scm_class_direct_supers
991 SCM_VALIDATE_CLASS (1, obj);
992 return scm_slot_ref (obj, sym_direct_supers);
996 SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
998 "Return the direct slots of the class @var{obj}.")
999 #define FUNC_NAME s_scm_class_direct_slots
1001 SCM_VALIDATE_CLASS (1, obj);
1002 return scm_slot_ref (obj, sym_direct_slots);
1006 SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
1008 "Return the direct subclasses of the class @var{obj}.")
1009 #define FUNC_NAME s_scm_class_direct_subclasses
1011 SCM_VALIDATE_CLASS (1, obj);
1012 return scm_slot_ref(obj, sym_direct_subclasses);
1016 SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
1018 "Return the direct methods of the class @var{obj}")
1019 #define FUNC_NAME s_scm_class_direct_methods
1021 SCM_VALIDATE_CLASS (1, obj);
1022 return scm_slot_ref (obj, sym_direct_methods);
1026 SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
1028 "Return the class precedence list of the class @var{obj}.")
1029 #define FUNC_NAME s_scm_class_precedence_list
1031 SCM_VALIDATE_CLASS (1, obj);
1032 return scm_slot_ref (obj, sym_cpl);
1036 SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
1038 "Return the slot list of the class @var{obj}.")
1039 #define FUNC_NAME s_scm_class_slots
1041 SCM_VALIDATE_CLASS (1, obj);
1042 return scm_slot_ref (obj, sym_slots);
1046 SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
1048 "Return the environment of the class @var{obj}.")
1049 #define FUNC_NAME s_scm_class_environment
1051 SCM_VALIDATE_CLASS (1, obj);
1052 return scm_slot_ref(obj, sym_environment);
1057 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
1059 "Return the name of the generic function @var{obj}.")
1060 #define FUNC_NAME s_scm_generic_function_name
1062 SCM_VALIDATE_GENERIC (1, obj);
1063 return scm_procedure_property (obj, scm_sym_name);
1067 SCM_SYMBOL (sym_methods, "methods");
1068 SCM_SYMBOL (sym_extended_by, "extended-by");
1069 SCM_SYMBOL (sym_extends, "extends");
1072 SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
1074 SCM gfs = scm_slot_ref (gf, sym_extended_by);
1075 method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
1076 while (!scm_is_null (gfs))
1078 method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
1079 gfs = SCM_CDR (gfs);
1081 return method_lists;
1085 SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
1087 if (SCM_IS_A_P (gf, scm_class_extended_generic))
1089 SCM gfs = scm_slot_ref (gf, sym_extends);
1090 while (!scm_is_null (gfs))
1092 SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
1093 method_lists = fold_upward_gf_methods (scm_cons (methods,
1096 gfs = SCM_CDR (gfs);
1099 return method_lists;
1102 SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
1104 "Return the methods of the generic function @var{obj}.")
1105 #define FUNC_NAME s_scm_generic_function_methods
1108 SCM_VALIDATE_GENERIC (1, obj);
1109 methods = fold_upward_gf_methods (SCM_EOL, obj);
1110 methods = fold_downward_gf_methods (methods, obj);
1111 return scm_append (methods);
1115 SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
1117 "Return the generic function for the method @var{obj}.")
1118 #define FUNC_NAME s_scm_method_generic_function
1120 SCM_VALIDATE_METHOD (1, obj);
1121 return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
1125 SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
1127 "Return specializers of the method @var{obj}.")
1128 #define FUNC_NAME s_scm_method_specializers
1130 SCM_VALIDATE_METHOD (1, obj);
1131 return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
1135 SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
1137 "Return the procedure of the method @var{obj}.")
1138 #define FUNC_NAME s_scm_method_procedure
1140 SCM_VALIDATE_METHOD (1, obj);
1141 return scm_slot_ref (obj, sym_procedure);
1145 SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
1147 "Return the slot definition of the accessor @var{obj}.")
1148 #define FUNC_NAME s_scm_accessor_method_slot_definition
1150 SCM_VALIDATE_ACCESSOR (1, obj);
1151 return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
1155 SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0,
1157 "Internal GOOPS magic---don't use this function!")
1158 #define FUNC_NAME s_scm_sys_tag_body
1160 return scm_cons (SCM_IM_LAMBDA, body);
1164 /******************************************************************************
1166 * S l o t a c c e s s
1168 ******************************************************************************/
1170 SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
1172 "Return the unbound value.")
1173 #define FUNC_NAME s_scm_make_unbound
1175 return SCM_GOOPS_UNBOUND;
1179 SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
1181 "Return @code{#t} if @var{obj} is unbound.")
1182 #define FUNC_NAME s_scm_unbound_p
1184 return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
1188 SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
1189 (SCM value, SCM obj),
1190 "Return @var{value} if it is bound, and invoke the\n"
1191 "@var{slot-unbound} method of @var{obj} if it is not.")
1192 #define FUNC_NAME s_scm_assert_bound
1194 if (SCM_GOOPS_UNBOUNDP (value))
1195 return CALL_GF1 ("slot-unbound", obj);
1200 SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
1201 (SCM obj, SCM index),
1202 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1203 "the value from @var{obj}.")
1204 #define FUNC_NAME s_scm_at_assert_bound_ref
1206 SCM value = SCM_SLOT (obj, scm_to_int (index));
1207 if (SCM_GOOPS_UNBOUNDP (value))
1208 return CALL_GF1 ("slot-unbound", obj);
1213 SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
1214 (SCM obj, SCM index),
1215 "Return the slot value with index @var{index} from @var{obj}.")
1216 #define FUNC_NAME s_scm_sys_fast_slot_ref
1218 unsigned long int i;
1220 SCM_VALIDATE_INSTANCE (1, obj);
1221 i = scm_to_unsigned_integer (index, 0,
1222 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1225 return SCM_SLOT (obj, i);
1229 SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
1230 (SCM obj, SCM index, SCM value),
1231 "Set the slot with index @var{index} in @var{obj} to\n"
1233 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1235 unsigned long int i;
1237 SCM_VALIDATE_INSTANCE (1, obj);
1238 i = scm_to_unsigned_integer (index, 0,
1239 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
1243 SCM_SET_SLOT (obj, i, value);
1245 return SCM_UNSPECIFIED;
1250 SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
1251 SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
1256 /* In the future, this function will return the effective slot
1257 * definition associated with SLOT_NAME. Now it just returns some of
1258 * the information which will be stored in the effective slot
1263 slot_definition_using_name (SCM class, SCM slot_name)
1265 register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
1266 for (; !scm_is_null (slots); slots = SCM_CDR (slots))
1267 if (SCM_CAAR (slots) == slot_name)
1268 return SCM_CAR (slots);
1273 get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
1274 #define FUNC_NAME "%get-slot-value"
1276 SCM access = SCM_CDDR (slotdef);
1278 * - access is an integer (the offset of this slot in the slots vector)
1279 * - otherwise (car access) is the getter function to apply
1281 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1282 * we can just assume fixnums here.
1284 if (SCM_I_INUMP (access))
1285 /* Don't poke at the slots directly, because scm_struct_ref handles the
1286 access bits for us. */
1287 return scm_struct_ref (obj, access);
1290 /* We must evaluate (apply (car access) (list obj))
1291 * where (car access) is known to be a closure of arity 1 */
1292 register SCM code, env;
1294 code = SCM_CAR (access);
1295 if (!SCM_CLOSUREP (code))
1296 return SCM_SUBRF (code) (obj);
1297 env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1300 /* Evaluate the closure body */
1301 return scm_eval_body (SCM_CLOSURE_BODY (code), env);
1307 get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
1309 SCM slotdef = slot_definition_using_name (class, slot_name);
1310 if (scm_is_true (slotdef))
1311 return get_slot_value (class, obj, slotdef);
1313 return CALL_GF3 ("slot-missing", class, obj, slot_name);
1317 set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
1318 #define FUNC_NAME "%set-slot-value"
1320 SCM access = SCM_CDDR (slotdef);
1322 * - access is an integer (the offset of this slot in the slots vector)
1323 * - otherwise (cadr access) is the setter function to apply
1325 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1326 * we can just assume fixnums here.
1328 if (SCM_I_INUMP (access))
1329 /* obey permissions bits via going through struct-set! */
1330 scm_struct_set_x (obj, access, value);
1333 /* We must evaluate (apply (cadr l) (list obj value))
1334 * where (cadr l) is known to be a closure of arity 2 */
1335 register SCM code, env;
1337 code = SCM_CADR (access);
1338 if (!SCM_CLOSUREP (code))
1339 SCM_SUBRF (code) (obj, value);
1342 env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
1343 scm_list_2 (obj, value),
1345 /* Evaluate the closure body */
1346 scm_eval_body (SCM_CLOSURE_BODY (code), env);
1349 return SCM_UNSPECIFIED;
1354 set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
1356 SCM slotdef = slot_definition_using_name (class, slot_name);
1357 if (scm_is_true (slotdef))
1358 return set_slot_value (class, obj, slotdef, value);
1360 return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
1364 test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
1368 for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
1369 if (scm_is_eq (SCM_CAAR (l), slot_name))
1375 /* ======================================== */
1377 SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
1378 (SCM class, SCM obj, SCM slot_name),
1380 #define FUNC_NAME s_scm_slot_ref_using_class
1384 SCM_VALIDATE_CLASS (1, class);
1385 SCM_VALIDATE_INSTANCE (2, obj);
1386 SCM_VALIDATE_SYMBOL (3, slot_name);
1388 res = get_slot_value_using_name (class, obj, slot_name);
1389 if (SCM_GOOPS_UNBOUNDP (res))
1390 return CALL_GF3 ("slot-unbound", class, obj, slot_name);
1396 SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
1397 (SCM class, SCM obj, SCM slot_name, SCM value),
1399 #define FUNC_NAME s_scm_slot_set_using_class_x
1401 SCM_VALIDATE_CLASS (1, class);
1402 SCM_VALIDATE_INSTANCE (2, obj);
1403 SCM_VALIDATE_SYMBOL (3, slot_name);
1405 return set_slot_value_using_name (class, obj, slot_name, value);
1410 SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
1411 (SCM class, SCM obj, SCM slot_name),
1413 #define FUNC_NAME s_scm_slot_bound_using_class_p
1415 SCM_VALIDATE_CLASS (1, class);
1416 SCM_VALIDATE_INSTANCE (2, obj);
1417 SCM_VALIDATE_SYMBOL (3, slot_name);
1419 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name))
1425 SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
1426 (SCM class, SCM obj, SCM slot_name),
1428 #define FUNC_NAME s_scm_slot_exists_using_class_p
1430 SCM_VALIDATE_CLASS (1, class);
1431 SCM_VALIDATE_INSTANCE (2, obj);
1432 SCM_VALIDATE_SYMBOL (3, slot_name);
1433 return test_slot_existence (class, obj, slot_name);
1438 /* ======================================== */
1440 SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
1441 (SCM obj, SCM slot_name),
1442 "Return the value from @var{obj}'s slot with the name\n"
1444 #define FUNC_NAME s_scm_slot_ref
1448 SCM_VALIDATE_INSTANCE (1, obj);
1449 TEST_CHANGE_CLASS (obj, class);
1451 res = get_slot_value_using_name (class, obj, slot_name);
1452 if (SCM_GOOPS_UNBOUNDP (res))
1453 return CALL_GF3 ("slot-unbound", class, obj, slot_name);
1458 SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
1459 (SCM obj, SCM slot_name, SCM value),
1460 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1461 #define FUNC_NAME s_scm_slot_set_x
1465 SCM_VALIDATE_INSTANCE (1, obj);
1466 TEST_CHANGE_CLASS(obj, class);
1468 return set_slot_value_using_name (class, obj, slot_name, value);
1472 const char *scm_s_slot_set_x = s_scm_slot_set_x;
1474 SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
1475 (SCM obj, SCM slot_name),
1476 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1478 #define FUNC_NAME s_scm_slot_bound_p
1482 SCM_VALIDATE_INSTANCE (1, obj);
1483 TEST_CHANGE_CLASS(obj, class);
1485 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1493 SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
1494 (SCM obj, SCM slot_name),
1495 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1496 #define FUNC_NAME s_scm_slot_exists_p
1500 SCM_VALIDATE_INSTANCE (1, obj);
1501 SCM_VALIDATE_SYMBOL (2, slot_name);
1502 TEST_CHANGE_CLASS (obj, class);
1504 return test_slot_existence (class, obj, slot_name);
1509 /******************************************************************************
1511 * %allocate-instance (the low level instance allocation primitive)
1513 ******************************************************************************/
1515 static void clear_method_cache (SCM);
1518 wrap_init (SCM class, SCM *m, long n)
1521 scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
1522 const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
1524 /* Set all SCM-holding slots to unbound */
1525 for (i = 0; i < n; i++)
1526 if (layout[i*2] == 'p')
1527 m[i] = SCM_GOOPS_UNBOUND;
1531 return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
1533 (scm_t_bits) m, 0, 0);
1536 SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
1537 (SCM class, SCM initargs),
1538 "Create a new instance of class @var{class} and initialize it\n"
1539 "from the arguments @var{initargs}.")
1540 #define FUNC_NAME s_scm_sys_allocate_instance
1545 SCM_VALIDATE_CLASS (1, class);
1547 /* Most instances */
1548 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
1550 n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
1551 m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
1552 return wrap_init (class, m, n);
1555 /* Foreign objects */
1556 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
1557 return scm_make_foreign_object (class, initargs);
1559 n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
1562 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
1564 m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
1566 m[scm_struct_i_setter] = SCM_BOOL_F;
1567 m[scm_struct_i_procedure] = SCM_BOOL_F;
1568 /* Generic functions */
1569 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
1571 SCM gf = wrap_init (class, m, n);
1572 clear_method_cache (gf);
1576 return wrap_init (class, m, n);
1580 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1584 /* allocate class object */
1585 SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
1587 SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
1588 for (i = scm_si_goops_fields; i < n; i++)
1589 SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
1591 if (SCM_SUBCLASSP (class, scm_class_entity_class))
1592 SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
1593 else if (SCM_SUBCLASSP (class, scm_class_operator_class))
1594 SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR);
1599 /* Non-light instances */
1601 m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
1602 return wrap_init (class, m, n);
1607 SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
1608 (SCM obj, SCM setter),
1610 #define FUNC_NAME s_scm_sys_set_object_setter_x
1612 SCM_ASSERT (SCM_STRUCTP (obj)
1613 && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
1614 || SCM_I_ENTITYP (obj)),
1618 if (SCM_I_ENTITYP (obj))
1619 SCM_SET_ENTITY_SETTER (obj, setter);
1621 SCM_OPERATOR_CLASS (obj)->setter = setter;
1622 return SCM_UNSPECIFIED;
1626 /******************************************************************************
1628 * %modify-instance (used by change-class to modify in place)
1630 ******************************************************************************/
1632 SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
1635 #define FUNC_NAME s_scm_sys_modify_instance
1637 SCM_VALIDATE_INSTANCE (1, old);
1638 SCM_VALIDATE_INSTANCE (2, new);
1640 /* Exchange the data contained in old and new. We exchange rather than
1641 * scratch the old value with new to be correct with GC.
1642 * See "Class redefinition protocol above".
1644 SCM_CRITICAL_SECTION_START;
1646 SCM car = SCM_CAR (old);
1647 SCM cdr = SCM_CDR (old);
1648 SCM_SETCAR (old, SCM_CAR (new));
1649 SCM_SETCDR (old, SCM_CDR (new));
1650 SCM_SETCAR (new, car);
1651 SCM_SETCDR (new, cdr);
1653 SCM_CRITICAL_SECTION_END;
1654 return SCM_UNSPECIFIED;
1658 SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
1661 #define FUNC_NAME s_scm_sys_modify_class
1663 SCM_VALIDATE_CLASS (1, old);
1664 SCM_VALIDATE_CLASS (2, new);
1666 SCM_CRITICAL_SECTION_START;
1668 SCM car = SCM_CAR (old);
1669 SCM cdr = SCM_CDR (old);
1670 SCM_SETCAR (old, SCM_CAR (new));
1671 SCM_SETCDR (old, SCM_CDR (new));
1672 SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
1673 SCM_SETCAR (new, car);
1674 SCM_SETCDR (new, cdr);
1675 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
1677 SCM_CRITICAL_SECTION_END;
1678 return SCM_UNSPECIFIED;
1682 SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
1685 #define FUNC_NAME s_scm_sys_invalidate_class
1687 SCM_VALIDATE_CLASS (1, class);
1688 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
1689 return SCM_UNSPECIFIED;
1693 /* When instances change class, they finally get a new body, but
1694 * before that, they go through purgatory in hell. Odd as it may
1695 * seem, this data structure saves us from eternal suffering in
1696 * infinite recursions.
1699 static scm_t_bits **hell;
1700 static long n_hell = 1; /* one place for the evil one himself */
1701 static long hell_size = 4;
1702 static SCM hell_mutex;
1708 for (i = 1; i < n_hell; ++i)
1709 if (SCM_STRUCT_DATA (o) == hell[i])
1715 go_to_hell (void *o)
1717 SCM obj = SCM_PACK ((scm_t_bits) o);
1718 scm_lock_mutex (hell_mutex);
1719 if (n_hell >= hell_size)
1722 hell = scm_realloc (hell, hell_size * sizeof(*hell));
1724 hell[n_hell++] = SCM_STRUCT_DATA (obj);
1725 scm_unlock_mutex (hell_mutex);
1729 go_to_heaven (void *o)
1731 scm_lock_mutex (hell_mutex);
1732 hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
1733 scm_unlock_mutex (hell_mutex);
1737 SCM_SYMBOL (scm_sym_change_class, "change-class");
1740 purgatory (void *args)
1742 return scm_apply_0 (GETVAR (scm_sym_change_class),
1743 SCM_PACK ((scm_t_bits) args));
1746 /* This function calls the generic function change-class for all
1747 * instances which aren't currently undergoing class change.
1751 scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
1754 scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
1755 (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
1756 (void *) SCM_UNPACK (obj));
1759 /******************************************************************************
1765 * GGG E N E R I C F U N C T I O N S
1767 * This implementation provides
1768 * - generic functions (with class specializers)
1771 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1773 ******************************************************************************/
1775 SCM_KEYWORD (k_name, "name");
1777 SCM_SYMBOL (sym_no_method, "no-method");
1779 static SCM list_of_no_method;
1781 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
1785 scm_make_method_cache (SCM gf)
1787 return scm_list_5 (SCM_IM_DISPATCH,
1790 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
1796 clear_method_cache (SCM gf)
1798 SCM cache = scm_make_method_cache (gf);
1799 SCM_SET_ENTITY_PROCEDURE (gf, cache);
1800 SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
1803 SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
1806 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1809 SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
1810 used_by = SCM_SLOT (gf, scm_si_used_by);
1811 if (scm_is_true (used_by))
1813 SCM methods = SCM_SLOT (gf, scm_si_methods);
1814 for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
1815 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
1816 clear_method_cache (gf);
1817 for (; scm_is_pair (methods); methods = SCM_CDR (methods))
1818 SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
1821 SCM n = SCM_SLOT (gf, scm_si_n_specialized);
1822 /* The sign of n is a flag indicating rest args. */
1823 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n);
1825 return SCM_UNSPECIFIED;
1829 SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
1832 #define FUNC_NAME s_scm_generic_capability_p
1834 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
1835 proc, SCM_ARG1, FUNC_NAME);
1836 return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
1842 SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
1845 #define FUNC_NAME s_scm_enable_primitive_generic_x
1847 SCM_VALIDATE_REST_ARGUMENT (subrs);
1848 while (!scm_is_null (subrs))
1850 SCM subr = SCM_CAR (subrs);
1851 SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
1852 subr, SCM_ARGn, FUNC_NAME);
1853 *SCM_SUBR_GENERIC (subr)
1854 = scm_make (scm_list_3 (scm_class_generic,
1857 subrs = SCM_CDR (subrs);
1859 return SCM_UNSPECIFIED;
1863 SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
1866 #define FUNC_NAME s_scm_primitive_generic_generic
1868 if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
1870 if (!*SCM_SUBR_GENERIC (subr))
1871 scm_enable_primitive_generic_x (scm_list_1 (subr));
1872 return *SCM_SUBR_GENERIC (subr);
1874 SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
1878 typedef struct t_extension {
1879 struct t_extension *next;
1884 static t_extension *extensions = 0;
1886 SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
1889 scm_c_extend_primitive_generic (SCM extended, SCM extension)
1894 if (!*SCM_SUBR_GENERIC (extended))
1895 scm_enable_primitive_generic_x (scm_list_1 (extended));
1896 gf = *SCM_SUBR_GENERIC (extended);
1897 gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
1899 SCM_SNAME (extension));
1900 *SCM_SUBR_GENERIC (extension) = gext;
1904 t_extension *e = scm_malloc (sizeof (t_extension));
1905 t_extension **loc = &extensions;
1906 /* Make sure that extensions are placed before their own
1907 * extensions in the extensions list. O(N^2) algorithm, but
1908 * extensions of primitive generics are rare.
1910 while (*loc && extension != (*loc)->extended)
1911 loc = &(*loc)->next;
1913 e->extended = extended;
1914 e->extension = extension;
1920 setup_extended_primitive_generics ()
1924 t_extension *e = extensions;
1925 scm_c_extend_primitive_generic (e->extended, e->extension);
1926 extensions = e->next;
1931 /******************************************************************************
1933 * Protocol for calling a generic fumction
1934 * This protocol is roughly equivalent to (parameter are a little bit different
1935 * for efficiency reasons):
1937 * + apply-generic (gf args)
1938 * + compute-applicable-methods (gf args ...)
1939 * + sort-applicable-methods (methods args)
1940 * + apply-methods (gf methods args)
1942 * apply-methods calls make-next-method to build the "continuation" of a a
1943 * method. Applying a next-method will call apply-next-method which in
1944 * turn will call apply again to call effectively the following method.
1946 ******************************************************************************/
1949 applicablep (SCM actual, SCM formal)
1951 /* We already know that the cpl is well formed. */
1952 return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
1956 more_specificp (SCM m1, SCM m2, SCM const *targs)
1958 register SCM s1, s2;
1962 * m1 and m2 can have != length (i.e. one can be one element longer than the
1963 * other when we have a dotted parameter list). For instance, with the call
1966 * (define-method M (a . l) ....)
1967 * (define-method M (a) ....)
1969 * we consider that the second method is more specific.
1971 * BTW, targs is an array of types. We don't need it's size since
1972 * we already know that m1 and m2 are applicable (no risk to go past
1973 * the end of this array).
1976 for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
1977 if (scm_is_null(s1)) return 1;
1978 if (scm_is_null(s2)) return 0;
1979 if (SCM_CAR(s1) != SCM_CAR(s2)) {
1980 register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
1982 for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
1983 if (cs1 == SCM_CAR(l))
1985 if (cs2 == SCM_CAR(l))
1988 return 0;/* should not occur! */
1991 return 0; /* should not occur! */
1994 #define BUFFSIZE 32 /* big enough for most uses */
1997 scm_i_vector2list (SCM l, long len)
2000 SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
2002 for (j = 0; j < len; j++, l = SCM_CDR (l)) {
2003 SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
2009 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
2012 SCM *v, vector = SCM_EOL;
2013 SCM buffer[BUFFSIZE];
2014 SCM save = method_list;
2015 scm_t_array_handle handle;
2017 /* For reasonably sized method_lists we can try to avoid all the
2018 * consing and reorder the list in place...
2019 * This idea is due to David McClain <Dave_McClain@msn.com>
2021 if (size <= BUFFSIZE)
2023 for (i = 0; i < size; i++)
2025 buffer[i] = SCM_CAR (method_list);
2026 method_list = SCM_CDR (method_list);
2032 /* Too many elements in method_list to keep everything locally */
2033 vector = scm_i_vector2list (save, size);
2034 v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
2037 /* Use a simple shell sort since it is generally faster than qsort on
2038 * small vectors (which is probably mostly the case when we have to
2039 * sort a list of applicable methods).
2041 for (incr = size / 2; incr; incr /= 2)
2043 for (i = incr; i < size; i++)
2045 for (j = i - incr; j >= 0; j -= incr)
2047 if (more_specificp (v[j], v[j+incr], targs))
2051 SCM tmp = v[j + incr];
2059 if (size <= BUFFSIZE)
2061 /* We did it in locally, so restore the original list (reordered) in-place */
2062 for (i = 0, method_list = save; i < size; i++, v++)
2064 SCM_SETCAR (method_list, *v);
2065 method_list = SCM_CDR (method_list);
2070 /* If we are here, that's that we did it the hard way... */
2071 scm_array_handle_release (&handle);
2072 return scm_vector_to_list (vector);
2076 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
2080 SCM l, fl, applicable = SCM_EOL;
2082 SCM buffer[BUFFSIZE];
2086 scm_t_array_handle handle;
2088 /* Build the list of arguments types */
2089 if (len >= BUFFSIZE)
2091 tmp = scm_c_make_vector (len, SCM_UNDEFINED);
2092 types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
2095 note that we don't have to work to reset the generation
2096 count. TMP is a new vector anyway, and it is found
2103 for ( ; !scm_is_null (args); args = SCM_CDR (args))
2104 *p++ = scm_class_of (SCM_CAR (args));
2106 /* Build a list of all applicable methods */
2107 for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
2109 fl = SPEC_OF (SCM_CAR (l));
2110 /* Only accept accessors which match exactly in first arg. */
2111 if (SCM_ACCESSORP (SCM_CAR (l))
2112 && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
2114 for (i = 0; ; i++, fl = SCM_CDR (fl))
2116 if (SCM_INSTANCEP (fl)
2117 /* We have a dotted argument list */
2118 || (i >= len && scm_is_null (fl)))
2119 { /* both list exhausted */
2120 applicable = scm_cons (SCM_CAR (l), applicable);
2126 || !applicablep (types[i], SCM_CAR (fl)))
2131 if (len >= BUFFSIZE)
2132 scm_array_handle_release (&handle);
2138 CALL_GF2 ("no-applicable-method", gf, save);
2139 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2145 : sort_applicable_methods (applicable, count, types));
2149 SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
2152 static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
2155 scm_sys_compute_applicable_methods (SCM gf, SCM args)
2156 #define FUNC_NAME s_sys_compute_applicable_methods
2159 SCM_VALIDATE_GENERIC (1, gf);
2160 n = scm_ilength (args);
2161 SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
2162 return scm_compute_applicable_methods (gf, args, n, 1);
2166 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
2167 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));
2170 lock_cache_mutex (void *m)
2172 SCM mutex = SCM_PACK ((scm_t_bits) m);
2173 scm_lock_mutex (mutex);
2177 unlock_cache_mutex (void *m)
2179 SCM mutex = SCM_PACK ((scm_t_bits) m);
2180 scm_unlock_mutex (mutex);
2184 call_memoize_method (void *a)
2186 SCM args = SCM_PACK ((scm_t_bits) a);
2187 SCM gf = SCM_CAR (args);
2188 SCM x = SCM_CADR (args);
2189 /* First check if another thread has inserted a method between
2190 * the cache miss and locking the mutex.
2192 SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
2193 if (scm_is_true (cmethod))
2195 /*fixme* Use scm_apply */
2196 return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
2200 scm_memoize_method (SCM x, SCM args)
2202 SCM gf = SCM_CAR (scm_last_pair (x));
2203 return scm_internal_dynamic_wind (
2205 call_memoize_method,
2207 (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
2208 (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
2211 /******************************************************************************
2213 * A simple make (which will be redefined later in Scheme)
2214 * This version handles only creation of gf, methods and classes (no instances)
2216 * Since this code will disappear when Goops will be fully booted,
2217 * no precaution is taken to be efficient.
2219 ******************************************************************************/
2221 SCM_KEYWORD (k_setter, "setter");
2222 SCM_KEYWORD (k_specializers, "specializers");
2223 SCM_KEYWORD (k_procedure, "procedure");
2224 SCM_KEYWORD (k_dsupers, "dsupers");
2225 SCM_KEYWORD (k_slots, "slots");
2226 SCM_KEYWORD (k_gf, "generic-function");
2228 SCM_DEFINE (scm_make, "make", 0, 0, 1,
2230 "Make a new object. @var{args} must contain the class and\n"
2231 "all necessary initialization information.")
2232 #define FUNC_NAME s_scm_make
2235 long len = scm_ilength (args);
2237 if (len <= 0 || (len & 1) == 0)
2238 SCM_WRONG_NUM_ARGS ();
2240 class = SCM_CAR(args);
2241 args = SCM_CDR(args);
2243 if (class == scm_class_generic || class == scm_class_accessor)
2245 z = scm_make_struct (class, SCM_INUM0,
2246 scm_list_5 (SCM_EOL,
2251 scm_set_procedure_property_x (z, scm_sym_name,
2252 scm_get_keyword (k_name,
2255 clear_method_cache (z);
2256 if (class == scm_class_accessor)
2258 SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
2259 if (scm_is_true (setter))
2260 scm_sys_set_object_setter_x (z, setter);
2265 z = scm_sys_allocate_instance (class, args);
2267 if (class == scm_class_method
2268 || class == scm_class_simple_method
2269 || class == scm_class_accessor_method)
2271 SCM_SET_SLOT (z, scm_si_generic_function,
2272 scm_i_get_keyword (k_gf,
2277 SCM_SET_SLOT (z, scm_si_specializers,
2278 scm_i_get_keyword (k_specializers,
2283 SCM_SET_SLOT (z, scm_si_procedure,
2284 scm_i_get_keyword (k_procedure,
2289 SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
2293 /* In all the others case, make a new class .... No instance here */
2294 SCM_SET_SLOT (z, scm_si_name,
2295 scm_i_get_keyword (k_name,
2298 scm_from_locale_symbol ("???"),
2300 SCM_SET_SLOT (z, scm_si_direct_supers,
2301 scm_i_get_keyword (k_dsupers,
2306 SCM_SET_SLOT (z, scm_si_direct_slots,
2307 scm_i_get_keyword (k_slots,
2318 SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
2321 #define FUNC_NAME s_scm_find_method
2324 long len = scm_ilength (l);
2327 SCM_WRONG_NUM_ARGS ();
2329 gf = SCM_CAR(l); l = SCM_CDR(l);
2330 SCM_VALIDATE_GENERIC (1, gf);
2331 if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
2332 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
2334 return scm_compute_applicable_methods (gf, l, len - 1, 1);
2338 SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
2339 (SCM m1, SCM m2, SCM targs),
2340 "Return true if method @var{m1} is more specific than @var{m2} "
2341 "given the argument types (classes) listed in @var{targs}.")
2342 #define FUNC_NAME s_scm_sys_method_more_specific_p
2346 long i, len, m1_specs, m2_specs;
2347 scm_t_array_handle handle;
2349 SCM_VALIDATE_METHOD (1, m1);
2350 SCM_VALIDATE_METHOD (2, m2);
2352 len = scm_ilength (targs);
2353 m1_specs = scm_ilength (SPEC_OF (m1));
2354 m2_specs = scm_ilength (SPEC_OF (m2));
2355 SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
2356 targs, SCM_ARG3, FUNC_NAME);
2358 /* Verify that all the arguments of TARGS are classes and place them
2361 v = scm_c_make_vector (len, SCM_EOL);
2362 v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
2364 for (i = 0, l = targs;
2365 i < len && scm_is_pair (l);
2366 i++, l = SCM_CDR (l))
2368 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
2369 v_elts[i] = SCM_CAR (l);
2371 result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
2373 scm_array_handle_release (&handle);
2381 /******************************************************************************
2385 ******************************************************************************/
2388 fix_cpl (SCM c, SCM before, SCM after)
2390 SCM cpl = SCM_SLOT (c, scm_si_cpl);
2391 SCM ls = scm_c_memq (after, cpl);
2392 SCM tail = scm_delq1_x (before, SCM_CDR (ls));
2393 if (scm_is_false (ls))
2394 /* if this condition occurs, fix_cpl should not be applied this way */
2396 SCM_SETCAR (ls, before);
2397 SCM_SETCDR (ls, scm_cons (after, tail));
2399 SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
2400 SCM slots = build_slots_list (maplist (dslots), cpl);
2401 SCM g_n_s = compute_getters_n_setters (slots);
2402 SCM_SET_SLOT (c, scm_si_slots, slots);
2403 SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
2409 make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
2411 SCM tmp = scm_from_locale_symbol (name);
2413 *var = scm_permanent_object (scm_basic_make_class (meta,
2417 : scm_list_1 (super),
2423 SCM_KEYWORD (k_slot_definition, "slot-definition");
2426 create_standard_classes (void)
2429 SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
2430 scm_from_locale_symbol ("specializers"),
2432 scm_from_locale_symbol ("code-table"));
2433 SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2435 k_slot_definition));
2436 SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2437 SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2441 SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
2442 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2445 scm_list_3 (scm_from_locale_symbol ("used-by"),
2448 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2451 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2454 SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2457 /* Foreign class slot classes */
2458 make_stdcls (&scm_class_foreign_slot, "<foreign-slot>",
2459 scm_class_class, scm_class_top, SCM_EOL);
2460 make_stdcls (&scm_class_protected, "<protected-slot>",
2461 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2462 make_stdcls (&scm_class_opaque, "<opaque-slot>",
2463 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2464 make_stdcls (&scm_class_read_only, "<read-only-slot>",
2465 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2466 make_stdcls (&scm_class_self, "<self-slot>",
2468 scm_class_read_only,
2470 make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
2472 scm_list_2 (scm_class_protected, scm_class_opaque),
2474 make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
2476 scm_list_2 (scm_class_protected, scm_class_read_only),
2478 make_stdcls (&scm_class_scm, "<scm-slot>",
2479 scm_class_class, scm_class_protected, SCM_EOL);
2480 make_stdcls (&scm_class_int, "<int-slot>",
2481 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2482 make_stdcls (&scm_class_float, "<float-slot>",
2483 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2484 make_stdcls (&scm_class_double, "<double-slot>",
2485 scm_class_class, scm_class_foreign_slot, SCM_EOL);
2487 /* Continue initialization of class <class> */
2489 slots = build_class_class_slots ();
2490 SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
2491 SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
2492 SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
2493 compute_getters_n_setters (slots));
2495 make_stdcls (&scm_class_foreign_class, "<foreign-class>",
2496 scm_class_class, scm_class_class,
2497 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2500 scm_list_3 (scm_from_locale_symbol ("destructor"),
2502 scm_class_opaque)));
2503 make_stdcls (&scm_class_foreign_object, "<foreign-object>",
2504 scm_class_foreign_class, scm_class_object, SCM_EOL);
2505 SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
2507 /* scm_class_generic functions classes */
2508 make_stdcls (&scm_class_procedure_class, "<procedure-class>",
2509 scm_class_class, scm_class_class, SCM_EOL);
2510 make_stdcls (&scm_class_entity_class, "<entity-class>",
2511 scm_class_class, scm_class_procedure_class, SCM_EOL);
2512 make_stdcls (&scm_class_operator_class, "<operator-class>",
2513 scm_class_class, scm_class_procedure_class, SCM_EOL);
2514 make_stdcls (&scm_class_operator_with_setter_class,
2515 "<operator-with-setter-class>",
2516 scm_class_class, scm_class_operator_class, SCM_EOL);
2517 make_stdcls (&scm_class_method, "<method>",
2518 scm_class_class, scm_class_object, method_slots);
2519 make_stdcls (&scm_class_simple_method, "<simple-method>",
2520 scm_class_class, scm_class_method, SCM_EOL);
2521 SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
2522 make_stdcls (&scm_class_accessor_method, "<accessor-method>",
2523 scm_class_class, scm_class_simple_method, amethod_slots);
2524 SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
2525 make_stdcls (&scm_class_applicable, "<applicable>",
2526 scm_class_class, scm_class_top, SCM_EOL);
2527 make_stdcls (&scm_class_entity, "<entity>",
2528 scm_class_entity_class,
2529 scm_list_2 (scm_class_object, scm_class_applicable),
2531 make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
2532 scm_class_entity_class, scm_class_entity, SCM_EOL);
2533 make_stdcls (&scm_class_generic, "<generic>",
2534 scm_class_entity_class, scm_class_entity, gf_slots);
2535 SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
2536 make_stdcls (&scm_class_extended_generic, "<extended-generic>",
2537 scm_class_entity_class, scm_class_generic, egf_slots);
2538 SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
2539 make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
2540 scm_class_entity_class,
2541 scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
2543 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
2544 make_stdcls (&scm_class_accessor, "<accessor>",
2545 scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
2546 SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
2547 make_stdcls (&scm_class_extended_generic_with_setter,
2548 "<extended-generic-with-setter>",
2549 scm_class_entity_class,
2550 scm_list_2 (scm_class_generic_with_setter,
2551 scm_class_extended_generic),
2553 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
2554 SCM_CLASSF_PURE_GENERIC);
2555 make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
2556 scm_class_entity_class,
2557 scm_list_2 (scm_class_accessor,
2558 scm_class_extended_generic_with_setter),
2560 fix_cpl (scm_class_extended_accessor,
2561 scm_class_extended_generic, scm_class_generic);
2562 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
2564 /* Primitive types classes */
2565 make_stdcls (&scm_class_boolean, "<boolean>",
2566 scm_class_class, scm_class_top, SCM_EOL);
2567 make_stdcls (&scm_class_char, "<char>",
2568 scm_class_class, scm_class_top, SCM_EOL);
2569 make_stdcls (&scm_class_list, "<list>",
2570 scm_class_class, scm_class_top, SCM_EOL);
2571 make_stdcls (&scm_class_pair, "<pair>",
2572 scm_class_class, scm_class_list, SCM_EOL);
2573 make_stdcls (&scm_class_null, "<null>",
2574 scm_class_class, scm_class_list, SCM_EOL);
2575 make_stdcls (&scm_class_string, "<string>",
2576 scm_class_class, scm_class_top, SCM_EOL);
2577 make_stdcls (&scm_class_symbol, "<symbol>",
2578 scm_class_class, scm_class_top, SCM_EOL);
2579 make_stdcls (&scm_class_vector, "<vector>",
2580 scm_class_class, scm_class_top, SCM_EOL);
2581 make_stdcls (&scm_class_number, "<number>",
2582 scm_class_class, scm_class_top, SCM_EOL);
2583 make_stdcls (&scm_class_complex, "<complex>",
2584 scm_class_class, scm_class_number, SCM_EOL);
2585 make_stdcls (&scm_class_real, "<real>",
2586 scm_class_class, scm_class_complex, SCM_EOL);
2587 make_stdcls (&scm_class_integer, "<integer>",
2588 scm_class_class, scm_class_real, SCM_EOL);
2589 make_stdcls (&scm_class_fraction, "<fraction>",
2590 scm_class_class, scm_class_real, SCM_EOL);
2591 make_stdcls (&scm_class_keyword, "<keyword>",
2592 scm_class_class, scm_class_top, SCM_EOL);
2593 make_stdcls (&scm_class_unknown, "<unknown>",
2594 scm_class_class, scm_class_top, SCM_EOL);
2595 make_stdcls (&scm_class_procedure, "<procedure>",
2596 scm_class_procedure_class, scm_class_applicable, SCM_EOL);
2597 make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
2598 scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2599 make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
2600 scm_class_procedure_class, scm_class_procedure, SCM_EOL);
2601 make_stdcls (&scm_class_port, "<port>",
2602 scm_class_class, scm_class_top, SCM_EOL);
2603 make_stdcls (&scm_class_input_port, "<input-port>",
2604 scm_class_class, scm_class_port, SCM_EOL);
2605 make_stdcls (&scm_class_output_port, "<output-port>",
2606 scm_class_class, scm_class_port, SCM_EOL);
2607 make_stdcls (&scm_class_input_output_port, "<input-output-port>",
2609 scm_list_2 (scm_class_input_port, scm_class_output_port),
2613 /**********************************************************************
2617 **********************************************************************/
2620 make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
2626 sprintf (buffer, template, type_name);
2627 name = scm_from_locale_symbol (buffer);
2630 name = SCM_GOOPS_UNBOUND;
2632 class = scm_permanent_object (scm_basic_make_class (applicablep
2633 ? scm_class_procedure_class
2639 /* Only define name if doesn't already exist. */
2640 if (!SCM_GOOPS_UNBOUNDP (name)
2641 && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
2642 DEFVAR (name, class);
2647 scm_make_extended_class (char const *type_name, int applicablep)
2649 return make_class_from_template ("<%s>",
2651 scm_list_1 (applicablep
2652 ? scm_class_applicable
2658 scm_i_inherit_applicable (SCM c)
2660 if (!SCM_SUBCLASSP (c, scm_class_applicable))
2662 SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
2663 SCM cpl = SCM_SLOT (c, scm_si_cpl);
2664 /* patch scm_class_applicable into direct-supers */
2665 SCM top = scm_c_memq (scm_class_top, dsupers);
2666 if (scm_is_false (top))
2667 dsupers = scm_append (scm_list_2 (dsupers,
2668 scm_list_1 (scm_class_applicable)));
2671 SCM_SETCAR (top, scm_class_applicable);
2672 SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2674 SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
2675 /* patch scm_class_applicable into cpl */
2676 top = scm_c_memq (scm_class_top, cpl);
2677 if (scm_is_false (top))
2681 SCM_SETCAR (top, scm_class_applicable);
2682 SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
2684 /* add class to direct-subclasses of scm_class_applicable */
2685 SCM_SET_SLOT (scm_class_applicable,
2686 scm_si_direct_subclasses,
2687 scm_cons (c, SCM_SLOT (scm_class_applicable,
2688 scm_si_direct_subclasses)));
2693 create_smob_classes (void)
2697 scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
2698 for (i = 0; i < 255; ++i)
2699 scm_smob_class[i] = 0;
2701 scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
2703 for (i = 0; i < scm_numsmob; ++i)
2704 if (!scm_smob_class[i])
2705 scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
2706 scm_smobs[i].apply != 0);
2710 scm_make_port_classes (long ptobnum, char *type_name)
2712 SCM c, class = make_class_from_template ("<%s-port>",
2714 scm_list_1 (scm_class_port),
2716 scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
2717 = make_class_from_template ("<%s-input-port>",
2719 scm_list_2 (class, scm_class_input_port),
2721 scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
2722 = make_class_from_template ("<%s-output-port>",
2724 scm_list_2 (class, scm_class_output_port),
2726 scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
2728 = make_class_from_template ("<%s-input-output-port>",
2730 scm_list_2 (class, scm_class_input_output_port),
2732 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2733 SCM_SET_SLOT (c, scm_si_cpl,
2734 scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
2738 create_port_classes (void)
2742 scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
2743 for (i = 0; i < 3 * 256; ++i)
2744 scm_port_class[i] = 0;
2746 for (i = 0; i < scm_numptob; ++i)
2747 scm_make_port_classes (i, SCM_PTOBNAME (i));
2751 make_struct_class (void *closure SCM_UNUSED,
2752 SCM vtable, SCM data, SCM prev SCM_UNUSED)
2754 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
2755 SCM_SET_STRUCT_TABLE_CLASS (data,
2756 scm_make_extended_class
2757 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
2758 SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
2759 return SCM_UNSPECIFIED;
2763 create_struct_classes (void)
2765 scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
2768 /**********************************************************************
2772 **********************************************************************/
2777 if (!goops_loaded_p)
2778 scm_c_resolve_module ("oop goops");
2783 scm_make_foreign_object (SCM class, SCM initargs)
2784 #define FUNC_NAME s_scm_make
2786 void * (*constructor) (SCM)
2787 = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
2788 if (constructor == 0)
2789 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2790 return scm_wrap_object (class, constructor (initargs));
2796 scm_free_foreign_object (SCM *class, SCM *data)
2798 size_t (*destructor) (void *)
2799 = (size_t (*) (void *)) class[scm_si_destructor];
2800 return destructor (data);
2804 scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
2805 void * (*constructor) (SCM initargs),
2806 size_t (*destructor) (void *))
2809 name = scm_from_locale_symbol (s_name);
2810 if (scm_is_null (supers))
2811 supers = scm_list_1 (scm_class_foreign_object);
2812 class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
2813 scm_sys_inherit_magic_x (class, supers);
2815 if (destructor != 0)
2817 SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
2818 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
2822 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
2823 SCM_SET_CLASS_INSTANCE_SIZE (class, size);
2826 SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
2827 SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
2832 SCM_SYMBOL (sym_o, "o");
2833 SCM_SYMBOL (sym_x, "x");
2835 SCM_KEYWORD (k_accessor, "accessor");
2836 SCM_KEYWORD (k_getter, "getter");
2839 default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
2841 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
2846 scm_add_slot (SCM class, char *slot_name, SCM slot_class,
2847 SCM (*getter) (SCM obj),
2848 SCM (*setter) (SCM obj, SCM x),
2849 char *accessor_name)
2852 SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
2853 SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
2854 setter ? setter : default_setter);
2856 /* Dirk:FIXME:: The following two expressions make use of the fact that
2857 * the memoizer will accept a subr-object in the place of a function.
2858 * This is not guaranteed to stay this way. */
2859 SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2861 scm_list_2 (get, sym_o)),
2863 SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
2864 scm_list_2 (sym_o, sym_x),
2865 scm_list_3 (set, sym_o, sym_x)),
2869 SCM name = scm_from_locale_symbol (slot_name);
2870 SCM aname = scm_from_locale_symbol (accessor_name);
2871 SCM gf = scm_ensure_accessor (aname);
2872 SCM slot = scm_list_5 (name,
2875 setter ? k_accessor : k_getter,
2877 scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
2882 scm_add_method (scm_setter (gf),
2883 scm_make (scm_list_5 (scm_class_accessor_method,
2885 scm_list_2 (class, scm_class_top),
2890 SCM_SET_SLOT (class, scm_si_slots,
2891 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
2892 scm_list_1 (slot))));
2894 SCM n = SCM_SLOT (class, scm_si_nfields);
2895 SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
2897 SCM_SET_SLOT (class, scm_si_getters_n_setters,
2898 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
2899 scm_list_1 (gns))));
2900 SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
2907 scm_wrap_object (SCM class, void *data)
2909 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
2917 scm_wrap_component (SCM class, SCM container, void *data)
2919 SCM obj = scm_wrap_object (class, data);
2920 SCM handle = scm_hash_fn_create_handle_x (scm_components,
2926 SCM_SETCDR (handle, container);
2931 scm_ensure_accessor (SCM name)
2933 SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
2934 if (!SCM_IS_A_P (gf, scm_class_accessor))
2936 gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
2937 gf = scm_make (scm_list_5 (scm_class_accessor,
2938 k_name, name, k_setter, gf));
2943 SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
2946 scm_add_method (SCM gf, SCM m)
2948 scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
2953 * Debugging utilities
2956 SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
2958 "Return @code{#t} if @var{obj} is a pure generic.")
2959 #define FUNC_NAME s_scm_pure_generic_p
2961 return scm_from_bool (SCM_PUREGENERICP (obj));
2965 #endif /* GUILE_DEBUG */
2971 SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
2973 "Announce that GOOPS is loaded and perform initialization\n"
2974 "on the C level which depends on the loaded GOOPS modules.")
2975 #define FUNC_NAME s_scm_sys_goops_loaded
2978 var_compute_applicable_methods =
2979 scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
2981 setup_extended_primitive_generics ();
2982 return SCM_UNSPECIFIED;
2986 SCM scm_module_goops;
2989 scm_init_goops_builtins (void)
2991 scm_module_goops = scm_current_module ();
2992 scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
2994 /* Not really necessary right now, but who knows...
2996 scm_permanent_object (scm_module_goops);
2997 scm_permanent_object (scm_goops_lookup_closure);
2999 scm_components = scm_permanent_object (scm_make_weak_key_hash_table
3000 (scm_from_int (37)));
3002 goops_rstate = scm_c_make_rstate ("GOOPS", 5);
3004 #include "libguile/goops.x"
3006 list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
3008 hell = scm_calloc (hell_size * sizeof (*hell));
3009 hell_mutex = scm_permanent_object (scm_make_mutex ());
3011 create_basic_classes ();
3012 create_standard_classes ();
3013 create_smob_classes ();
3014 create_struct_classes ();
3015 create_port_classes ();
3018 SCM name = scm_from_locale_symbol ("no-applicable-method");
3019 scm_no_applicable_method
3020 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
3023 DEFVAR (name, scm_no_applicable_method);
3026 return SCM_UNSPECIFIED;
3032 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3033 scm_init_goops_builtins);