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/vm.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
61 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
64 #define SCM_IN_PCLASS_INDEX 0
65 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
66 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
68 /* this file is a mess. in theory, though, we shouldn't have many SCM references
69 -- most of the references should be to vars. */
71 static SCM var_slot_unbound
= SCM_BOOL_F
;
72 static SCM var_slot_missing
= SCM_BOOL_F
;
73 static SCM var_compute_cpl
= SCM_BOOL_F
;
74 static SCM var_no_applicable_method
= SCM_BOOL_F
;
75 static SCM var_change_class
= SCM_BOOL_F
;
77 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
78 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
79 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
80 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
81 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
82 SCM_SYMBOL (sym_change_class
, "change-class");
84 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
87 /* Class redefinition protocol:
89 A class is represented by a heap header h1 which points to a
90 malloc:ed memory block m1.
92 When a new version of a class is created, a new header h2 and
93 memory block m2 are allocated. The headers h1 and h2 then switch
94 pointers so that h1 refers to m2 and h2 to m1. In this way, names
95 bound to h1 will point to the new class at the same time as h2 will
96 be a handle which the GC will use to free m1.
98 The `redefined' slot of m1 will be set to point to h1. An old
99 instance will have its class pointer (the CAR of the heap header)
100 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
101 the class modification and the new class pointer can be found via
105 #define TEST_CHANGE_CLASS(obj, class) \
107 class = SCM_CLASS_OF (obj); \
108 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
110 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
111 class = SCM_CLASS_OF (obj); \
115 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
116 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
118 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
119 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
121 static int goops_loaded_p
= 0;
122 static scm_t_rstate
*goops_rstate
;
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_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_applicable_struct
, scm_class_applicable_struct_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_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_applicable_struct_class
;
142 SCM scm_class_number
, scm_class_list
;
143 SCM scm_class_keyword
;
144 SCM scm_class_port
, scm_class_input_output_port
;
145 SCM scm_class_input_port
, scm_class_output_port
;
146 SCM scm_class_foreign_slot
;
147 SCM scm_class_self
, scm_class_protected
;
148 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
149 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
151 SCM scm_class_int
, scm_class_float
, scm_class_double
;
153 static SCM class_foreign
;
154 static SCM class_hashtable
;
155 static SCM class_fluid
;
156 static SCM class_dynamic_state
;
157 static SCM class_frame
;
158 static SCM class_objcode
;
160 static SCM class_vm_cont
;
161 static SCM class_bytevector
;
162 static SCM class_uvec
;
164 static SCM vtable_class_map
= SCM_BOOL_F
;
166 /* Port classes. Allocate 3 times the maximum number of port types so that
167 input ports, output ports, and in/out ports can be stored at different
168 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
169 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
172 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
174 SCM scm_no_applicable_method
;
176 SCM_SYMBOL (scm_sym_define_public
, "define-public");
178 static SCM
scm_make_unbound (void);
179 static SCM
scm_unbound_p (SCM obj
);
180 static SCM
scm_assert_bound (SCM value
, SCM obj
);
181 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
182 static SCM
scm_sys_goops_loaded (void);
183 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
188 scm_i_define_class_for_vtable (SCM vtable
)
192 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
193 if (scm_is_false (vtable_class_map
))
194 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
195 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
197 if (scm_is_false (scm_struct_vtable_p (vtable
)))
200 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
202 if (scm_is_false (class))
204 if (SCM_UNPACK (scm_class_class
))
206 SCM name
= SCM_VTABLE_NAME (vtable
);
207 if (!scm_is_symbol (name
))
208 name
= scm_string_to_symbol (scm_nullstr
);
210 class = scm_make_extended_class_from_symbol
211 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
214 /* `create_struct_classes' will fill this in later. */
217 /* Don't worry about races. This only happens when creating a
218 vtable, which happens by definition in one thread. */
219 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
225 /* This function is used for efficient type dispatch. */
226 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
228 "Return the class of @var{x}.")
229 #define FUNC_NAME s_scm_class_of
231 switch (SCM_ITAG3 (x
))
235 return scm_class_integer
;
239 return scm_class_char
;
240 else if (scm_is_bool (x
))
241 return scm_class_boolean
;
242 else if (scm_is_null (x
))
243 return scm_class_null
;
245 return scm_class_unknown
;
248 switch (SCM_TYP7 (x
))
250 case scm_tcs_cons_nimcar
:
251 return scm_class_pair
;
253 return scm_class_symbol
;
256 return scm_class_vector
;
257 case scm_tc7_pointer
:
258 return class_foreign
;
259 case scm_tc7_hashtable
:
260 return class_hashtable
;
263 case scm_tc7_dynamic_state
:
264 return class_dynamic_state
;
267 case scm_tc7_objcode
:
268 return class_objcode
;
271 case scm_tc7_vm_cont
:
272 return class_vm_cont
;
273 case scm_tc7_bytevector
:
274 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
275 return class_bytevector
;
279 return scm_class_string
;
281 switch SCM_TYP16 (x
) {
283 return scm_class_integer
;
285 return scm_class_real
;
286 case scm_tc16_complex
:
287 return scm_class_complex
;
288 case scm_tc16_fraction
:
289 return scm_class_fraction
;
291 case scm_tc7_program
:
292 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
293 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
294 return scm_class_primitive_generic
;
296 return scm_class_procedure
;
300 scm_t_bits type
= SCM_TYP16 (x
);
301 if (type
!= scm_tc16_port_with_ps
)
302 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
303 x
= SCM_PORT_WITH_PS_PORT (x
);
304 /* fall through to ports */
307 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
308 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
309 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
310 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
311 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
313 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
314 return SCM_CLASS_OF (x
);
315 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
318 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
319 scm_change_object_class (x
,
320 SCM_CLASS_OF (x
), /* old */
321 SCM_OBJ_CLASS_REDEF (x
)); /* new */
322 return SCM_CLASS_OF (x
);
325 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
328 return scm_class_pair
;
330 return scm_class_unknown
;
336 /* case scm_tc3_unused: */
340 return scm_class_unknown
;
344 /******************************************************************************
348 * This version doesn't fully handle multiple-inheritance. It serves
349 * only for booting classes and will be overloaded in Scheme
351 ******************************************************************************/
354 map (SCM (*proc
) (SCM
), SCM ls
)
356 if (scm_is_null (ls
))
360 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
363 while (!scm_is_null (ls
))
365 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
377 while (!scm_is_null (ls
))
379 SCM el
= SCM_CAR (ls
);
380 if (scm_is_false (scm_c_memq (el
, res
)))
381 res
= scm_cons (el
, res
);
388 compute_cpl (SCM
class)
391 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
394 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
395 SCM ls
= scm_append (scm_acons (class, supers
,
396 map (compute_cpl
, supers
)));
397 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
401 /******************************************************************************
405 ******************************************************************************/
408 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
416 if (!scm_is_symbol (tmp
))
417 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
419 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
420 res
= scm_cons (SCM_CAR (l
), res
);
421 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
424 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
428 build_slots_list (SCM dslots
, SCM cpl
)
430 register SCM res
= dslots
;
432 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
433 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
434 scm_si_direct_slots
),
437 /* res contains a list of slots. Remove slots which appears more than once */
438 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
445 while (!scm_is_null (ls
))
447 if (!scm_is_pair (SCM_CAR (ls
)))
448 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
455 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
457 "Return a list consisting of the names of all slots belonging to\n"
458 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
460 #define FUNC_NAME s_scm_sys_compute_slots
462 SCM_VALIDATE_CLASS (1, class);
463 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
464 SCM_SLOT (class, scm_si_cpl
));
469 /******************************************************************************
471 * compute-getters-n-setters
473 * This version doesn't handle slot options. It serves only for booting
474 * classes and will be overloaded in Scheme.
476 ******************************************************************************/
478 SCM_KEYWORD (k_init_value
, "init-value");
479 SCM_KEYWORD (k_init_thunk
, "init-thunk");
482 compute_getters_n_setters (SCM slots
)
488 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
490 SCM init
= SCM_BOOL_F
;
491 SCM options
= SCM_CDAR (slots
);
492 if (!scm_is_null (options
))
494 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
495 if (SCM_UNPACK (init
))
497 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
499 scm_list_2 (scm_sym_quote
,
503 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
505 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
507 scm_from_int (i
++))),
509 cdrloc
= SCM_CDRLOC (*cdrloc
);
514 /******************************************************************************
518 ******************************************************************************/
520 /*fixme* Manufacture keywords in advance */
522 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
526 for (i
= 0; i
!= len
; i
+= 2)
528 SCM obj
= SCM_CAR (l
);
530 if (!scm_is_keyword (obj
))
531 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
532 else if (scm_is_eq (obj
, key
))
538 return default_value
;
542 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
543 (SCM key
, SCM l
, SCM default_value
),
544 "Determine an associated value for the keyword @var{key} from\n"
545 "the list @var{l}. The list @var{l} has to consist of an even\n"
546 "number of elements, where, starting with the first, every\n"
547 "second element is a keyword, followed by its associated value.\n"
548 "If @var{l} does not hold a value for @var{key}, the value\n"
549 "@var{default_value} is returned.")
550 #define FUNC_NAME s_scm_get_keyword
554 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
555 len
= scm_ilength (l
);
556 if (len
< 0 || len
% 2 == 1)
557 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
559 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
564 SCM_KEYWORD (k_init_keyword
, "init-keyword");
566 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
567 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
569 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
570 (SCM obj
, SCM initargs
),
571 "Initialize the object @var{obj} with the given arguments\n"
573 #define FUNC_NAME s_scm_sys_initialize_object
575 SCM tmp
, get_n_set
, slots
;
576 SCM
class = SCM_CLASS_OF (obj
);
579 SCM_VALIDATE_INSTANCE (1, obj
);
580 n_initargs
= scm_ilength (initargs
);
581 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
583 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
584 slots
= SCM_SLOT (class, scm_si_slots
);
586 /* See for each slot how it must be initialized */
588 !scm_is_null (slots
);
589 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
591 SCM slot_name
= SCM_CAR (slots
);
592 SCM slot_value
= SCM_PACK (0);
594 if (!scm_is_null (SCM_CDR (slot_name
)))
596 /* This slot admits (perhaps) to be initialized at creation time */
597 long n
= scm_ilength (SCM_CDR (slot_name
));
598 if (n
& 1) /* odd or -1 */
599 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
600 scm_list_1 (slot_name
));
601 tmp
= scm_i_get_keyword (k_init_keyword
,
606 slot_name
= SCM_CAR (slot_name
);
607 if (SCM_UNPACK (tmp
))
609 /* an initarg was provided for this slot */
610 if (!scm_is_keyword (tmp
))
611 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
613 slot_value
= scm_i_get_keyword (tmp
,
621 if (SCM_UNPACK (slot_value
))
622 /* set slot to provided value */
623 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
626 /* set slot to its :init-form if it exists */
627 tmp
= SCM_CADAR (get_n_set
);
628 if (scm_is_true (tmp
))
630 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
631 if (SCM_GOOPS_UNBOUNDP (slot_value
))
632 set_slot_value (class,
644 /* NOTE: The following macros are interdependent with code
645 * in goops.scm:compute-getters-n-setters
647 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
648 (SCM_I_INUMP (SCM_CDDR (gns)) \
649 || (scm_is_pair (SCM_CDDR (gns)) \
650 && scm_is_pair (SCM_CDDDR (gns)) \
651 && scm_is_pair (SCM_CDDDDR (gns))))
652 #define SCM_GNS_INDEX(gns) \
653 (SCM_I_INUMP (SCM_CDDR (gns)) \
654 ? SCM_I_INUM (SCM_CDDR (gns)) \
655 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
656 #define SCM_GNS_SIZE(gns) \
657 (SCM_I_INUMP (SCM_CDDR (gns)) \
659 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
661 SCM_KEYWORD (k_class
, "class");
662 SCM_KEYWORD (k_allocation
, "allocation");
663 SCM_KEYWORD (k_instance
, "instance");
665 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
668 #define FUNC_NAME s_scm_sys_prep_layout_x
670 SCM slots
, getters_n_setters
, nfields
;
671 unsigned long int n
, i
;
675 SCM_VALIDATE_INSTANCE (1, class);
676 slots
= SCM_SLOT (class, scm_si_slots
);
677 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
678 nfields
= SCM_SLOT (class, scm_si_nfields
);
679 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
680 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
681 scm_list_1 (nfields
));
682 n
= 2 * SCM_I_INUM (nfields
);
683 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
684 && SCM_SUBCLASSP (class, scm_class_class
))
685 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
686 scm_list_1 (nfields
));
688 layout
= scm_i_make_string (n
, &s
, 0);
690 while (scm_is_pair (getters_n_setters
))
692 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
695 int len
, index
, size
;
698 if (i
>= n
|| !scm_is_pair (slots
))
701 /* extract slot type */
702 len
= scm_ilength (SCM_CDAR (slots
));
703 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
704 len
, SCM_BOOL_F
, FUNC_NAME
);
705 /* determine slot GC protection and access mode */
706 if (scm_is_false (type
))
713 if (!SCM_CLASSP (type
))
714 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
715 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
717 if (SCM_SUBCLASSP (type
, scm_class_self
))
719 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
724 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
726 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
728 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
740 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
741 if (index
!= (i
>> 1))
743 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
751 slots
= SCM_CDR (slots
);
752 getters_n_setters
= SCM_CDR (getters_n_setters
);
754 if (!scm_is_null (slots
))
757 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
759 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
760 return SCM_UNSPECIFIED
;
764 static void prep_hashsets (SCM
);
766 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
767 (SCM
class, SCM dsupers
),
769 #define FUNC_NAME s_scm_sys_inherit_magic_x
771 SCM_VALIDATE_INSTANCE (1, class);
772 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
773 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
775 prep_hashsets (class);
777 return SCM_UNSPECIFIED
;
782 prep_hashsets (SCM
class)
786 for (i
= 0; i
< 8; ++i
)
787 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
790 /******************************************************************************/
793 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
795 SCM z
, cpl
, slots
, nfields
, g_n_s
;
797 /* Allocate one instance */
798 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
800 /* Initialize its slots */
801 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
802 cpl
= compute_cpl (z
);
803 slots
= build_slots_list (maplist (dslots
), cpl
);
804 nfields
= scm_from_int (scm_ilength (slots
));
805 g_n_s
= compute_getters_n_setters (slots
);
807 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
808 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
809 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
810 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
811 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
812 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
813 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
814 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
815 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
817 /* Add this class in the direct-subclasses slot of dsupers */
820 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
821 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
822 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
823 scm_si_direct_subclasses
)));
830 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
832 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
833 scm_sys_prep_layout_x (z
);
834 scm_sys_inherit_magic_x (z
, dsupers
);
838 /******************************************************************************/
840 SCM_SYMBOL (sym_layout
, "layout");
841 SCM_SYMBOL (sym_flags
, "flags");
842 SCM_SYMBOL (sym_self
, "%self");
843 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
844 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
845 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
846 SCM_SYMBOL (sym_print
, "print");
847 SCM_SYMBOL (sym_procedure
, "procedure");
848 SCM_SYMBOL (sym_setter
, "setter");
849 SCM_SYMBOL (sym_redefined
, "redefined");
850 SCM_SYMBOL (sym_h0
, "h0");
851 SCM_SYMBOL (sym_h1
, "h1");
852 SCM_SYMBOL (sym_h2
, "h2");
853 SCM_SYMBOL (sym_h3
, "h3");
854 SCM_SYMBOL (sym_h4
, "h4");
855 SCM_SYMBOL (sym_h5
, "h5");
856 SCM_SYMBOL (sym_h6
, "h6");
857 SCM_SYMBOL (sym_h7
, "h7");
858 SCM_SYMBOL (sym_name
, "name");
859 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
860 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
861 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
862 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
863 SCM_SYMBOL (sym_cpl
, "cpl");
864 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
865 SCM_SYMBOL (sym_slots
, "slots");
866 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
867 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
868 SCM_SYMBOL (sym_nfields
, "nfields");
872 build_class_class_slots ()
874 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
875 SCM_CLASS_CLASS_LAYOUT */
877 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
878 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
879 scm_list_3 (sym_self
, k_class
, scm_class_self
),
880 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
881 scm_list_1 (sym_print
),
882 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
883 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
884 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
885 scm_list_1 (sym_redefined
),
886 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
887 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
888 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
889 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
890 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
891 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
892 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
893 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
894 scm_list_1 (sym_direct_supers
),
895 scm_list_1 (sym_direct_slots
),
896 scm_list_1 (sym_direct_subclasses
),
897 scm_list_1 (sym_direct_methods
),
898 scm_list_1 (sym_cpl
),
899 scm_list_1 (sym_default_slot_definition_class
),
900 scm_list_1 (sym_slots
),
901 scm_list_1 (sym_getters_n_setters
),
902 scm_list_1 (sym_keyword_access
),
903 scm_list_1 (sym_nfields
),
908 create_basic_classes (void)
910 /* SCM slots_of_class = build_class_class_slots (); */
913 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
914 SCM name
= scm_from_latin1_symbol ("<class>");
915 scm_class_class
= scm_make_vtable_vtable (cs
, SCM_INUM0
, SCM_EOL
);
916 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
917 | SCM_CLASSF_METACLASS
));
919 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
920 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
921 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
922 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
923 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
924 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
925 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
926 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
927 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
928 compute_getters_n_setters (slots_of_class)); */
929 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
931 prep_hashsets (scm_class_class
);
933 scm_module_define (scm_module_goops
, name
, scm_class_class
);
936 name
= scm_from_latin1_symbol ("<top>");
937 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
940 scm_module_define (scm_module_goops
, name
, scm_class_top
);
943 name
= scm_from_latin1_symbol ("<object>");
944 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
945 scm_list_1 (scm_class_top
), SCM_EOL
);
947 scm_module_define (scm_module_goops
, name
, scm_class_object
);
949 /* <top> <object> and <class> were partially initialized. Correct them here */
950 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
952 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
953 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
956 /******************************************************************************/
958 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
960 "Return @code{#t} if @var{obj} is an instance.")
961 #define FUNC_NAME s_scm_instance_p
963 return scm_from_bool (SCM_INSTANCEP (obj
));
968 /******************************************************************************
970 * Meta object accessors
972 ******************************************************************************/
973 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
975 "Return the class name of @var{obj}.")
976 #define FUNC_NAME s_scm_class_name
978 SCM_VALIDATE_CLASS (1, obj
);
979 return scm_slot_ref (obj
, sym_name
);
983 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
985 "Return the direct superclasses of the class @var{obj}.")
986 #define FUNC_NAME s_scm_class_direct_supers
988 SCM_VALIDATE_CLASS (1, obj
);
989 return scm_slot_ref (obj
, sym_direct_supers
);
993 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
995 "Return the direct slots of the class @var{obj}.")
996 #define FUNC_NAME s_scm_class_direct_slots
998 SCM_VALIDATE_CLASS (1, obj
);
999 return scm_slot_ref (obj
, sym_direct_slots
);
1003 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1005 "Return the direct subclasses of the class @var{obj}.")
1006 #define FUNC_NAME s_scm_class_direct_subclasses
1008 SCM_VALIDATE_CLASS (1, obj
);
1009 return scm_slot_ref(obj
, sym_direct_subclasses
);
1013 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1015 "Return the direct methods of the class @var{obj}")
1016 #define FUNC_NAME s_scm_class_direct_methods
1018 SCM_VALIDATE_CLASS (1, obj
);
1019 return scm_slot_ref (obj
, sym_direct_methods
);
1023 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1025 "Return the class precedence list of the class @var{obj}.")
1026 #define FUNC_NAME s_scm_class_precedence_list
1028 SCM_VALIDATE_CLASS (1, obj
);
1029 return scm_slot_ref (obj
, sym_cpl
);
1033 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1035 "Return the slot list of the class @var{obj}.")
1036 #define FUNC_NAME s_scm_class_slots
1038 SCM_VALIDATE_CLASS (1, obj
);
1039 return scm_slot_ref (obj
, sym_slots
);
1043 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1045 "Return the name of the generic function @var{obj}.")
1046 #define FUNC_NAME s_scm_generic_function_name
1048 SCM_VALIDATE_GENERIC (1, obj
);
1049 return scm_procedure_property (obj
, scm_sym_name
);
1053 SCM_SYMBOL (sym_methods
, "methods");
1054 SCM_SYMBOL (sym_extended_by
, "extended-by");
1055 SCM_SYMBOL (sym_extends
, "extends");
1058 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1060 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1061 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1062 while (!scm_is_null (gfs
))
1064 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1065 gfs
= SCM_CDR (gfs
);
1067 return method_lists
;
1071 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1073 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1075 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1076 while (!scm_is_null (gfs
))
1078 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1079 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1082 gfs
= SCM_CDR (gfs
);
1085 return method_lists
;
1088 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1090 "Return the methods of the generic function @var{obj}.")
1091 #define FUNC_NAME s_scm_generic_function_methods
1094 SCM_VALIDATE_GENERIC (1, obj
);
1095 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1096 methods
= fold_downward_gf_methods (methods
, obj
);
1097 return scm_append (methods
);
1101 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1103 "Return the generic function for the method @var{obj}.")
1104 #define FUNC_NAME s_scm_method_generic_function
1106 SCM_VALIDATE_METHOD (1, obj
);
1107 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1111 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1113 "Return specializers of the method @var{obj}.")
1114 #define FUNC_NAME s_scm_method_specializers
1116 SCM_VALIDATE_METHOD (1, obj
);
1117 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1121 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1123 "Return the procedure of the method @var{obj}.")
1124 #define FUNC_NAME s_scm_method_procedure
1126 SCM_VALIDATE_METHOD (1, obj
);
1127 return scm_slot_ref (obj
, sym_procedure
);
1131 /******************************************************************************
1133 * S l o t a c c e s s
1135 ******************************************************************************/
1137 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1139 "Return the unbound value.")
1140 #define FUNC_NAME s_scm_make_unbound
1142 return SCM_GOOPS_UNBOUND
;
1146 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1148 "Return @code{#t} if @var{obj} is unbound.")
1149 #define FUNC_NAME s_scm_unbound_p
1151 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1155 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1156 (SCM value
, SCM obj
),
1157 "Return @var{value} if it is bound, and invoke the\n"
1158 "@var{slot-unbound} method of @var{obj} if it is not.")
1159 #define FUNC_NAME s_scm_assert_bound
1161 if (SCM_GOOPS_UNBOUNDP (value
))
1162 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1167 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1168 (SCM obj
, SCM index
),
1169 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1170 "the value from @var{obj}.")
1171 #define FUNC_NAME s_scm_at_assert_bound_ref
1173 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1174 if (SCM_GOOPS_UNBOUNDP (value
))
1175 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1180 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1181 (SCM obj
, SCM index
),
1182 "Return the slot value with index @var{index} from @var{obj}.")
1183 #define FUNC_NAME s_scm_sys_fast_slot_ref
1187 SCM_VALIDATE_INSTANCE (1, obj
);
1188 i
= scm_to_unsigned_integer (index
, 0,
1189 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1192 return SCM_SLOT (obj
, i
);
1196 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1197 (SCM obj
, SCM index
, SCM value
),
1198 "Set the slot with index @var{index} in @var{obj} to\n"
1200 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1204 SCM_VALIDATE_INSTANCE (1, obj
);
1205 i
= scm_to_unsigned_integer (index
, 0,
1206 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1210 SCM_SET_SLOT (obj
, i
, value
);
1212 return SCM_UNSPECIFIED
;
1220 /* In the future, this function will return the effective slot
1221 * definition associated with SLOT_NAME. Now it just returns some of
1222 * the information which will be stored in the effective slot
1227 slot_definition_using_name (SCM
class, SCM slot_name
)
1229 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1230 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1231 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1232 return SCM_CAR (slots
);
1237 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1238 #define FUNC_NAME "%get-slot-value"
1240 SCM access
= SCM_CDDR (slotdef
);
1242 * - access is an integer (the offset of this slot in the slots vector)
1243 * - otherwise (car access) is the getter function to apply
1245 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1246 * we can just assume fixnums here.
1248 if (SCM_I_INUMP (access
))
1249 /* Don't poke at the slots directly, because scm_struct_ref handles the
1250 access bits for us. */
1251 return scm_struct_ref (obj
, access
);
1253 return scm_call_1 (SCM_CAR (access
), obj
);
1258 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1260 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1261 if (scm_is_true (slotdef
))
1262 return get_slot_value (class, obj
, slotdef
);
1264 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1268 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1269 #define FUNC_NAME "%set-slot-value"
1271 SCM access
= SCM_CDDR (slotdef
);
1273 * - access is an integer (the offset of this slot in the slots vector)
1274 * - otherwise (cadr access) is the setter function to apply
1276 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1277 * we can just assume fixnums here.
1279 if (SCM_I_INUMP (access
))
1280 /* obey permissions bits via going through struct-set! */
1281 scm_struct_set_x (obj
, access
, value
);
1283 /* ((cadr l) obj value) */
1284 scm_call_2 (SCM_CADR (access
), obj
, value
);
1285 return SCM_UNSPECIFIED
;
1290 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1292 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1293 if (scm_is_true (slotdef
))
1294 return set_slot_value (class, obj
, slotdef
, value
);
1296 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1300 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1304 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1305 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1311 /* ======================================== */
1313 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1314 (SCM
class, SCM obj
, SCM slot_name
),
1316 #define FUNC_NAME s_scm_slot_ref_using_class
1320 SCM_VALIDATE_CLASS (1, class);
1321 SCM_VALIDATE_INSTANCE (2, obj
);
1322 SCM_VALIDATE_SYMBOL (3, slot_name
);
1324 res
= get_slot_value_using_name (class, obj
, slot_name
);
1325 if (SCM_GOOPS_UNBOUNDP (res
))
1326 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1332 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1333 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1335 #define FUNC_NAME s_scm_slot_set_using_class_x
1337 SCM_VALIDATE_CLASS (1, class);
1338 SCM_VALIDATE_INSTANCE (2, obj
);
1339 SCM_VALIDATE_SYMBOL (3, slot_name
);
1341 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1346 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1347 (SCM
class, SCM obj
, SCM slot_name
),
1349 #define FUNC_NAME s_scm_slot_bound_using_class_p
1351 SCM_VALIDATE_CLASS (1, class);
1352 SCM_VALIDATE_INSTANCE (2, obj
);
1353 SCM_VALIDATE_SYMBOL (3, slot_name
);
1355 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1361 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1362 (SCM
class, SCM obj
, SCM slot_name
),
1364 #define FUNC_NAME s_scm_slot_exists_using_class_p
1366 SCM_VALIDATE_CLASS (1, class);
1367 SCM_VALIDATE_INSTANCE (2, obj
);
1368 SCM_VALIDATE_SYMBOL (3, slot_name
);
1369 return test_slot_existence (class, obj
, slot_name
);
1374 /* ======================================== */
1376 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1377 (SCM obj
, SCM slot_name
),
1378 "Return the value from @var{obj}'s slot with the name\n"
1380 #define FUNC_NAME s_scm_slot_ref
1384 SCM_VALIDATE_INSTANCE (1, obj
);
1385 TEST_CHANGE_CLASS (obj
, class);
1387 res
= get_slot_value_using_name (class, obj
, slot_name
);
1388 if (SCM_GOOPS_UNBOUNDP (res
))
1389 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1394 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1395 (SCM obj
, SCM slot_name
, SCM value
),
1396 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1397 #define FUNC_NAME s_scm_slot_set_x
1401 SCM_VALIDATE_INSTANCE (1, obj
);
1402 TEST_CHANGE_CLASS(obj
, class);
1404 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1408 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1410 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1411 (SCM obj
, SCM slot_name
),
1412 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1414 #define FUNC_NAME s_scm_slot_bound_p
1418 SCM_VALIDATE_INSTANCE (1, obj
);
1419 TEST_CHANGE_CLASS(obj
, class);
1421 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1429 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1430 (SCM obj
, SCM slot_name
),
1431 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1432 #define FUNC_NAME s_scm_slot_exists_p
1436 SCM_VALIDATE_INSTANCE (1, obj
);
1437 SCM_VALIDATE_SYMBOL (2, slot_name
);
1438 TEST_CHANGE_CLASS (obj
, class);
1440 return test_slot_existence (class, obj
, slot_name
);
1445 /******************************************************************************
1447 * %allocate-instance (the low level instance allocation primitive)
1449 ******************************************************************************/
1451 static void clear_method_cache (SCM
);
1453 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1454 (SCM
class, SCM initargs
),
1455 "Create a new instance of class @var{class} and initialize it\n"
1456 "from the arguments @var{initargs}.")
1457 #define FUNC_NAME s_scm_sys_allocate_instance
1460 scm_t_signed_bits n
, i
;
1463 SCM_VALIDATE_CLASS (1, class);
1465 /* FIXME: duplicates some of scm_make_struct. */
1467 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1468 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1470 layout
= SCM_VTABLE_LAYOUT (class);
1472 /* Set all SCM-holding slots to unbound */
1473 for (i
= 0; i
< n
; i
++)
1475 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1477 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1479 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1481 SCM_STRUCT_DATA (obj
)[i
] = 0;
1484 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1485 clear_method_cache (obj
);
1491 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1492 (SCM obj
, SCM setter
),
1494 #define FUNC_NAME s_scm_sys_set_object_setter_x
1496 SCM_ASSERT (SCM_STRUCTP (obj
)
1497 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1501 SCM_SET_GENERIC_SETTER (obj
, setter
);
1502 return SCM_UNSPECIFIED
;
1506 /******************************************************************************
1508 * %modify-instance (used by change-class to modify in place)
1510 ******************************************************************************/
1512 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1515 #define FUNC_NAME s_scm_sys_modify_instance
1517 SCM_VALIDATE_INSTANCE (1, old
);
1518 SCM_VALIDATE_INSTANCE (2, new);
1520 /* Exchange the data contained in old and new. We exchange rather than
1521 * scratch the old value with new to be correct with GC.
1522 * See "Class redefinition protocol above".
1524 SCM_CRITICAL_SECTION_START
;
1526 scm_t_bits word0
, word1
;
1527 word0
= SCM_CELL_WORD_0 (old
);
1528 word1
= SCM_CELL_WORD_1 (old
);
1529 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1530 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1531 SCM_SET_CELL_WORD_0 (new, word0
);
1532 SCM_SET_CELL_WORD_1 (new, word1
);
1534 SCM_CRITICAL_SECTION_END
;
1535 return SCM_UNSPECIFIED
;
1539 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1542 #define FUNC_NAME s_scm_sys_modify_class
1544 SCM_VALIDATE_CLASS (1, old
);
1545 SCM_VALIDATE_CLASS (2, new);
1547 SCM_CRITICAL_SECTION_START
;
1549 scm_t_bits word0
, word1
;
1550 word0
= SCM_CELL_WORD_0 (old
);
1551 word1
= SCM_CELL_WORD_1 (old
);
1552 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1553 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1554 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1555 SCM_SET_CELL_WORD_0 (new, word0
);
1556 SCM_SET_CELL_WORD_1 (new, word1
);
1557 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1559 SCM_CRITICAL_SECTION_END
;
1560 return SCM_UNSPECIFIED
;
1564 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1567 #define FUNC_NAME s_scm_sys_invalidate_class
1569 SCM_VALIDATE_CLASS (1, class);
1570 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1571 return SCM_UNSPECIFIED
;
1575 /* When instances change class, they finally get a new body, but
1576 * before that, they go through purgatory in hell. Odd as it may
1577 * seem, this data structure saves us from eternal suffering in
1578 * infinite recursions.
1581 static scm_t_bits
**hell
;
1582 static long n_hell
= 1; /* one place for the evil one himself */
1583 static long hell_size
= 4;
1584 static SCM hell_mutex
;
1590 for (i
= 1; i
< n_hell
; ++i
)
1591 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1597 go_to_hell (void *o
)
1600 scm_lock_mutex (hell_mutex
);
1601 if (n_hell
>= hell_size
)
1604 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1606 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1607 scm_unlock_mutex (hell_mutex
);
1611 go_to_heaven (void *o
)
1614 scm_lock_mutex (hell_mutex
);
1615 hell
[burnin (obj
)] = hell
[--n_hell
];
1616 scm_unlock_mutex (hell_mutex
);
1620 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1623 purgatory (SCM obj
, SCM new_class
)
1625 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1628 /* This function calls the generic function change-class for all
1629 * instances which aren't currently undergoing class change.
1633 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1637 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1638 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1639 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1640 purgatory (obj
, new_class
);
1645 /******************************************************************************
1651 * GGG E N E R I C F U N C T I O N S
1653 * This implementation provides
1654 * - generic functions (with class specializers)
1657 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1659 ******************************************************************************/
1661 SCM_KEYWORD (k_name
, "name");
1663 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1666 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1668 make_dispatch_procedure (SCM gf
)
1670 static SCM var
= SCM_BOOL_F
;
1671 if (scm_is_false (var
))
1672 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1673 sym_delayed_compile
);
1674 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1678 clear_method_cache (SCM gf
)
1680 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1681 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1684 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1687 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1689 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1690 clear_method_cache (gf
);
1691 return SCM_UNSPECIFIED
;
1695 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1698 #define FUNC_NAME s_scm_generic_capability_p
1700 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1701 proc
, SCM_ARG1
, FUNC_NAME
);
1702 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1706 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1709 #define FUNC_NAME s_scm_enable_primitive_generic_x
1711 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1712 while (!scm_is_null (subrs
))
1714 SCM subr
= SCM_CAR (subrs
);
1715 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1716 SCM_SET_SUBR_GENERIC (subr
,
1717 scm_make (scm_list_3 (scm_class_generic
,
1719 SCM_SUBR_NAME (subr
))));
1720 subrs
= SCM_CDR (subrs
);
1722 return SCM_UNSPECIFIED
;
1726 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1727 (SCM subr
, SCM generic
),
1729 #define FUNC_NAME s_scm_set_primitive_generic_x
1731 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1732 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1733 SCM_SET_SUBR_GENERIC (subr
, generic
);
1734 return SCM_UNSPECIFIED
;
1738 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1741 #define FUNC_NAME s_scm_primitive_generic_generic
1743 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1745 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1746 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1747 return *SCM_SUBR_GENERIC (subr
);
1749 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1753 typedef struct t_extension
{
1754 struct t_extension
*next
;
1760 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1762 static const char extension_gc_hint
[] = "GOOPS extension";
1764 static t_extension
*extensions
= 0;
1767 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1772 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1773 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1774 gf
= *SCM_SUBR_GENERIC (extended
);
1775 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1777 SCM_SUBR_NAME (extension
));
1778 SCM_SET_SUBR_GENERIC (extension
, gext
);
1782 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1784 t_extension
**loc
= &extensions
;
1785 /* Make sure that extensions are placed before their own
1786 * extensions in the extensions list. O(N^2) algorithm, but
1787 * extensions of primitive generics are rare.
1789 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1790 loc
= &(*loc
)->next
;
1792 e
->extended
= extended
;
1793 e
->extension
= extension
;
1799 setup_extended_primitive_generics ()
1803 t_extension
*e
= extensions
;
1804 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1805 extensions
= e
->next
;
1809 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1810 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1811 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1815 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1817 if (!SCM_UNPACK (gf
))
1818 scm_error_num_args_subr (subr
);
1820 return scm_call_0 (gf
);
1824 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1826 if (!SCM_UNPACK (gf
))
1827 scm_wrong_type_arg (subr
, pos
, a1
);
1829 return scm_call_1 (gf
, a1
);
1833 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1835 if (!SCM_UNPACK (gf
))
1836 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1838 return scm_call_2 (gf
, a1
, a2
);
1842 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1844 if (!SCM_UNPACK (gf
))
1845 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1847 return scm_apply_0 (gf
, args
);
1850 /******************************************************************************
1852 * Protocol for calling a generic fumction
1853 * This protocol is roughly equivalent to (parameter are a little bit different
1854 * for efficiency reasons):
1856 * + apply-generic (gf args)
1857 * + compute-applicable-methods (gf args ...)
1858 * + sort-applicable-methods (methods args)
1859 * + apply-methods (gf methods args)
1861 * apply-methods calls make-next-method to build the "continuation" of a a
1862 * method. Applying a next-method will call apply-next-method which in
1863 * turn will call apply again to call effectively the following method.
1865 ******************************************************************************/
1868 applicablep (SCM actual
, SCM formal
)
1870 /* We already know that the cpl is well formed. */
1871 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1875 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1877 register SCM s1
, s2
;
1881 * m1 and m2 can have != length (i.e. one can be one element longer than the
1882 * other when we have a dotted parameter list). For instance, with the call
1885 * (define-method M (a . l) ....)
1886 * (define-method M (a) ....)
1888 * we consider that the second method is more specific.
1890 * BTW, targs is an array of types. We don't need it's size since
1891 * we already know that m1 and m2 are applicable (no risk to go past
1892 * the end of this array).
1895 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1896 if (scm_is_null(s1
)) return 1;
1897 if (scm_is_null(s2
)) return 0;
1898 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1899 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1901 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1902 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1904 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1907 return 0;/* should not occur! */
1910 return 0; /* should not occur! */
1913 #define BUFFSIZE 32 /* big enough for most uses */
1916 scm_i_vector2list (SCM l
, long len
)
1919 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1921 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1922 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1928 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1931 SCM
*v
, vector
= SCM_EOL
;
1932 SCM buffer
[BUFFSIZE
];
1933 SCM save
= method_list
;
1934 scm_t_array_handle handle
;
1936 /* For reasonably sized method_lists we can try to avoid all the
1937 * consing and reorder the list in place...
1938 * This idea is due to David McClain <Dave_McClain@msn.com>
1940 if (size
<= BUFFSIZE
)
1942 for (i
= 0; i
< size
; i
++)
1944 buffer
[i
] = SCM_CAR (method_list
);
1945 method_list
= SCM_CDR (method_list
);
1951 /* Too many elements in method_list to keep everything locally */
1952 vector
= scm_i_vector2list (save
, size
);
1953 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
1956 /* Use a simple shell sort since it is generally faster than qsort on
1957 * small vectors (which is probably mostly the case when we have to
1958 * sort a list of applicable methods).
1960 for (incr
= size
/ 2; incr
; incr
/= 2)
1962 for (i
= incr
; i
< size
; i
++)
1964 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1966 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1970 SCM tmp
= v
[j
+ incr
];
1978 if (size
<= BUFFSIZE
)
1980 /* We did it in locally, so restore the original list (reordered) in-place */
1981 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1983 SCM_SETCAR (method_list
, *v
);
1984 method_list
= SCM_CDR (method_list
);
1989 /* If we are here, that's that we did it the hard way... */
1990 scm_array_handle_release (&handle
);
1991 return scm_vector_to_list (vector
);
1995 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1999 SCM l
, fl
, applicable
= SCM_EOL
;
2001 SCM buffer
[BUFFSIZE
];
2005 scm_t_array_handle handle
;
2007 /* Build the list of arguments types */
2008 if (len
>= BUFFSIZE
)
2010 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2011 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2014 note that we don't have to work to reset the generation
2015 count. TMP is a new vector anyway, and it is found
2022 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2023 *p
++ = scm_class_of (SCM_CAR (args
));
2025 /* Build a list of all applicable methods */
2026 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2028 fl
= SPEC_OF (SCM_CAR (l
));
2029 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2031 if (SCM_INSTANCEP (fl
)
2032 /* We have a dotted argument list */
2033 || (i
>= len
&& scm_is_null (fl
)))
2034 { /* both list exhausted */
2035 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2041 || !applicablep (types
[i
], SCM_CAR (fl
)))
2046 if (len
>= BUFFSIZE
)
2047 scm_array_handle_release (&handle
);
2053 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2054 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2060 : sort_applicable_methods (applicable
, count
, types
));
2064 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2067 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2070 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2071 #define FUNC_NAME s_sys_compute_applicable_methods
2074 SCM_VALIDATE_GENERIC (1, gf
);
2075 n
= scm_ilength (args
);
2076 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2077 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2081 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2082 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2083 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2084 scm_sys_compute_applicable_methods
));
2086 /******************************************************************************
2088 * A simple make (which will be redefined later in Scheme)
2089 * This version handles only creation of gf, methods and classes (no instances)
2091 * Since this code will disappear when Goops will be fully booted,
2092 * no precaution is taken to be efficient.
2094 ******************************************************************************/
2096 SCM_KEYWORD (k_setter
, "setter");
2097 SCM_KEYWORD (k_specializers
, "specializers");
2098 SCM_KEYWORD (k_procedure
, "procedure");
2099 SCM_KEYWORD (k_formals
, "formals");
2100 SCM_KEYWORD (k_body
, "body");
2101 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2102 SCM_KEYWORD (k_dsupers
, "dsupers");
2103 SCM_KEYWORD (k_slots
, "slots");
2104 SCM_KEYWORD (k_gf
, "generic-function");
2106 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2108 "Make a new object. @var{args} must contain the class and\n"
2109 "all necessary initialization information.")
2110 #define FUNC_NAME s_scm_make
2113 long len
= scm_ilength (args
);
2115 if (len
<= 0 || (len
& 1) == 0)
2116 SCM_WRONG_NUM_ARGS ();
2118 class = SCM_CAR(args
);
2119 args
= SCM_CDR(args
);
2121 if (scm_is_eq (class, scm_class_generic
)
2122 || scm_is_eq (class, scm_class_accessor
))
2124 z
= scm_make_struct (class, SCM_INUM0
,
2125 scm_list_4 (SCM_BOOL_F
,
2129 scm_set_procedure_property_x (z
, scm_sym_name
,
2130 scm_get_keyword (k_name
,
2133 clear_method_cache (z
);
2134 if (scm_is_eq (class, scm_class_accessor
))
2136 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2137 if (scm_is_true (setter
))
2138 scm_sys_set_object_setter_x (z
, setter
);
2143 z
= scm_sys_allocate_instance (class, args
);
2145 if (scm_is_eq (class, scm_class_method
)
2146 || scm_is_eq (class, scm_class_accessor_method
))
2148 SCM_SET_SLOT (z
, scm_si_generic_function
,
2149 scm_i_get_keyword (k_gf
,
2154 SCM_SET_SLOT (z
, scm_si_specializers
,
2155 scm_i_get_keyword (k_specializers
,
2160 SCM_SET_SLOT (z
, scm_si_procedure
,
2161 scm_i_get_keyword (k_procedure
,
2166 SCM_SET_SLOT (z
, scm_si_formals
,
2167 scm_i_get_keyword (k_formals
,
2172 SCM_SET_SLOT (z
, scm_si_body
,
2173 scm_i_get_keyword (k_body
,
2178 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2179 scm_i_get_keyword (k_make_procedure
,
2187 /* In all the others case, make a new class .... No instance here */
2188 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2189 scm_i_get_keyword (k_name
,
2192 scm_from_latin1_symbol ("???"),
2194 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2195 scm_i_get_keyword (k_dsupers
,
2200 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2201 scm_i_get_keyword (k_slots
,
2212 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2215 #define FUNC_NAME s_scm_find_method
2218 long len
= scm_ilength (l
);
2221 SCM_WRONG_NUM_ARGS ();
2223 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2224 SCM_VALIDATE_GENERIC (1, gf
);
2225 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2226 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2228 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2232 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2233 (SCM m1
, SCM m2
, SCM targs
),
2234 "Return true if method @var{m1} is more specific than @var{m2} "
2235 "given the argument types (classes) listed in @var{targs}.")
2236 #define FUNC_NAME s_scm_sys_method_more_specific_p
2240 long i
, len
, m1_specs
, m2_specs
;
2241 scm_t_array_handle handle
;
2243 SCM_VALIDATE_METHOD (1, m1
);
2244 SCM_VALIDATE_METHOD (2, m2
);
2246 len
= scm_ilength (targs
);
2247 m1_specs
= scm_ilength (SPEC_OF (m1
));
2248 m2_specs
= scm_ilength (SPEC_OF (m2
));
2249 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2250 targs
, SCM_ARG3
, FUNC_NAME
);
2252 /* Verify that all the arguments of TARGS are classes and place them
2255 v
= scm_c_make_vector (len
, SCM_EOL
);
2256 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2258 for (i
= 0, l
= targs
;
2259 i
< len
&& scm_is_pair (l
);
2260 i
++, l
= SCM_CDR (l
))
2262 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2263 v_elts
[i
] = SCM_CAR (l
);
2265 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2267 scm_array_handle_release (&handle
);
2275 /******************************************************************************
2279 ******************************************************************************/
2281 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2282 assuming that currently the reverse is true. Recalculate slots and
2283 associated getters-n-setters. */
2285 fix_cpl (SCM c
, SCM before
, SCM after
)
2287 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2288 SCM ls
= scm_c_memq (after
, cpl
);
2291 if (scm_is_false (ls
))
2292 /* if this condition occurs, fix_cpl should not be applied this way */
2295 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2296 SCM_SETCAR (ls
, before
);
2297 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2299 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2300 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2301 SCM g_n_s
= compute_getters_n_setters (slots
);
2302 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2303 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2309 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2311 SCM tmp
= scm_from_locale_symbol (name
);
2313 *var
= scm_basic_make_class (meta
, tmp
,
2314 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2316 scm_module_define (scm_module_goops
, tmp
, *var
);
2320 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2323 create_standard_classes (void)
2326 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2327 scm_from_latin1_symbol ("specializers"),
2329 scm_from_latin1_symbol ("formals"),
2330 scm_from_latin1_symbol ("body"),
2331 scm_from_latin1_symbol ("make-procedure"),
2333 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2335 k_slot_definition
));
2336 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2337 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2340 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2343 scm_from_latin1_symbol ("effective-methods"));
2344 SCM setter_slots
= scm_list_1 (sym_setter
);
2345 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2348 /* Foreign class slot classes */
2349 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2350 scm_class_class
, scm_class_top
, SCM_EOL
);
2351 make_stdcls (&scm_class_protected
, "<protected-slot>",
2352 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2353 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2354 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2355 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2356 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2357 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2358 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2359 make_stdcls (&scm_class_self
, "<self-slot>",
2360 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2361 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2363 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2365 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2367 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2369 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2371 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2373 make_stdcls (&scm_class_scm
, "<scm-slot>",
2374 scm_class_class
, scm_class_protected
, SCM_EOL
);
2375 make_stdcls (&scm_class_int
, "<int-slot>",
2376 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2377 make_stdcls (&scm_class_float
, "<float-slot>",
2378 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2379 make_stdcls (&scm_class_double
, "<double-slot>",
2380 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2382 /* Continue initialization of class <class> */
2384 slots
= build_class_class_slots ();
2385 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2386 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2387 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2388 compute_getters_n_setters (slots
));
2390 /* scm_class_generic functions classes */
2391 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2392 scm_class_class
, scm_class_class
, SCM_EOL
);
2393 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2394 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2395 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2396 make_stdcls (&scm_class_method
, "<method>",
2397 scm_class_class
, scm_class_object
, method_slots
);
2398 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2399 scm_class_class
, scm_class_method
, amethod_slots
);
2400 make_stdcls (&scm_class_applicable
, "<applicable>",
2401 scm_class_class
, scm_class_top
, SCM_EOL
);
2402 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2403 scm_class_applicable_struct_class
,
2404 scm_list_2 (scm_class_object
, scm_class_applicable
),
2405 scm_list_1 (sym_procedure
));
2406 make_stdcls (&scm_class_generic
, "<generic>",
2407 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2408 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2409 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2410 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2411 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2412 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2413 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2414 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2415 make_stdcls (&scm_class_accessor
, "<accessor>",
2416 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2417 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2418 make_stdcls (&scm_class_extended_generic_with_setter
,
2419 "<extended-generic-with-setter>",
2420 scm_class_applicable_struct_class
,
2421 scm_list_2 (scm_class_extended_generic
,
2422 scm_class_generic_with_setter
),
2424 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2425 SCM_CLASSF_PURE_GENERIC
);
2426 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2427 scm_class_applicable_struct_class
,
2428 scm_list_2 (scm_class_accessor
,
2429 scm_class_extended_generic_with_setter
),
2431 /* <extended-generic> is misplaced. */
2432 fix_cpl (scm_class_extended_accessor
,
2433 scm_class_extended_generic
, scm_class_generic_with_setter
);
2434 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2436 /* Primitive types classes */
2437 make_stdcls (&scm_class_boolean
, "<boolean>",
2438 scm_class_class
, scm_class_top
, SCM_EOL
);
2439 make_stdcls (&scm_class_char
, "<char>",
2440 scm_class_class
, scm_class_top
, SCM_EOL
);
2441 make_stdcls (&scm_class_list
, "<list>",
2442 scm_class_class
, scm_class_top
, SCM_EOL
);
2443 make_stdcls (&scm_class_pair
, "<pair>",
2444 scm_class_class
, scm_class_list
, SCM_EOL
);
2445 make_stdcls (&scm_class_null
, "<null>",
2446 scm_class_class
, scm_class_list
, SCM_EOL
);
2447 make_stdcls (&scm_class_string
, "<string>",
2448 scm_class_class
, scm_class_top
, SCM_EOL
);
2449 make_stdcls (&scm_class_symbol
, "<symbol>",
2450 scm_class_class
, scm_class_top
, SCM_EOL
);
2451 make_stdcls (&scm_class_vector
, "<vector>",
2452 scm_class_class
, scm_class_top
, SCM_EOL
);
2453 make_stdcls (&class_foreign
, "<foreign>",
2454 scm_class_class
, scm_class_top
, SCM_EOL
);
2455 make_stdcls (&class_hashtable
, "<hashtable>",
2456 scm_class_class
, scm_class_top
, SCM_EOL
);
2457 make_stdcls (&class_fluid
, "<fluid>",
2458 scm_class_class
, scm_class_top
, SCM_EOL
);
2459 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2460 scm_class_class
, scm_class_top
, SCM_EOL
);
2461 make_stdcls (&class_frame
, "<frame>",
2462 scm_class_class
, scm_class_top
, SCM_EOL
);
2463 make_stdcls (&class_objcode
, "<objcode>",
2464 scm_class_class
, scm_class_top
, SCM_EOL
);
2465 make_stdcls (&class_vm
, "<vm>",
2466 scm_class_class
, scm_class_top
, SCM_EOL
);
2467 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2468 scm_class_class
, scm_class_top
, SCM_EOL
);
2469 make_stdcls (&class_bytevector
, "<bytevector>",
2470 scm_class_class
, scm_class_top
, SCM_EOL
);
2471 make_stdcls (&class_uvec
, "<uvec>",
2472 scm_class_class
, class_bytevector
, SCM_EOL
);
2473 make_stdcls (&scm_class_number
, "<number>",
2474 scm_class_class
, scm_class_top
, SCM_EOL
);
2475 make_stdcls (&scm_class_complex
, "<complex>",
2476 scm_class_class
, scm_class_number
, SCM_EOL
);
2477 make_stdcls (&scm_class_real
, "<real>",
2478 scm_class_class
, scm_class_complex
, SCM_EOL
);
2479 make_stdcls (&scm_class_integer
, "<integer>",
2480 scm_class_class
, scm_class_real
, SCM_EOL
);
2481 make_stdcls (&scm_class_fraction
, "<fraction>",
2482 scm_class_class
, scm_class_real
, SCM_EOL
);
2483 make_stdcls (&scm_class_keyword
, "<keyword>",
2484 scm_class_class
, scm_class_top
, SCM_EOL
);
2485 make_stdcls (&scm_class_unknown
, "<unknown>",
2486 scm_class_class
, scm_class_top
, SCM_EOL
);
2487 make_stdcls (&scm_class_procedure
, "<procedure>",
2488 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2489 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2490 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2491 make_stdcls (&scm_class_port
, "<port>",
2492 scm_class_class
, scm_class_top
, SCM_EOL
);
2493 make_stdcls (&scm_class_input_port
, "<input-port>",
2494 scm_class_class
, scm_class_port
, SCM_EOL
);
2495 make_stdcls (&scm_class_output_port
, "<output-port>",
2496 scm_class_class
, scm_class_port
, SCM_EOL
);
2497 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2499 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2503 /**********************************************************************
2507 **********************************************************************/
2510 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2516 sprintf (buffer
, template, type_name
);
2517 name
= scm_from_locale_symbol (buffer
);
2520 name
= SCM_GOOPS_UNBOUND
;
2522 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2523 name
, supers
, SCM_EOL
);
2527 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2531 if (scm_is_true (type_name_sym
))
2533 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2534 scm_symbol_to_string (type_name_sym
),
2535 scm_from_locale_string (">")));
2536 name
= scm_string_to_symbol (name
);
2539 name
= SCM_GOOPS_UNBOUND
;
2541 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2542 name
, supers
, SCM_EOL
);
2546 scm_make_extended_class (char const *type_name
, int applicablep
)
2548 return make_class_from_template ("<%s>",
2550 scm_list_1 (applicablep
2551 ? scm_class_applicable
2557 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2559 return make_class_from_symbol (type_name_sym
,
2560 scm_list_1 (applicablep
2561 ? scm_class_applicable
2567 scm_i_inherit_applicable (SCM c
)
2569 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2571 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2572 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2573 /* patch scm_class_applicable into direct-supers */
2574 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2575 if (scm_is_false (top
))
2576 dsupers
= scm_append (scm_list_2 (dsupers
,
2577 scm_list_1 (scm_class_applicable
)));
2580 SCM_SETCAR (top
, scm_class_applicable
);
2581 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2583 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2584 /* patch scm_class_applicable into cpl */
2585 top
= scm_c_memq (scm_class_top
, cpl
);
2586 if (scm_is_false (top
))
2590 SCM_SETCAR (top
, scm_class_applicable
);
2591 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2593 /* add class to direct-subclasses of scm_class_applicable */
2594 SCM_SET_SLOT (scm_class_applicable
,
2595 scm_si_direct_subclasses
,
2596 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2597 scm_si_direct_subclasses
)));
2602 create_smob_classes (void)
2606 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2607 scm_smob_class
[i
] = SCM_BOOL_F
;
2609 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2611 for (i
= 0; i
< scm_numsmob
; ++i
)
2612 if (scm_is_false (scm_smob_class
[i
]))
2613 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2614 scm_smobs
[i
].apply
!= 0);
2618 scm_make_port_classes (long ptobnum
, char *type_name
)
2620 SCM c
, class = make_class_from_template ("<%s-port>",
2622 scm_list_1 (scm_class_port
),
2624 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2625 = make_class_from_template ("<%s-input-port>",
2627 scm_list_2 (class, scm_class_input_port
),
2629 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2630 = make_class_from_template ("<%s-output-port>",
2632 scm_list_2 (class, scm_class_output_port
),
2634 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2636 = make_class_from_template ("<%s-input-output-port>",
2638 scm_list_2 (class, scm_class_input_output_port
),
2640 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2641 SCM_SET_SLOT (c
, scm_si_cpl
,
2642 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2646 create_port_classes (void)
2650 for (i
= 0; i
< scm_numptob
; ++i
)
2651 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2655 make_struct_class (void *closure SCM_UNUSED
,
2656 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2658 if (scm_is_false (data
))
2659 scm_i_define_class_for_vtable (vtable
);
2660 return SCM_UNSPECIFIED
;
2664 create_struct_classes (void)
2666 /* FIXME: take the vtable_class_map while initializing goops? */
2667 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2671 /**********************************************************************
2675 **********************************************************************/
2680 if (!goops_loaded_p
)
2681 scm_c_resolve_module ("oop goops");
2685 SCM_SYMBOL (sym_o
, "o");
2686 SCM_SYMBOL (sym_x
, "x");
2688 SCM_KEYWORD (k_accessor
, "accessor");
2689 SCM_KEYWORD (k_getter
, "getter");
2692 scm_ensure_accessor (SCM name
)
2694 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2695 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2697 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2698 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2699 k_name
, name
, k_setter
, gf
));
2706 * Debugging utilities
2709 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2711 "Return @code{#t} if @var{obj} is a pure generic.")
2712 #define FUNC_NAME s_scm_pure_generic_p
2714 return scm_from_bool (SCM_PUREGENERICP (obj
));
2718 #endif /* GUILE_DEBUG */
2724 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2726 "Announce that GOOPS is loaded and perform initialization\n"
2727 "on the C level which depends on the loaded GOOPS modules.")
2728 #define FUNC_NAME s_scm_sys_goops_loaded
2731 var_compute_applicable_methods
=
2732 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2734 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2736 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2738 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2739 var_no_applicable_method
=
2740 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2742 scm_module_variable (scm_module_goops
, sym_change_class
);
2743 setup_extended_primitive_generics ();
2744 return SCM_UNSPECIFIED
;
2748 SCM scm_module_goops
;
2751 scm_init_goops_builtins (void)
2753 scm_module_goops
= scm_current_module ();
2755 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2757 #include "libguile/goops.x"
2759 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2760 hell_mutex
= scm_make_mutex ();
2762 create_basic_classes ();
2763 create_standard_classes ();
2764 create_smob_classes ();
2765 create_struct_classes ();
2766 create_port_classes ();
2769 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2770 scm_no_applicable_method
=
2771 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2772 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2775 return SCM_UNSPECIFIED
;
2781 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2782 scm_init_goops_builtins
);