1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
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
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * 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/gsubr.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
57 #include "libguile/vm.h"
59 #include "libguile/validate.h"
60 #include "libguile/goops.h"
62 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
65 #define SCM_IN_PCLASS_INDEX 0
66 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
67 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
69 /* this file is a mess. in theory, though, we shouldn't have many SCM references
70 -- most of the references should be to vars. */
72 static SCM var_slot_unbound
= SCM_BOOL_F
;
73 static SCM var_slot_missing
= SCM_BOOL_F
;
74 static SCM var_compute_cpl
= SCM_BOOL_F
;
75 static SCM var_no_applicable_method
= SCM_BOOL_F
;
76 static SCM var_change_class
= SCM_BOOL_F
;
78 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
79 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
80 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
81 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
82 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
83 SCM_SYMBOL (sym_change_class
, "change-class");
85 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
88 /* Class redefinition protocol:
90 A class is represented by a heap header h1 which points to a
91 malloc:ed memory block m1.
93 When a new version of a class is created, a new header h2 and
94 memory block m2 are allocated. The headers h1 and h2 then switch
95 pointers so that h1 refers to m2 and h2 to m1. In this way, names
96 bound to h1 will point to the new class at the same time as h2 will
97 be a handle which the GC will use to free m1.
99 The `redefined' slot of m1 will be set to point to h1. An old
100 instance will have its class pointer (the CAR of the heap header)
101 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
102 the class modification and the new class pointer can be found via
106 #define TEST_CHANGE_CLASS(obj, class) \
108 class = SCM_CLASS_OF (obj); \
109 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
111 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
112 class = SCM_CLASS_OF (obj); \
116 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
117 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
119 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
120 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
122 static int goops_loaded_p
= 0;
123 static scm_t_rstate
*goops_rstate
;
125 /* These variables are filled in by the object system when loaded. */
126 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
127 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
128 SCM scm_class_primitive_generic
;
129 SCM scm_class_vector
, scm_class_null
;
130 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
131 SCM scm_class_unknown
;
132 SCM scm_class_top
, scm_class_object
, scm_class_class
;
133 SCM scm_class_applicable
;
134 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
135 SCM scm_class_generic
, scm_class_generic_with_setter
;
136 SCM scm_class_accessor
;
137 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
138 SCM scm_class_extended_accessor
;
139 SCM scm_class_method
;
140 SCM scm_class_accessor_method
;
141 SCM scm_class_procedure_class
;
142 SCM scm_class_applicable_struct_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_slot
;
148 SCM scm_class_self
, scm_class_protected
;
149 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
150 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
152 SCM scm_class_int
, scm_class_float
, scm_class_double
;
154 static SCM class_foreign
;
155 static SCM class_hashtable
;
156 static SCM class_fluid
;
157 static SCM class_dynamic_state
;
158 static SCM class_frame
;
159 static SCM class_objcode
;
161 static SCM class_vm_cont
;
162 static SCM class_bytevector
;
163 static SCM class_uvec
;
165 static SCM vtable_class_map
= SCM_BOOL_F
;
166 static scm_i_pthread_mutex_t vtable_class_map_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
168 /* Port classes. Allocate 3 times the maximum number of port types so that
169 input ports, output ports, and in/out ports can be stored at different
170 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
171 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
174 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
176 SCM scm_no_applicable_method
;
178 SCM_SYMBOL (scm_sym_define_public
, "define-public");
180 static SCM
scm_make_unbound (void);
181 static SCM
scm_unbound_p (SCM obj
);
182 static SCM
scm_assert_bound (SCM value
, SCM obj
);
183 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
184 static SCM
scm_sys_goops_loaded (void);
185 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
190 scm_i_define_class_for_vtable (SCM vtable
)
194 scm_i_pthread_mutex_lock (&vtable_class_map_lock
);
196 if (scm_is_false (vtable_class_map
))
197 vtable_class_map
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
199 if (scm_is_false (scm_struct_vtable_p (vtable
)))
202 class = scm_hashq_ref (vtable_class_map
, vtable
, SCM_BOOL_F
);
204 scm_i_pthread_mutex_unlock (&vtable_class_map_lock
);
206 if (scm_is_false (class))
208 if (SCM_UNPACK (scm_class_class
))
210 SCM name
= SCM_VTABLE_NAME (vtable
);
211 if (!scm_is_symbol (name
))
212 name
= scm_string_to_symbol (scm_nullstr
);
214 class = scm_make_extended_class_from_symbol
215 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
218 /* `create_struct_classes' will fill this in later. */
221 /* Don't worry about races. This only happens when creating a
222 vtable, which happens by definition in one thread. */
223 scm_i_pthread_mutex_lock (&vtable_class_map_lock
);
224 scm_hashq_set_x (vtable_class_map
, vtable
, class);
225 scm_i_pthread_mutex_unlock (&vtable_class_map_lock
);
231 /* This function is used for efficient type dispatch. */
232 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
234 "Return the class of @var{x}.")
235 #define FUNC_NAME s_scm_class_of
237 switch (SCM_ITAG3 (x
))
241 return scm_class_integer
;
245 return scm_class_char
;
246 else if (scm_is_bool (x
))
247 return scm_class_boolean
;
248 else if (scm_is_null (x
))
249 return scm_class_null
;
251 return scm_class_unknown
;
254 switch (SCM_TYP7 (x
))
256 case scm_tcs_cons_nimcar
:
257 return scm_class_pair
;
259 return scm_class_symbol
;
262 return scm_class_vector
;
263 case scm_tc7_pointer
:
264 return class_foreign
;
265 case scm_tc7_hashtable
:
266 return class_hashtable
;
269 case scm_tc7_dynamic_state
:
270 return class_dynamic_state
;
273 case scm_tc7_objcode
:
274 return class_objcode
;
277 case scm_tc7_vm_cont
:
278 return class_vm_cont
;
279 case scm_tc7_bytevector
:
280 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
281 return class_bytevector
;
285 return scm_class_string
;
287 switch SCM_TYP16 (x
) {
289 return scm_class_integer
;
291 return scm_class_real
;
292 case scm_tc16_complex
:
293 return scm_class_complex
;
294 case scm_tc16_fraction
:
295 return scm_class_fraction
;
297 case scm_tc7_program
:
298 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
299 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
300 return scm_class_primitive_generic
;
302 return scm_class_procedure
;
306 scm_t_bits type
= SCM_TYP16 (x
);
307 if (type
!= scm_tc16_port_with_ps
)
308 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
309 x
= SCM_PORT_WITH_PS_PORT (x
);
310 /* fall through to ports */
313 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
314 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
315 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
316 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
317 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
319 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
320 return SCM_CLASS_OF (x
);
321 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
324 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
325 scm_change_object_class (x
,
326 SCM_CLASS_OF (x
), /* old */
327 SCM_OBJ_CLASS_REDEF (x
)); /* new */
328 return SCM_CLASS_OF (x
);
331 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
334 return scm_class_pair
;
336 return scm_class_unknown
;
342 /* case scm_tc3_unused: */
346 return scm_class_unknown
;
350 /******************************************************************************
354 * This version doesn't fully handle multiple-inheritance. It serves
355 * only for booting classes and will be overloaded in Scheme
357 ******************************************************************************/
360 map (SCM (*proc
) (SCM
), SCM ls
)
362 if (scm_is_null (ls
))
366 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
369 while (!scm_is_null (ls
))
371 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
383 while (!scm_is_null (ls
))
385 SCM el
= SCM_CAR (ls
);
386 if (scm_is_false (scm_c_memq (el
, res
)))
387 res
= scm_cons (el
, res
);
394 compute_cpl (SCM
class)
397 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
400 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
401 SCM ls
= scm_append (scm_acons (class, supers
,
402 map (compute_cpl
, supers
)));
403 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
407 /******************************************************************************
411 ******************************************************************************/
414 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
422 if (!scm_is_symbol (tmp
))
423 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
425 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
426 res
= scm_cons (SCM_CAR (l
), res
);
427 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
430 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
434 build_slots_list (SCM dslots
, SCM cpl
)
436 register SCM res
= dslots
;
438 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
439 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
440 scm_si_direct_slots
),
443 /* res contains a list of slots. Remove slots which appears more than once */
444 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
451 while (!scm_is_null (ls
))
453 if (!scm_is_pair (SCM_CAR (ls
)))
454 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
461 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
463 "Return a list consisting of the names of all slots belonging to\n"
464 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
466 #define FUNC_NAME s_scm_sys_compute_slots
468 SCM_VALIDATE_CLASS (1, class);
469 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
470 SCM_SLOT (class, scm_si_cpl
));
475 /******************************************************************************
477 * compute-getters-n-setters
479 * This version doesn't handle slot options. It serves only for booting
480 * classes and will be overloaded in Scheme.
482 ******************************************************************************/
484 SCM_KEYWORD (k_init_value
, "init-value");
485 SCM_KEYWORD (k_init_thunk
, "init-thunk");
488 compute_getters_n_setters (SCM slots
)
494 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
496 SCM init
= SCM_BOOL_F
;
497 SCM options
= SCM_CDAR (slots
);
498 if (!scm_is_null (options
))
500 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
501 if (SCM_UNPACK (init
))
503 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
505 scm_list_2 (scm_sym_quote
,
509 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
511 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
513 scm_from_int (i
++))),
515 cdrloc
= SCM_CDRLOC (*cdrloc
);
520 /******************************************************************************
524 ******************************************************************************/
526 /*fixme* Manufacture keywords in advance */
528 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
532 for (i
= 0; i
!= len
; i
+= 2)
534 SCM obj
= SCM_CAR (l
);
536 if (!scm_is_keyword (obj
))
537 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
538 else if (scm_is_eq (obj
, key
))
544 return default_value
;
548 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
549 (SCM key
, SCM l
, SCM default_value
),
550 "Determine an associated value for the keyword @var{key} from\n"
551 "the list @var{l}. The list @var{l} has to consist of an even\n"
552 "number of elements, where, starting with the first, every\n"
553 "second element is a keyword, followed by its associated value.\n"
554 "If @var{l} does not hold a value for @var{key}, the value\n"
555 "@var{default_value} is returned.")
556 #define FUNC_NAME s_scm_get_keyword
560 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
561 len
= scm_ilength (l
);
562 if (len
< 0 || len
% 2 == 1)
563 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
565 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
570 SCM_KEYWORD (k_init_keyword
, "init-keyword");
572 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
573 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
575 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
576 (SCM obj
, SCM initargs
),
577 "Initialize the object @var{obj} with the given arguments\n"
579 #define FUNC_NAME s_scm_sys_initialize_object
581 SCM tmp
, get_n_set
, slots
;
582 SCM
class = SCM_CLASS_OF (obj
);
585 SCM_VALIDATE_INSTANCE (1, obj
);
586 n_initargs
= scm_ilength (initargs
);
587 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
589 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
590 slots
= SCM_SLOT (class, scm_si_slots
);
592 /* See for each slot how it must be initialized */
594 !scm_is_null (slots
);
595 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
597 SCM slot_name
= SCM_CAR (slots
);
598 SCM slot_value
= SCM_PACK (0);
600 if (!scm_is_null (SCM_CDR (slot_name
)))
602 /* This slot admits (perhaps) to be initialized at creation time */
603 long n
= scm_ilength (SCM_CDR (slot_name
));
604 if (n
& 1) /* odd or -1 */
605 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
606 scm_list_1 (slot_name
));
607 tmp
= scm_i_get_keyword (k_init_keyword
,
612 slot_name
= SCM_CAR (slot_name
);
613 if (SCM_UNPACK (tmp
))
615 /* an initarg was provided for this slot */
616 if (!scm_is_keyword (tmp
))
617 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
619 slot_value
= scm_i_get_keyword (tmp
,
627 if (SCM_UNPACK (slot_value
))
628 /* set slot to provided value */
629 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
632 /* set slot to its :init-form if it exists */
633 tmp
= SCM_CADAR (get_n_set
);
634 if (scm_is_true (tmp
))
636 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
637 if (SCM_GOOPS_UNBOUNDP (slot_value
))
638 set_slot_value (class,
650 /* NOTE: The following macros are interdependent with code
651 * in goops.scm:compute-getters-n-setters
653 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
654 (SCM_I_INUMP (SCM_CDDR (gns)) \
655 || (scm_is_pair (SCM_CDDR (gns)) \
656 && scm_is_pair (SCM_CDDDR (gns)) \
657 && scm_is_pair (SCM_CDDDDR (gns))))
658 #define SCM_GNS_INDEX(gns) \
659 (SCM_I_INUMP (SCM_CDDR (gns)) \
660 ? SCM_I_INUM (SCM_CDDR (gns)) \
661 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
662 #define SCM_GNS_SIZE(gns) \
663 (SCM_I_INUMP (SCM_CDDR (gns)) \
665 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
667 SCM_KEYWORD (k_class
, "class");
668 SCM_KEYWORD (k_allocation
, "allocation");
669 SCM_KEYWORD (k_instance
, "instance");
671 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
674 #define FUNC_NAME s_scm_sys_prep_layout_x
676 SCM slots
, getters_n_setters
, nfields
;
677 unsigned long int n
, i
;
681 SCM_VALIDATE_INSTANCE (1, class);
682 slots
= SCM_SLOT (class, scm_si_slots
);
683 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
684 nfields
= SCM_SLOT (class, scm_si_nfields
);
685 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
686 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
687 scm_list_1 (nfields
));
688 n
= 2 * SCM_I_INUM (nfields
);
689 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
690 && SCM_SUBCLASSP (class, scm_class_class
))
691 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
692 scm_list_1 (nfields
));
694 layout
= scm_i_make_string (n
, &s
, 0);
696 while (scm_is_pair (getters_n_setters
))
698 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
701 int len
, index
, size
;
704 if (i
>= n
|| !scm_is_pair (slots
))
707 /* extract slot type */
708 len
= scm_ilength (SCM_CDAR (slots
));
709 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
710 len
, SCM_BOOL_F
, FUNC_NAME
);
711 /* determine slot GC protection and access mode */
712 if (scm_is_false (type
))
719 if (!SCM_CLASSP (type
))
720 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
721 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
723 if (SCM_SUBCLASSP (type
, scm_class_self
))
725 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
730 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
732 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
734 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
746 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
747 if (index
!= (i
>> 1))
749 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
757 slots
= SCM_CDR (slots
);
758 getters_n_setters
= SCM_CDR (getters_n_setters
);
760 if (!scm_is_null (slots
))
763 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
765 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
766 return SCM_UNSPECIFIED
;
770 static void prep_hashsets (SCM
);
772 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
773 (SCM
class, SCM dsupers
),
775 #define FUNC_NAME s_scm_sys_inherit_magic_x
777 SCM_VALIDATE_INSTANCE (1, class);
778 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
779 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
781 prep_hashsets (class);
783 return SCM_UNSPECIFIED
;
788 prep_hashsets (SCM
class)
792 for (i
= 0; i
< 8; ++i
)
793 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
796 /******************************************************************************/
799 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
801 SCM z
, cpl
, slots
, nfields
, g_n_s
;
803 /* Allocate one instance */
804 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
806 /* Initialize its slots */
807 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
808 cpl
= compute_cpl (z
);
809 slots
= build_slots_list (maplist (dslots
), cpl
);
810 nfields
= scm_from_int (scm_ilength (slots
));
811 g_n_s
= compute_getters_n_setters (slots
);
813 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
814 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
815 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
816 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
817 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
818 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
819 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
820 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
821 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
823 /* Add this class in the direct-subclasses slot of dsupers */
826 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
827 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
828 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
829 scm_si_direct_subclasses
)));
836 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
838 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
839 scm_sys_prep_layout_x (z
);
840 scm_sys_inherit_magic_x (z
, dsupers
);
844 /******************************************************************************/
846 SCM_SYMBOL (sym_layout
, "layout");
847 SCM_SYMBOL (sym_flags
, "flags");
848 SCM_SYMBOL (sym_self
, "%self");
849 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
850 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
851 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
852 SCM_SYMBOL (sym_print
, "print");
853 SCM_SYMBOL (sym_procedure
, "procedure");
854 SCM_SYMBOL (sym_setter
, "setter");
855 SCM_SYMBOL (sym_redefined
, "redefined");
856 SCM_SYMBOL (sym_h0
, "h0");
857 SCM_SYMBOL (sym_h1
, "h1");
858 SCM_SYMBOL (sym_h2
, "h2");
859 SCM_SYMBOL (sym_h3
, "h3");
860 SCM_SYMBOL (sym_h4
, "h4");
861 SCM_SYMBOL (sym_h5
, "h5");
862 SCM_SYMBOL (sym_h6
, "h6");
863 SCM_SYMBOL (sym_h7
, "h7");
864 SCM_SYMBOL (sym_name
, "name");
865 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
866 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
867 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
868 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
869 SCM_SYMBOL (sym_cpl
, "cpl");
870 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
871 SCM_SYMBOL (sym_slots
, "slots");
872 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
873 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
874 SCM_SYMBOL (sym_nfields
, "nfields");
878 build_class_class_slots ()
880 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
881 SCM_CLASS_CLASS_LAYOUT */
883 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
884 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
885 scm_list_3 (sym_self
, k_class
, scm_class_self
),
886 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
887 scm_list_1 (sym_print
),
888 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
889 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
890 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
891 scm_list_1 (sym_redefined
),
892 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
893 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
894 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
895 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
896 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
897 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
898 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
899 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
900 scm_list_1 (sym_direct_supers
),
901 scm_list_1 (sym_direct_slots
),
902 scm_list_1 (sym_direct_subclasses
),
903 scm_list_1 (sym_direct_methods
),
904 scm_list_1 (sym_cpl
),
905 scm_list_1 (sym_default_slot_definition_class
),
906 scm_list_1 (sym_slots
),
907 scm_list_1 (sym_getters_n_setters
),
908 scm_list_1 (sym_keyword_access
),
909 scm_list_1 (sym_nfields
),
914 create_basic_classes (void)
916 /* SCM slots_of_class = build_class_class_slots (); */
919 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
920 SCM name
= scm_from_latin1_symbol ("<class>");
921 scm_class_class
= scm_make_vtable_vtable (cs
, SCM_INUM0
, SCM_EOL
);
922 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
923 | SCM_CLASSF_METACLASS
));
925 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
926 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
927 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
928 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
929 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
930 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
931 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
932 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
933 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
934 compute_getters_n_setters (slots_of_class)); */
935 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
937 prep_hashsets (scm_class_class
);
939 scm_module_define (scm_module_goops
, name
, scm_class_class
);
942 name
= scm_from_latin1_symbol ("<top>");
943 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
946 scm_module_define (scm_module_goops
, name
, scm_class_top
);
949 name
= scm_from_latin1_symbol ("<object>");
950 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
951 scm_list_1 (scm_class_top
), SCM_EOL
);
953 scm_module_define (scm_module_goops
, name
, scm_class_object
);
955 /* <top> <object> and <class> were partially initialized. Correct them here */
956 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
958 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
959 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
962 /******************************************************************************/
964 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
966 "Return @code{#t} if @var{obj} is an instance.")
967 #define FUNC_NAME s_scm_instance_p
969 return scm_from_bool (SCM_INSTANCEP (obj
));
974 /******************************************************************************
976 * Meta object accessors
978 ******************************************************************************/
979 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
981 "Return the class name of @var{obj}.")
982 #define FUNC_NAME s_scm_class_name
984 SCM_VALIDATE_CLASS (1, obj
);
985 return scm_slot_ref (obj
, sym_name
);
989 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
991 "Return the direct superclasses of the class @var{obj}.")
992 #define FUNC_NAME s_scm_class_direct_supers
994 SCM_VALIDATE_CLASS (1, obj
);
995 return scm_slot_ref (obj
, sym_direct_supers
);
999 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1001 "Return the direct slots of the class @var{obj}.")
1002 #define FUNC_NAME s_scm_class_direct_slots
1004 SCM_VALIDATE_CLASS (1, obj
);
1005 return scm_slot_ref (obj
, sym_direct_slots
);
1009 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1011 "Return the direct subclasses of the class @var{obj}.")
1012 #define FUNC_NAME s_scm_class_direct_subclasses
1014 SCM_VALIDATE_CLASS (1, obj
);
1015 return scm_slot_ref(obj
, sym_direct_subclasses
);
1019 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1021 "Return the direct methods of the class @var{obj}")
1022 #define FUNC_NAME s_scm_class_direct_methods
1024 SCM_VALIDATE_CLASS (1, obj
);
1025 return scm_slot_ref (obj
, sym_direct_methods
);
1029 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1031 "Return the class precedence list of the class @var{obj}.")
1032 #define FUNC_NAME s_scm_class_precedence_list
1034 SCM_VALIDATE_CLASS (1, obj
);
1035 return scm_slot_ref (obj
, sym_cpl
);
1039 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1041 "Return the slot list of the class @var{obj}.")
1042 #define FUNC_NAME s_scm_class_slots
1044 SCM_VALIDATE_CLASS (1, obj
);
1045 return scm_slot_ref (obj
, sym_slots
);
1049 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1051 "Return the name of the generic function @var{obj}.")
1052 #define FUNC_NAME s_scm_generic_function_name
1054 SCM_VALIDATE_GENERIC (1, obj
);
1055 return scm_procedure_property (obj
, scm_sym_name
);
1059 SCM_SYMBOL (sym_methods
, "methods");
1060 SCM_SYMBOL (sym_extended_by
, "extended-by");
1061 SCM_SYMBOL (sym_extends
, "extends");
1064 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1066 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1067 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1068 while (!scm_is_null (gfs
))
1070 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1071 gfs
= SCM_CDR (gfs
);
1073 return method_lists
;
1077 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1079 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1081 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1082 while (!scm_is_null (gfs
))
1084 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1085 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1088 gfs
= SCM_CDR (gfs
);
1091 return method_lists
;
1094 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1096 "Return the methods of the generic function @var{obj}.")
1097 #define FUNC_NAME s_scm_generic_function_methods
1100 SCM_VALIDATE_GENERIC (1, obj
);
1101 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1102 methods
= fold_downward_gf_methods (methods
, obj
);
1103 return scm_append (methods
);
1107 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1109 "Return the generic function for the method @var{obj}.")
1110 #define FUNC_NAME s_scm_method_generic_function
1112 SCM_VALIDATE_METHOD (1, obj
);
1113 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1117 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1119 "Return specializers of the method @var{obj}.")
1120 #define FUNC_NAME s_scm_method_specializers
1122 SCM_VALIDATE_METHOD (1, obj
);
1123 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1127 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1129 "Return the procedure of the method @var{obj}.")
1130 #define FUNC_NAME s_scm_method_procedure
1132 SCM_VALIDATE_METHOD (1, obj
);
1133 return scm_slot_ref (obj
, sym_procedure
);
1137 /******************************************************************************
1139 * S l o t a c c e s s
1141 ******************************************************************************/
1143 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1145 "Return the unbound value.")
1146 #define FUNC_NAME s_scm_make_unbound
1148 return SCM_GOOPS_UNBOUND
;
1152 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1154 "Return @code{#t} if @var{obj} is unbound.")
1155 #define FUNC_NAME s_scm_unbound_p
1157 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1161 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1162 (SCM value
, SCM obj
),
1163 "Return @var{value} if it is bound, and invoke the\n"
1164 "@var{slot-unbound} method of @var{obj} if it is not.")
1165 #define FUNC_NAME s_scm_assert_bound
1167 if (SCM_GOOPS_UNBOUNDP (value
))
1168 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1173 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1174 (SCM obj
, SCM index
),
1175 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1176 "the value from @var{obj}.")
1177 #define FUNC_NAME s_scm_at_assert_bound_ref
1179 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1180 if (SCM_GOOPS_UNBOUNDP (value
))
1181 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1186 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1187 (SCM obj
, SCM index
),
1188 "Return the slot value with index @var{index} from @var{obj}.")
1189 #define FUNC_NAME s_scm_sys_fast_slot_ref
1193 SCM_VALIDATE_INSTANCE (1, obj
);
1194 i
= scm_to_unsigned_integer (index
, 0,
1195 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1198 return SCM_SLOT (obj
, i
);
1202 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1203 (SCM obj
, SCM index
, SCM value
),
1204 "Set the slot with index @var{index} in @var{obj} to\n"
1206 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1210 SCM_VALIDATE_INSTANCE (1, obj
);
1211 i
= scm_to_unsigned_integer (index
, 0,
1212 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1216 SCM_SET_SLOT (obj
, i
, value
);
1218 return SCM_UNSPECIFIED
;
1226 /* In the future, this function will return the effective slot
1227 * definition associated with SLOT_NAME. Now it just returns some of
1228 * the information which will be stored in the effective slot
1233 slot_definition_using_name (SCM
class, SCM slot_name
)
1235 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1236 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1237 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1238 return SCM_CAR (slots
);
1243 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1244 #define FUNC_NAME "%get-slot-value"
1246 SCM access
= SCM_CDDR (slotdef
);
1248 * - access is an integer (the offset of this slot in the slots vector)
1249 * - otherwise (car access) is the getter function to apply
1251 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1252 * we can just assume fixnums here.
1254 if (SCM_I_INUMP (access
))
1255 /* Don't poke at the slots directly, because scm_struct_ref handles the
1256 access bits for us. */
1257 return scm_struct_ref (obj
, access
);
1259 return scm_call_1 (SCM_CAR (access
), obj
);
1264 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1266 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1267 if (scm_is_true (slotdef
))
1268 return get_slot_value (class, obj
, slotdef
);
1270 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1274 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1275 #define FUNC_NAME "%set-slot-value"
1277 SCM access
= SCM_CDDR (slotdef
);
1279 * - access is an integer (the offset of this slot in the slots vector)
1280 * - otherwise (cadr access) is the setter function to apply
1282 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1283 * we can just assume fixnums here.
1285 if (SCM_I_INUMP (access
))
1286 /* obey permissions bits via going through struct-set! */
1287 scm_struct_set_x (obj
, access
, value
);
1289 /* ((cadr l) obj value) */
1290 scm_call_2 (SCM_CADR (access
), obj
, value
);
1291 return SCM_UNSPECIFIED
;
1296 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1298 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1299 if (scm_is_true (slotdef
))
1300 return set_slot_value (class, obj
, slotdef
, value
);
1302 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1306 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1310 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1311 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1317 /* ======================================== */
1319 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1320 (SCM
class, SCM obj
, SCM slot_name
),
1322 #define FUNC_NAME s_scm_slot_ref_using_class
1326 SCM_VALIDATE_CLASS (1, class);
1327 SCM_VALIDATE_INSTANCE (2, obj
);
1328 SCM_VALIDATE_SYMBOL (3, slot_name
);
1330 res
= get_slot_value_using_name (class, obj
, slot_name
);
1331 if (SCM_GOOPS_UNBOUNDP (res
))
1332 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1338 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1339 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1341 #define FUNC_NAME s_scm_slot_set_using_class_x
1343 SCM_VALIDATE_CLASS (1, class);
1344 SCM_VALIDATE_INSTANCE (2, obj
);
1345 SCM_VALIDATE_SYMBOL (3, slot_name
);
1347 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1352 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1353 (SCM
class, SCM obj
, SCM slot_name
),
1355 #define FUNC_NAME s_scm_slot_bound_using_class_p
1357 SCM_VALIDATE_CLASS (1, class);
1358 SCM_VALIDATE_INSTANCE (2, obj
);
1359 SCM_VALIDATE_SYMBOL (3, slot_name
);
1361 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1367 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1368 (SCM
class, SCM obj
, SCM slot_name
),
1370 #define FUNC_NAME s_scm_slot_exists_using_class_p
1372 SCM_VALIDATE_CLASS (1, class);
1373 SCM_VALIDATE_INSTANCE (2, obj
);
1374 SCM_VALIDATE_SYMBOL (3, slot_name
);
1375 return test_slot_existence (class, obj
, slot_name
);
1380 /* ======================================== */
1382 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1383 (SCM obj
, SCM slot_name
),
1384 "Return the value from @var{obj}'s slot with the name\n"
1386 #define FUNC_NAME s_scm_slot_ref
1390 SCM_VALIDATE_INSTANCE (1, obj
);
1391 TEST_CHANGE_CLASS (obj
, class);
1393 res
= get_slot_value_using_name (class, obj
, slot_name
);
1394 if (SCM_GOOPS_UNBOUNDP (res
))
1395 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1400 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1401 (SCM obj
, SCM slot_name
, SCM value
),
1402 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1403 #define FUNC_NAME s_scm_slot_set_x
1407 SCM_VALIDATE_INSTANCE (1, obj
);
1408 TEST_CHANGE_CLASS(obj
, class);
1410 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1414 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1416 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1417 (SCM obj
, SCM slot_name
),
1418 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1420 #define FUNC_NAME s_scm_slot_bound_p
1424 SCM_VALIDATE_INSTANCE (1, obj
);
1425 TEST_CHANGE_CLASS(obj
, class);
1427 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1435 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1436 (SCM obj
, SCM slot_name
),
1437 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1438 #define FUNC_NAME s_scm_slot_exists_p
1442 SCM_VALIDATE_INSTANCE (1, obj
);
1443 SCM_VALIDATE_SYMBOL (2, slot_name
);
1444 TEST_CHANGE_CLASS (obj
, class);
1446 return test_slot_existence (class, obj
, slot_name
);
1451 /******************************************************************************
1453 * %allocate-instance (the low level instance allocation primitive)
1455 ******************************************************************************/
1457 static void clear_method_cache (SCM
);
1459 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1460 (SCM
class, SCM initargs
),
1461 "Create a new instance of class @var{class} and initialize it\n"
1462 "from the arguments @var{initargs}.")
1463 #define FUNC_NAME s_scm_sys_allocate_instance
1466 scm_t_signed_bits n
, i
;
1469 SCM_VALIDATE_CLASS (1, class);
1471 /* FIXME: duplicates some of scm_make_struct. */
1473 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1474 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1476 layout
= SCM_VTABLE_LAYOUT (class);
1478 /* Set all SCM-holding slots to unbound */
1479 for (i
= 0; i
< n
; i
++)
1481 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1483 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1485 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1487 SCM_STRUCT_DATA (obj
)[i
] = 0;
1490 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1491 clear_method_cache (obj
);
1497 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1498 (SCM obj
, SCM setter
),
1500 #define FUNC_NAME s_scm_sys_set_object_setter_x
1502 SCM_ASSERT (SCM_STRUCTP (obj
)
1503 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1507 SCM_SET_GENERIC_SETTER (obj
, setter
);
1508 return SCM_UNSPECIFIED
;
1512 /******************************************************************************
1514 * %modify-instance (used by change-class to modify in place)
1516 ******************************************************************************/
1518 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1521 #define FUNC_NAME s_scm_sys_modify_instance
1523 SCM_VALIDATE_INSTANCE (1, old
);
1524 SCM_VALIDATE_INSTANCE (2, new);
1526 /* Exchange the data contained in old and new. We exchange rather than
1527 * scratch the old value with new to be correct with GC.
1528 * See "Class redefinition protocol above".
1530 SCM_CRITICAL_SECTION_START
;
1532 scm_t_bits word0
, word1
;
1533 word0
= SCM_CELL_WORD_0 (old
);
1534 word1
= SCM_CELL_WORD_1 (old
);
1535 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1536 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1537 SCM_SET_CELL_WORD_0 (new, word0
);
1538 SCM_SET_CELL_WORD_1 (new, word1
);
1540 SCM_CRITICAL_SECTION_END
;
1541 return SCM_UNSPECIFIED
;
1545 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1548 #define FUNC_NAME s_scm_sys_modify_class
1550 SCM_VALIDATE_CLASS (1, old
);
1551 SCM_VALIDATE_CLASS (2, new);
1553 SCM_CRITICAL_SECTION_START
;
1555 scm_t_bits word0
, word1
;
1556 word0
= SCM_CELL_WORD_0 (old
);
1557 word1
= SCM_CELL_WORD_1 (old
);
1558 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1559 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1560 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1561 SCM_SET_CELL_WORD_0 (new, word0
);
1562 SCM_SET_CELL_WORD_1 (new, word1
);
1563 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1565 SCM_CRITICAL_SECTION_END
;
1566 return SCM_UNSPECIFIED
;
1570 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1573 #define FUNC_NAME s_scm_sys_invalidate_class
1575 SCM_VALIDATE_CLASS (1, class);
1576 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1577 return SCM_UNSPECIFIED
;
1581 /* When instances change class, they finally get a new body, but
1582 * before that, they go through purgatory in hell. Odd as it may
1583 * seem, this data structure saves us from eternal suffering in
1584 * infinite recursions.
1587 static scm_t_bits
**hell
;
1588 static long n_hell
= 1; /* one place for the evil one himself */
1589 static long hell_size
= 4;
1590 static SCM hell_mutex
;
1596 for (i
= 1; i
< n_hell
; ++i
)
1597 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1603 go_to_hell (void *o
)
1606 scm_lock_mutex (hell_mutex
);
1607 if (n_hell
>= hell_size
)
1610 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1612 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1613 scm_unlock_mutex (hell_mutex
);
1617 go_to_heaven (void *o
)
1620 scm_lock_mutex (hell_mutex
);
1621 hell
[burnin (obj
)] = hell
[--n_hell
];
1622 scm_unlock_mutex (hell_mutex
);
1626 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1629 purgatory (SCM obj
, SCM new_class
)
1631 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1634 /* This function calls the generic function change-class for all
1635 * instances which aren't currently undergoing class change.
1639 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1643 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1644 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1645 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1646 purgatory (obj
, new_class
);
1651 /******************************************************************************
1657 * GGG E N E R I C F U N C T I O N S
1659 * This implementation provides
1660 * - generic functions (with class specializers)
1663 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1665 ******************************************************************************/
1667 SCM_KEYWORD (k_name
, "name");
1669 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1672 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1674 make_dispatch_procedure (SCM gf
)
1676 static SCM var
= SCM_BOOL_F
;
1677 if (scm_is_false (var
))
1678 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1679 sym_delayed_compile
);
1680 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1684 clear_method_cache (SCM gf
)
1686 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1687 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1690 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1693 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1695 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1696 clear_method_cache (gf
);
1697 return SCM_UNSPECIFIED
;
1701 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1704 #define FUNC_NAME s_scm_generic_capability_p
1706 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1707 proc
, SCM_ARG1
, FUNC_NAME
);
1708 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1712 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1715 #define FUNC_NAME s_scm_enable_primitive_generic_x
1717 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1718 while (!scm_is_null (subrs
))
1720 SCM subr
= SCM_CAR (subrs
);
1721 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1722 SCM_SET_SUBR_GENERIC (subr
,
1723 scm_make (scm_list_3 (scm_class_generic
,
1725 SCM_SUBR_NAME (subr
))));
1726 subrs
= SCM_CDR (subrs
);
1728 return SCM_UNSPECIFIED
;
1732 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1733 (SCM subr
, SCM generic
),
1735 #define FUNC_NAME s_scm_set_primitive_generic_x
1737 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1738 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1739 SCM_SET_SUBR_GENERIC (subr
, generic
);
1740 return SCM_UNSPECIFIED
;
1744 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1747 #define FUNC_NAME s_scm_primitive_generic_generic
1749 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1751 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1752 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1753 return *SCM_SUBR_GENERIC (subr
);
1755 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1759 typedef struct t_extension
{
1760 struct t_extension
*next
;
1766 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1768 static const char extension_gc_hint
[] = "GOOPS extension";
1770 static t_extension
*extensions
= 0;
1773 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1778 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1779 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1780 gf
= *SCM_SUBR_GENERIC (extended
);
1781 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1783 SCM_SUBR_NAME (extension
));
1784 SCM_SET_SUBR_GENERIC (extension
, gext
);
1788 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1790 t_extension
**loc
= &extensions
;
1791 /* Make sure that extensions are placed before their own
1792 * extensions in the extensions list. O(N^2) algorithm, but
1793 * extensions of primitive generics are rare.
1795 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1796 loc
= &(*loc
)->next
;
1798 e
->extended
= extended
;
1799 e
->extension
= extension
;
1805 setup_extended_primitive_generics ()
1809 t_extension
*e
= extensions
;
1810 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1811 extensions
= e
->next
;
1815 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1816 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1817 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1821 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1823 if (!SCM_UNPACK (gf
))
1824 scm_error_num_args_subr (subr
);
1826 return scm_call_0 (gf
);
1830 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1832 if (!SCM_UNPACK (gf
))
1833 scm_wrong_type_arg (subr
, pos
, a1
);
1835 return scm_call_1 (gf
, a1
);
1839 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1841 if (!SCM_UNPACK (gf
))
1842 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1844 return scm_call_2 (gf
, a1
, a2
);
1848 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1850 if (!SCM_UNPACK (gf
))
1851 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1853 return scm_apply_0 (gf
, args
);
1856 /******************************************************************************
1858 * Protocol for calling a generic fumction
1859 * This protocol is roughly equivalent to (parameter are a little bit different
1860 * for efficiency reasons):
1862 * + apply-generic (gf args)
1863 * + compute-applicable-methods (gf args ...)
1864 * + sort-applicable-methods (methods args)
1865 * + apply-methods (gf methods args)
1867 * apply-methods calls make-next-method to build the "continuation" of a a
1868 * method. Applying a next-method will call apply-next-method which in
1869 * turn will call apply again to call effectively the following method.
1871 ******************************************************************************/
1874 applicablep (SCM actual
, SCM formal
)
1876 /* We already know that the cpl is well formed. */
1877 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1881 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1883 register SCM s1
, s2
;
1887 * m1 and m2 can have != length (i.e. one can be one element longer than the
1888 * other when we have a dotted parameter list). For instance, with the call
1891 * (define-method M (a . l) ....)
1892 * (define-method M (a) ....)
1894 * we consider that the second method is more specific.
1896 * BTW, targs is an array of types. We don't need it's size since
1897 * we already know that m1 and m2 are applicable (no risk to go past
1898 * the end of this array).
1901 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1902 if (scm_is_null(s1
)) return 1;
1903 if (scm_is_null(s2
)) return 0;
1904 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1905 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1907 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1908 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1910 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1913 return 0;/* should not occur! */
1916 return 0; /* should not occur! */
1919 #define BUFFSIZE 32 /* big enough for most uses */
1922 scm_i_vector2list (SCM l
, long len
)
1925 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1927 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1928 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1934 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1937 SCM
*v
, vector
= SCM_EOL
;
1938 SCM buffer
[BUFFSIZE
];
1939 SCM save
= method_list
;
1940 scm_t_array_handle handle
;
1942 /* For reasonably sized method_lists we can try to avoid all the
1943 * consing and reorder the list in place...
1944 * This idea is due to David McClain <Dave_McClain@msn.com>
1946 if (size
<= BUFFSIZE
)
1948 for (i
= 0; i
< size
; i
++)
1950 buffer
[i
] = SCM_CAR (method_list
);
1951 method_list
= SCM_CDR (method_list
);
1957 /* Too many elements in method_list to keep everything locally */
1958 vector
= scm_i_vector2list (save
, size
);
1959 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
1962 /* Use a simple shell sort since it is generally faster than qsort on
1963 * small vectors (which is probably mostly the case when we have to
1964 * sort a list of applicable methods).
1966 for (incr
= size
/ 2; incr
; incr
/= 2)
1968 for (i
= incr
; i
< size
; i
++)
1970 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1972 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1976 SCM tmp
= v
[j
+ incr
];
1984 if (size
<= BUFFSIZE
)
1986 /* We did it in locally, so restore the original list (reordered) in-place */
1987 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1989 SCM_SETCAR (method_list
, *v
);
1990 method_list
= SCM_CDR (method_list
);
1995 /* If we are here, that's that we did it the hard way... */
1996 scm_array_handle_release (&handle
);
1997 return scm_vector_to_list (vector
);
2001 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2005 SCM l
, fl
, applicable
= SCM_EOL
;
2007 SCM buffer
[BUFFSIZE
];
2011 scm_t_array_handle handle
;
2013 /* Build the list of arguments types */
2014 if (len
>= BUFFSIZE
)
2016 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2017 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2020 note that we don't have to work to reset the generation
2021 count. TMP is a new vector anyway, and it is found
2028 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2029 *p
++ = scm_class_of (SCM_CAR (args
));
2031 /* Build a list of all applicable methods */
2032 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2034 fl
= SPEC_OF (SCM_CAR (l
));
2035 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2037 if (SCM_INSTANCEP (fl
)
2038 /* We have a dotted argument list */
2039 || (i
>= len
&& scm_is_null (fl
)))
2040 { /* both list exhausted */
2041 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2047 || !applicablep (types
[i
], SCM_CAR (fl
)))
2052 if (len
>= BUFFSIZE
)
2053 scm_array_handle_release (&handle
);
2059 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2060 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2066 : sort_applicable_methods (applicable
, count
, types
));
2070 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2073 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2076 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2077 #define FUNC_NAME s_sys_compute_applicable_methods
2080 SCM_VALIDATE_GENERIC (1, gf
);
2081 n
= scm_ilength (args
);
2082 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2083 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2087 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2088 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2089 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2090 scm_sys_compute_applicable_methods
));
2092 /******************************************************************************
2094 * A simple make (which will be redefined later in Scheme)
2095 * This version handles only creation of gf, methods and classes (no instances)
2097 * Since this code will disappear when Goops will be fully booted,
2098 * no precaution is taken to be efficient.
2100 ******************************************************************************/
2102 SCM_KEYWORD (k_setter
, "setter");
2103 SCM_KEYWORD (k_specializers
, "specializers");
2104 SCM_KEYWORD (k_procedure
, "procedure");
2105 SCM_KEYWORD (k_formals
, "formals");
2106 SCM_KEYWORD (k_body
, "body");
2107 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2108 SCM_KEYWORD (k_dsupers
, "dsupers");
2109 SCM_KEYWORD (k_slots
, "slots");
2110 SCM_KEYWORD (k_gf
, "generic-function");
2112 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2114 "Make a new object. @var{args} must contain the class and\n"
2115 "all necessary initialization information.")
2116 #define FUNC_NAME s_scm_make
2119 long len
= scm_ilength (args
);
2121 if (len
<= 0 || (len
& 1) == 0)
2122 SCM_WRONG_NUM_ARGS ();
2124 class = SCM_CAR(args
);
2125 args
= SCM_CDR(args
);
2127 if (scm_is_eq (class, scm_class_generic
)
2128 || scm_is_eq (class, scm_class_accessor
))
2130 z
= scm_make_struct (class, SCM_INUM0
,
2131 scm_list_4 (SCM_BOOL_F
,
2135 scm_set_procedure_property_x (z
, scm_sym_name
,
2136 scm_get_keyword (k_name
,
2139 clear_method_cache (z
);
2140 if (scm_is_eq (class, scm_class_accessor
))
2142 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2143 if (scm_is_true (setter
))
2144 scm_sys_set_object_setter_x (z
, setter
);
2149 z
= scm_sys_allocate_instance (class, args
);
2151 if (scm_is_eq (class, scm_class_method
)
2152 || scm_is_eq (class, scm_class_accessor_method
))
2154 SCM_SET_SLOT (z
, scm_si_generic_function
,
2155 scm_i_get_keyword (k_gf
,
2160 SCM_SET_SLOT (z
, scm_si_specializers
,
2161 scm_i_get_keyword (k_specializers
,
2166 SCM_SET_SLOT (z
, scm_si_procedure
,
2167 scm_i_get_keyword (k_procedure
,
2172 SCM_SET_SLOT (z
, scm_si_formals
,
2173 scm_i_get_keyword (k_formals
,
2178 SCM_SET_SLOT (z
, scm_si_body
,
2179 scm_i_get_keyword (k_body
,
2184 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2185 scm_i_get_keyword (k_make_procedure
,
2193 /* In all the others case, make a new class .... No instance here */
2194 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2195 scm_i_get_keyword (k_name
,
2198 scm_from_latin1_symbol ("???"),
2200 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2201 scm_i_get_keyword (k_dsupers
,
2206 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2207 scm_i_get_keyword (k_slots
,
2218 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2221 #define FUNC_NAME s_scm_find_method
2224 long len
= scm_ilength (l
);
2227 SCM_WRONG_NUM_ARGS ();
2229 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2230 SCM_VALIDATE_GENERIC (1, gf
);
2231 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2232 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2234 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2238 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2239 (SCM m1
, SCM m2
, SCM targs
),
2240 "Return true if method @var{m1} is more specific than @var{m2} "
2241 "given the argument types (classes) listed in @var{targs}.")
2242 #define FUNC_NAME s_scm_sys_method_more_specific_p
2246 long i
, len
, m1_specs
, m2_specs
;
2247 scm_t_array_handle handle
;
2249 SCM_VALIDATE_METHOD (1, m1
);
2250 SCM_VALIDATE_METHOD (2, m2
);
2252 len
= scm_ilength (targs
);
2253 m1_specs
= scm_ilength (SPEC_OF (m1
));
2254 m2_specs
= scm_ilength (SPEC_OF (m2
));
2255 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2256 targs
, SCM_ARG3
, FUNC_NAME
);
2258 /* Verify that all the arguments of TARGS are classes and place them
2261 v
= scm_c_make_vector (len
, SCM_EOL
);
2262 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2264 for (i
= 0, l
= targs
;
2265 i
< len
&& scm_is_pair (l
);
2266 i
++, l
= SCM_CDR (l
))
2268 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2269 v_elts
[i
] = SCM_CAR (l
);
2271 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2273 scm_array_handle_release (&handle
);
2281 /******************************************************************************
2285 ******************************************************************************/
2287 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2288 assuming that currently the reverse is true. Recalculate slots and
2289 associated getters-n-setters. */
2291 fix_cpl (SCM c
, SCM before
, SCM after
)
2293 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2294 SCM ls
= scm_c_memq (after
, cpl
);
2297 if (scm_is_false (ls
))
2298 /* if this condition occurs, fix_cpl should not be applied this way */
2301 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2302 SCM_SETCAR (ls
, before
);
2303 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2305 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2306 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2307 SCM g_n_s
= compute_getters_n_setters (slots
);
2308 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2309 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2315 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2317 SCM tmp
= scm_from_locale_symbol (name
);
2319 *var
= scm_basic_make_class (meta
, tmp
,
2320 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2322 scm_module_define (scm_module_goops
, tmp
, *var
);
2326 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2329 create_standard_classes (void)
2332 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2333 scm_from_latin1_symbol ("specializers"),
2335 scm_from_latin1_symbol ("formals"),
2336 scm_from_latin1_symbol ("body"),
2337 scm_from_latin1_symbol ("make-procedure"),
2339 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2341 k_slot_definition
));
2342 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2343 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2346 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2349 scm_from_latin1_symbol ("effective-methods"));
2350 SCM setter_slots
= scm_list_1 (sym_setter
);
2351 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2354 /* Foreign class slot classes */
2355 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2356 scm_class_class
, scm_class_top
, SCM_EOL
);
2357 make_stdcls (&scm_class_protected
, "<protected-slot>",
2358 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2359 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2360 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2361 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2362 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2363 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2364 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2365 make_stdcls (&scm_class_self
, "<self-slot>",
2366 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2367 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2369 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2371 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2373 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2375 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2377 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2379 make_stdcls (&scm_class_scm
, "<scm-slot>",
2380 scm_class_class
, scm_class_protected
, SCM_EOL
);
2381 make_stdcls (&scm_class_int
, "<int-slot>",
2382 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2383 make_stdcls (&scm_class_float
, "<float-slot>",
2384 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2385 make_stdcls (&scm_class_double
, "<double-slot>",
2386 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2388 /* Continue initialization of class <class> */
2390 slots
= build_class_class_slots ();
2391 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2392 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2393 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2394 compute_getters_n_setters (slots
));
2396 /* scm_class_generic functions classes */
2397 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2398 scm_class_class
, scm_class_class
, SCM_EOL
);
2399 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2400 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2401 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2402 make_stdcls (&scm_class_method
, "<method>",
2403 scm_class_class
, scm_class_object
, method_slots
);
2404 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2405 scm_class_class
, scm_class_method
, amethod_slots
);
2406 make_stdcls (&scm_class_applicable
, "<applicable>",
2407 scm_class_class
, scm_class_top
, SCM_EOL
);
2408 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2409 scm_class_applicable_struct_class
,
2410 scm_list_2 (scm_class_object
, scm_class_applicable
),
2411 scm_list_1 (sym_procedure
));
2412 make_stdcls (&scm_class_generic
, "<generic>",
2413 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2414 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2415 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2416 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2417 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2418 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2419 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2420 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2421 make_stdcls (&scm_class_accessor
, "<accessor>",
2422 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2423 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2424 make_stdcls (&scm_class_extended_generic_with_setter
,
2425 "<extended-generic-with-setter>",
2426 scm_class_applicable_struct_class
,
2427 scm_list_2 (scm_class_extended_generic
,
2428 scm_class_generic_with_setter
),
2430 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2431 SCM_CLASSF_PURE_GENERIC
);
2432 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2433 scm_class_applicable_struct_class
,
2434 scm_list_2 (scm_class_accessor
,
2435 scm_class_extended_generic_with_setter
),
2437 /* <extended-generic> is misplaced. */
2438 fix_cpl (scm_class_extended_accessor
,
2439 scm_class_extended_generic
, scm_class_generic_with_setter
);
2440 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2442 /* Primitive types classes */
2443 make_stdcls (&scm_class_boolean
, "<boolean>",
2444 scm_class_class
, scm_class_top
, SCM_EOL
);
2445 make_stdcls (&scm_class_char
, "<char>",
2446 scm_class_class
, scm_class_top
, SCM_EOL
);
2447 make_stdcls (&scm_class_list
, "<list>",
2448 scm_class_class
, scm_class_top
, SCM_EOL
);
2449 make_stdcls (&scm_class_pair
, "<pair>",
2450 scm_class_class
, scm_class_list
, SCM_EOL
);
2451 make_stdcls (&scm_class_null
, "<null>",
2452 scm_class_class
, scm_class_list
, SCM_EOL
);
2453 make_stdcls (&scm_class_string
, "<string>",
2454 scm_class_class
, scm_class_top
, SCM_EOL
);
2455 make_stdcls (&scm_class_symbol
, "<symbol>",
2456 scm_class_class
, scm_class_top
, SCM_EOL
);
2457 make_stdcls (&scm_class_vector
, "<vector>",
2458 scm_class_class
, scm_class_top
, SCM_EOL
);
2459 make_stdcls (&class_foreign
, "<foreign>",
2460 scm_class_class
, scm_class_top
, SCM_EOL
);
2461 make_stdcls (&class_hashtable
, "<hashtable>",
2462 scm_class_class
, scm_class_top
, SCM_EOL
);
2463 make_stdcls (&class_fluid
, "<fluid>",
2464 scm_class_class
, scm_class_top
, SCM_EOL
);
2465 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2466 scm_class_class
, scm_class_top
, SCM_EOL
);
2467 make_stdcls (&class_frame
, "<frame>",
2468 scm_class_class
, scm_class_top
, SCM_EOL
);
2469 make_stdcls (&class_objcode
, "<objcode>",
2470 scm_class_class
, scm_class_top
, SCM_EOL
);
2471 make_stdcls (&class_vm
, "<vm>",
2472 scm_class_class
, scm_class_top
, SCM_EOL
);
2473 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2474 scm_class_class
, scm_class_top
, SCM_EOL
);
2475 make_stdcls (&class_bytevector
, "<bytevector>",
2476 scm_class_class
, scm_class_top
, SCM_EOL
);
2477 make_stdcls (&class_uvec
, "<uvec>",
2478 scm_class_class
, class_bytevector
, SCM_EOL
);
2479 make_stdcls (&scm_class_number
, "<number>",
2480 scm_class_class
, scm_class_top
, SCM_EOL
);
2481 make_stdcls (&scm_class_complex
, "<complex>",
2482 scm_class_class
, scm_class_number
, SCM_EOL
);
2483 make_stdcls (&scm_class_real
, "<real>",
2484 scm_class_class
, scm_class_complex
, SCM_EOL
);
2485 make_stdcls (&scm_class_integer
, "<integer>",
2486 scm_class_class
, scm_class_real
, SCM_EOL
);
2487 make_stdcls (&scm_class_fraction
, "<fraction>",
2488 scm_class_class
, scm_class_real
, SCM_EOL
);
2489 make_stdcls (&scm_class_keyword
, "<keyword>",
2490 scm_class_class
, scm_class_top
, SCM_EOL
);
2491 make_stdcls (&scm_class_unknown
, "<unknown>",
2492 scm_class_class
, scm_class_top
, SCM_EOL
);
2493 make_stdcls (&scm_class_procedure
, "<procedure>",
2494 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2495 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2496 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2497 make_stdcls (&scm_class_port
, "<port>",
2498 scm_class_class
, scm_class_top
, SCM_EOL
);
2499 make_stdcls (&scm_class_input_port
, "<input-port>",
2500 scm_class_class
, scm_class_port
, SCM_EOL
);
2501 make_stdcls (&scm_class_output_port
, "<output-port>",
2502 scm_class_class
, scm_class_port
, SCM_EOL
);
2503 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2505 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2509 /**********************************************************************
2513 **********************************************************************/
2516 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2522 sprintf (buffer
, template, type_name
);
2523 name
= scm_from_locale_symbol (buffer
);
2526 name
= SCM_GOOPS_UNBOUND
;
2528 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2529 name
, supers
, SCM_EOL
);
2533 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2537 if (scm_is_true (type_name_sym
))
2539 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2540 scm_symbol_to_string (type_name_sym
),
2541 scm_from_locale_string (">")));
2542 name
= scm_string_to_symbol (name
);
2545 name
= SCM_GOOPS_UNBOUND
;
2547 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2548 name
, supers
, SCM_EOL
);
2552 scm_make_extended_class (char const *type_name
, int applicablep
)
2554 return make_class_from_template ("<%s>",
2556 scm_list_1 (applicablep
2557 ? scm_class_applicable
2563 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2565 return make_class_from_symbol (type_name_sym
,
2566 scm_list_1 (applicablep
2567 ? scm_class_applicable
2573 scm_i_inherit_applicable (SCM c
)
2575 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2577 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2578 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2579 /* patch scm_class_applicable into direct-supers */
2580 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2581 if (scm_is_false (top
))
2582 dsupers
= scm_append (scm_list_2 (dsupers
,
2583 scm_list_1 (scm_class_applicable
)));
2586 SCM_SETCAR (top
, scm_class_applicable
);
2587 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2589 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2590 /* patch scm_class_applicable into cpl */
2591 top
= scm_c_memq (scm_class_top
, cpl
);
2592 if (scm_is_false (top
))
2596 SCM_SETCAR (top
, scm_class_applicable
);
2597 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2599 /* add class to direct-subclasses of scm_class_applicable */
2600 SCM_SET_SLOT (scm_class_applicable
,
2601 scm_si_direct_subclasses
,
2602 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2603 scm_si_direct_subclasses
)));
2608 create_smob_classes (void)
2612 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2613 scm_smob_class
[i
] = SCM_BOOL_F
;
2615 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2617 for (i
= 0; i
< scm_numsmob
; ++i
)
2618 if (scm_is_false (scm_smob_class
[i
]))
2619 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2620 scm_smobs
[i
].apply
!= 0);
2624 scm_make_port_classes (long ptobnum
, char *type_name
)
2626 SCM c
, class = make_class_from_template ("<%s-port>",
2628 scm_list_1 (scm_class_port
),
2630 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2631 = make_class_from_template ("<%s-input-port>",
2633 scm_list_2 (class, scm_class_input_port
),
2635 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2636 = make_class_from_template ("<%s-output-port>",
2638 scm_list_2 (class, scm_class_output_port
),
2640 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2642 = make_class_from_template ("<%s-input-output-port>",
2644 scm_list_2 (class, scm_class_input_output_port
),
2646 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2647 SCM_SET_SLOT (c
, scm_si_cpl
,
2648 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2652 create_port_classes (void)
2656 for (i
= 0; i
< scm_numptob
; ++i
)
2657 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2661 make_struct_class (void *closure SCM_UNUSED
,
2662 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2664 if (scm_is_false (data
))
2665 scm_i_define_class_for_vtable (vtable
);
2666 return SCM_UNSPECIFIED
;
2670 create_struct_classes (void)
2672 /* FIXME: take the vtable_class_map while initializing goops? */
2673 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2677 /**********************************************************************
2681 **********************************************************************/
2686 if (!goops_loaded_p
)
2687 scm_c_resolve_module ("oop goops");
2691 SCM_SYMBOL (sym_o
, "o");
2692 SCM_SYMBOL (sym_x
, "x");
2694 SCM_KEYWORD (k_accessor
, "accessor");
2695 SCM_KEYWORD (k_getter
, "getter");
2698 scm_ensure_accessor (SCM name
)
2700 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2701 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2703 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2704 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2705 k_name
, name
, k_setter
, gf
));
2712 * Debugging utilities
2715 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2717 "Return @code{#t} if @var{obj} is a pure generic.")
2718 #define FUNC_NAME s_scm_pure_generic_p
2720 return scm_from_bool (SCM_PUREGENERICP (obj
));
2724 #endif /* GUILE_DEBUG */
2730 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2732 "Announce that GOOPS is loaded and perform initialization\n"
2733 "on the C level which depends on the loaded GOOPS modules.")
2734 #define FUNC_NAME s_scm_sys_goops_loaded
2737 var_compute_applicable_methods
=
2738 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2740 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2742 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2744 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2745 var_no_applicable_method
=
2746 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2748 scm_module_variable (scm_module_goops
, sym_change_class
);
2749 setup_extended_primitive_generics ();
2750 return SCM_UNSPECIFIED
;
2754 SCM scm_module_goops
;
2757 scm_init_goops_builtins (void)
2759 scm_module_goops
= scm_current_module ();
2761 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2763 #include "libguile/goops.x"
2765 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2766 hell_mutex
= scm_make_mutex ();
2768 create_basic_classes ();
2769 create_standard_classes ();
2770 create_smob_classes ();
2771 create_struct_classes ();
2772 create_port_classes ();
2775 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2776 scm_no_applicable_method
=
2777 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2778 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2781 return SCM_UNSPECIFIED
;
2787 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2788 scm_init_goops_builtins
);