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 /* FIXME, exports should come from the scm file only */
89 #define DEFVAR(v, val) \
90 { scm_module_define (scm_module_goops, (v), (val)); \
91 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
95 /* Class redefinition protocol:
97 A class is represented by a heap header h1 which points to a
98 malloc:ed memory block m1.
100 When a new version of a class is created, a new header h2 and
101 memory block m2 are allocated. The headers h1 and h2 then switch
102 pointers so that h1 refers to m2 and h2 to m1. In this way, names
103 bound to h1 will point to the new class at the same time as h2 will
104 be a handle which the GC will use to free m1.
106 The `redefined' slot of m1 will be set to point to h1. An old
107 instance will have its class pointer (the CAR of the heap header)
108 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
109 the class modification and the new class pointer can be found via
113 #define TEST_CHANGE_CLASS(obj, class) \
115 class = SCM_CLASS_OF (obj); \
116 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
118 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
119 class = SCM_CLASS_OF (obj); \
123 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
124 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
126 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
127 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
129 static int goops_loaded_p
= 0;
130 static scm_t_rstate
*goops_rstate
;
132 /* These variables are filled in by the object system when loaded. */
133 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
134 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
135 SCM scm_class_primitive_generic
;
136 SCM scm_class_vector
, scm_class_null
;
137 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
138 SCM scm_class_unknown
;
139 SCM scm_class_top
, scm_class_object
, scm_class_class
;
140 SCM scm_class_applicable
;
141 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
142 SCM scm_class_generic
, scm_class_generic_with_setter
;
143 SCM scm_class_accessor
;
144 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
145 SCM scm_class_extended_accessor
;
146 SCM scm_class_method
;
147 SCM scm_class_accessor_method
;
148 SCM scm_class_procedure_class
;
149 SCM scm_class_applicable_struct_class
;
150 SCM scm_class_number
, scm_class_list
;
151 SCM scm_class_keyword
;
152 SCM scm_class_port
, scm_class_input_output_port
;
153 SCM scm_class_input_port
, scm_class_output_port
;
154 SCM scm_class_foreign_slot
;
155 SCM scm_class_self
, scm_class_protected
;
156 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
157 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
159 SCM scm_class_int
, scm_class_float
, scm_class_double
;
161 static SCM class_foreign
;
162 static SCM class_hashtable
;
163 static SCM class_fluid
;
164 static SCM class_dynamic_state
;
165 static SCM class_frame
;
166 static SCM class_objcode
;
168 static SCM class_vm_cont
;
169 static SCM class_bytevector
;
170 static SCM class_uvec
;
172 static SCM vtable_class_map
= SCM_BOOL_F
;
173 static scm_i_pthread_mutex_t vtable_class_map_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
175 /* Port classes. Allocate 3 times the maximum number of port types so that
176 input ports, output ports, and in/out ports can be stored at different
177 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
178 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
181 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
183 SCM scm_no_applicable_method
;
185 SCM_SYMBOL (scm_sym_define_public
, "define-public");
187 static SCM
scm_make_unbound (void);
188 static SCM
scm_unbound_p (SCM obj
);
189 static SCM
scm_assert_bound (SCM value
, SCM obj
);
190 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
191 static SCM
scm_sys_goops_loaded (void);
192 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
197 scm_i_define_class_for_vtable (SCM vtable
)
201 scm_i_pthread_mutex_lock (&vtable_class_map_lock
);
203 if (scm_is_false (vtable_class_map
))
204 vtable_class_map
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
206 if (scm_is_false (scm_struct_vtable_p (vtable
)))
209 class = scm_hashq_ref (vtable_class_map
, vtable
, SCM_BOOL_F
);
211 scm_i_pthread_mutex_unlock (&vtable_class_map_lock
);
213 if (scm_is_false (class))
215 if (SCM_UNPACK (scm_class_class
))
217 SCM name
= SCM_VTABLE_NAME (vtable
);
218 if (!scm_is_symbol (name
))
219 name
= scm_string_to_symbol (scm_nullstr
);
221 class = scm_make_extended_class_from_symbol
222 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
225 /* `create_struct_classes' will fill this in later. */
228 /* Don't worry about races. This only happens when creating a
229 vtable, which happens by definition in one thread. */
230 scm_i_pthread_mutex_lock (&vtable_class_map_lock
);
231 scm_hashq_set_x (vtable_class_map
, vtable
, class);
232 scm_i_pthread_mutex_unlock (&vtable_class_map_lock
);
238 /* This function is used for efficient type dispatch. */
239 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
241 "Return the class of @var{x}.")
242 #define FUNC_NAME s_scm_class_of
244 switch (SCM_ITAG3 (x
))
248 return scm_class_integer
;
252 return scm_class_char
;
253 else if (scm_is_bool (x
))
254 return scm_class_boolean
;
255 else if (scm_is_null (x
))
256 return scm_class_null
;
258 return scm_class_unknown
;
261 switch (SCM_TYP7 (x
))
263 case scm_tcs_cons_nimcar
:
264 return scm_class_pair
;
266 return scm_class_symbol
;
269 return scm_class_vector
;
270 case scm_tc7_pointer
:
271 return class_foreign
;
272 case scm_tc7_hashtable
:
273 return class_hashtable
;
276 case scm_tc7_dynamic_state
:
277 return class_dynamic_state
;
280 case scm_tc7_objcode
:
281 return class_objcode
;
284 case scm_tc7_vm_cont
:
285 return class_vm_cont
;
286 case scm_tc7_bytevector
:
287 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
288 return class_bytevector
;
292 return scm_class_string
;
294 switch SCM_TYP16 (x
) {
296 return scm_class_integer
;
298 return scm_class_real
;
299 case scm_tc16_complex
:
300 return scm_class_complex
;
301 case scm_tc16_fraction
:
302 return scm_class_fraction
;
304 case scm_tc7_program
:
305 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
306 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
307 return scm_class_primitive_generic
;
309 return scm_class_procedure
;
313 scm_t_bits type
= SCM_TYP16 (x
);
314 if (type
!= scm_tc16_port_with_ps
)
315 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
316 x
= SCM_PORT_WITH_PS_PORT (x
);
317 /* fall through to ports */
320 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
321 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
322 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
323 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
324 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
326 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
327 return SCM_CLASS_OF (x
);
328 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
331 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
332 scm_change_object_class (x
,
333 SCM_CLASS_OF (x
), /* old */
334 SCM_OBJ_CLASS_REDEF (x
)); /* new */
335 return SCM_CLASS_OF (x
);
338 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
341 return scm_class_pair
;
343 return scm_class_unknown
;
349 /* case scm_tc3_unused: */
353 return scm_class_unknown
;
357 /******************************************************************************
361 * This version doesn't fully handle multiple-inheritance. It serves
362 * only for booting classes and will be overloaded in Scheme
364 ******************************************************************************/
367 map (SCM (*proc
) (SCM
), SCM ls
)
369 if (scm_is_null (ls
))
373 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
376 while (scm_is_pair (ls
))
378 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
390 while (scm_is_pair (ls
))
392 SCM el
= SCM_CAR (ls
);
393 if (scm_is_false (scm_c_memq (el
, res
)))
394 res
= scm_cons (el
, res
);
401 compute_cpl (SCM
class)
404 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
407 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
408 SCM ls
= scm_append (scm_acons (class, supers
,
409 map (compute_cpl
, supers
)));
410 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
414 /******************************************************************************
418 ******************************************************************************/
421 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
425 if (!scm_is_pair (l
))
429 if (!scm_is_symbol (tmp
))
430 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
432 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
433 res
= scm_cons (SCM_CAR (l
), res
);
434 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
437 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
441 check_cpl (SCM slots
, SCM bslots
)
443 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
444 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
445 scm_misc_error ("init-object", "a predefined <class> inherited "
446 "field cannot be redefined", SCM_EOL
);
450 build_class_class_slots (void);
453 build_slots_list (SCM dslots
, SCM cpl
)
455 SCM bslots
, class_slots
;
459 class_slots
= SCM_EOL
;
460 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
464 bslots
= build_class_class_slots ();
465 check_cpl (res
, bslots
);
470 if (scm_is_pair (cpl
))
472 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
474 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
475 scm_si_direct_slots
);
478 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
479 check_cpl (new_slots
, bslots
);
482 /* Move class slots to the head of the list. */
483 class_slots
= new_slots
;
487 res
= scm_append (scm_list_2 (new_slots
, res
));
491 scm_misc_error ("%compute-slots", "malformed cpl argument in "
492 "build_slots_list", SCM_EOL
);
494 /* make sure to add the <class> slots to the head of the list */
496 res
= scm_append (scm_list_2 (class_slots
, res
));
498 /* res contains a list of slots. Remove slots which appears more than once */
499 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
506 while (!scm_is_null (ls
))
508 if (!scm_is_pair (ls
))
509 scm_misc_error ("%compute-slots", "malformed ls argument in "
511 if (!scm_is_pair (SCM_CAR (ls
)))
512 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
519 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
521 "Return a list consisting of the names of all slots belonging to\n"
522 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
524 #define FUNC_NAME s_scm_sys_compute_slots
526 SCM_VALIDATE_CLASS (1, class);
527 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
528 SCM_SLOT (class, scm_si_cpl
));
533 /******************************************************************************
535 * compute-getters-n-setters
537 * This version doesn't handle slot options. It serves only for booting
538 * classes and will be overloaded in Scheme.
540 ******************************************************************************/
542 SCM_KEYWORD (k_init_value
, "init-value");
543 SCM_KEYWORD (k_init_thunk
, "init-thunk");
546 compute_getters_n_setters (SCM slots
)
552 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
554 SCM init
= SCM_BOOL_F
;
555 SCM options
= SCM_CDAR (slots
);
556 if (!scm_is_null (options
))
558 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
559 if (SCM_UNPACK (init
))
561 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
563 scm_list_2 (scm_sym_quote
,
567 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
569 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
571 scm_from_int (i
++))),
573 cdrloc
= SCM_CDRLOC (*cdrloc
);
578 /******************************************************************************
582 ******************************************************************************/
584 /*fixme* Manufacture keywords in advance */
586 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
590 for (i
= 0; i
!= len
; i
+= 2)
592 SCM obj
= SCM_CAR (l
);
594 if (!scm_is_keyword (obj
))
595 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
596 else if (scm_is_eq (obj
, key
))
602 return default_value
;
606 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
607 (SCM key
, SCM l
, SCM default_value
),
608 "Determine an associated value for the keyword @var{key} from\n"
609 "the list @var{l}. The list @var{l} has to consist of an even\n"
610 "number of elements, where, starting with the first, every\n"
611 "second element is a keyword, followed by its associated value.\n"
612 "If @var{l} does not hold a value for @var{key}, the value\n"
613 "@var{default_value} is returned.")
614 #define FUNC_NAME s_scm_get_keyword
618 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
619 len
= scm_ilength (l
);
620 if (len
< 0 || len
% 2 == 1)
621 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
623 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
628 SCM_KEYWORD (k_init_keyword
, "init-keyword");
630 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
631 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
633 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
634 (SCM obj
, SCM initargs
),
635 "Initialize the object @var{obj} with the given arguments\n"
637 #define FUNC_NAME s_scm_sys_initialize_object
639 SCM tmp
, get_n_set
, slots
;
640 SCM
class = SCM_CLASS_OF (obj
);
643 SCM_VALIDATE_INSTANCE (1, obj
);
644 n_initargs
= scm_ilength (initargs
);
645 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
647 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
648 slots
= SCM_SLOT (class, scm_si_slots
);
650 /* See for each slot how it must be initialized */
652 !scm_is_null (slots
);
653 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
655 SCM slot_name
= SCM_CAR (slots
);
656 SCM slot_value
= SCM_PACK (0);
658 if (!scm_is_null (SCM_CDR (slot_name
)))
660 /* This slot admits (perhaps) to be initialized at creation time */
661 long n
= scm_ilength (SCM_CDR (slot_name
));
662 if (n
& 1) /* odd or -1 */
663 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
664 scm_list_1 (slot_name
));
665 tmp
= scm_i_get_keyword (k_init_keyword
,
670 slot_name
= SCM_CAR (slot_name
);
671 if (SCM_UNPACK (tmp
))
673 /* an initarg was provided for this slot */
674 if (!scm_is_keyword (tmp
))
675 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
677 slot_value
= scm_i_get_keyword (tmp
,
685 if (SCM_UNPACK (slot_value
))
686 /* set slot to provided value */
687 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
690 /* set slot to its :init-form if it exists */
691 tmp
= SCM_CADAR (get_n_set
);
692 if (scm_is_true (tmp
))
694 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
695 if (SCM_GOOPS_UNBOUNDP (slot_value
))
696 set_slot_value (class,
708 /* NOTE: The following macros are interdependent with code
709 * in goops.scm:compute-getters-n-setters
711 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
712 (SCM_I_INUMP (SCM_CDDR (gns)) \
713 || (scm_is_pair (SCM_CDDR (gns)) \
714 && scm_is_pair (SCM_CDDDR (gns)) \
715 && scm_is_pair (SCM_CDDDDR (gns))))
716 #define SCM_GNS_INDEX(gns) \
717 (SCM_I_INUMP (SCM_CDDR (gns)) \
718 ? SCM_I_INUM (SCM_CDDR (gns)) \
719 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
720 #define SCM_GNS_SIZE(gns) \
721 (SCM_I_INUMP (SCM_CDDR (gns)) \
723 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
725 SCM_KEYWORD (k_class
, "class");
726 SCM_KEYWORD (k_allocation
, "allocation");
727 SCM_KEYWORD (k_instance
, "instance");
729 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
732 #define FUNC_NAME s_scm_sys_prep_layout_x
734 SCM slots
, getters_n_setters
, nfields
;
735 unsigned long int n
, i
;
739 SCM_VALIDATE_INSTANCE (1, class);
740 slots
= SCM_SLOT (class, scm_si_slots
);
741 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
742 nfields
= SCM_SLOT (class, scm_si_nfields
);
743 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
744 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
745 scm_list_1 (nfields
));
746 n
= 2 * SCM_I_INUM (nfields
);
747 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
748 && SCM_SUBCLASSP (class, scm_class_class
))
749 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
750 scm_list_1 (nfields
));
752 layout
= scm_i_make_string (n
, &s
, 0);
754 while (scm_is_pair (getters_n_setters
))
756 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
759 int len
, index
, size
;
762 if (i
>= n
|| !scm_is_pair (slots
))
765 /* extract slot type */
766 len
= scm_ilength (SCM_CDAR (slots
));
767 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
768 len
, SCM_BOOL_F
, FUNC_NAME
);
769 /* determine slot GC protection and access mode */
770 if (scm_is_false (type
))
777 if (!SCM_CLASSP (type
))
778 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
779 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
781 if (SCM_SUBCLASSP (type
, scm_class_self
))
783 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
788 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
790 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
792 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
804 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
805 if (index
!= (i
>> 1))
807 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
815 slots
= SCM_CDR (slots
);
816 getters_n_setters
= SCM_CDR (getters_n_setters
);
818 if (!scm_is_null (slots
))
821 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
823 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
824 return SCM_UNSPECIFIED
;
828 static void prep_hashsets (SCM
);
830 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
831 (SCM
class, SCM dsupers
),
833 #define FUNC_NAME s_scm_sys_inherit_magic_x
835 SCM_VALIDATE_INSTANCE (1, class);
836 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
837 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
839 prep_hashsets (class);
841 return SCM_UNSPECIFIED
;
846 prep_hashsets (SCM
class)
850 for (i
= 0; i
< 8; ++i
)
851 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
854 /******************************************************************************/
857 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
859 SCM z
, cpl
, slots
, nfields
, g_n_s
;
861 /* Allocate one instance */
862 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
864 /* Initialize its slots */
865 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
866 cpl
= compute_cpl (z
);
867 slots
= build_slots_list (maplist (dslots
), cpl
);
868 nfields
= scm_from_int (scm_ilength (slots
));
869 g_n_s
= compute_getters_n_setters (slots
);
871 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
872 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
873 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
874 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
875 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
876 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
877 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
878 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
879 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
881 /* Add this class in the direct-subclasses slot of dsupers */
884 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
885 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
886 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
887 scm_si_direct_subclasses
)));
894 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
896 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
897 scm_sys_prep_layout_x (z
);
898 scm_sys_inherit_magic_x (z
, dsupers
);
902 /******************************************************************************/
904 SCM_SYMBOL (sym_layout
, "layout");
905 SCM_SYMBOL (sym_flags
, "flags");
906 SCM_SYMBOL (sym_self
, "%self");
907 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
908 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
909 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
910 SCM_SYMBOL (sym_print
, "print");
911 SCM_SYMBOL (sym_procedure
, "procedure");
912 SCM_SYMBOL (sym_setter
, "setter");
913 SCM_SYMBOL (sym_redefined
, "redefined");
914 SCM_SYMBOL (sym_h0
, "h0");
915 SCM_SYMBOL (sym_h1
, "h1");
916 SCM_SYMBOL (sym_h2
, "h2");
917 SCM_SYMBOL (sym_h3
, "h3");
918 SCM_SYMBOL (sym_h4
, "h4");
919 SCM_SYMBOL (sym_h5
, "h5");
920 SCM_SYMBOL (sym_h6
, "h6");
921 SCM_SYMBOL (sym_h7
, "h7");
922 SCM_SYMBOL (sym_name
, "name");
923 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
924 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
925 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
926 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
927 SCM_SYMBOL (sym_cpl
, "cpl");
928 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
929 SCM_SYMBOL (sym_slots
, "slots");
930 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
931 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
932 SCM_SYMBOL (sym_nfields
, "nfields");
936 build_class_class_slots (void)
938 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
939 SCM_CLASS_CLASS_LAYOUT */
941 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
942 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
943 scm_list_3 (sym_self
, k_class
, scm_class_self
),
944 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
945 scm_list_1 (sym_print
),
946 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
947 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
948 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
949 scm_list_1 (sym_redefined
),
950 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
951 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
952 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
953 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
954 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
955 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
956 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
957 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
958 scm_list_1 (sym_direct_supers
),
959 scm_list_1 (sym_direct_slots
),
960 scm_list_1 (sym_direct_subclasses
),
961 scm_list_1 (sym_direct_methods
),
962 scm_list_1 (sym_cpl
),
963 scm_list_1 (sym_default_slot_definition_class
),
964 scm_list_1 (sym_slots
),
965 scm_list_1 (sym_getters_n_setters
),
966 scm_list_1 (sym_keyword_access
),
967 scm_list_1 (sym_nfields
),
972 create_basic_classes (void)
974 /* SCM slots_of_class = build_class_class_slots (); */
977 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
978 SCM name
= scm_from_latin1_symbol ("<class>");
979 scm_class_class
= scm_make_vtable_vtable (cs
, SCM_INUM0
, SCM_EOL
);
980 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
981 | SCM_CLASSF_METACLASS
));
983 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
984 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
985 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
986 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
987 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
988 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
989 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
990 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
991 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
992 compute_getters_n_setters (slots_of_class)); */
993 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
995 prep_hashsets (scm_class_class
);
997 DEFVAR(name
, scm_class_class
);
1000 name
= scm_from_latin1_symbol ("<top>");
1001 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
1004 DEFVAR(name
, scm_class_top
);
1006 /**** <object> ****/
1007 name
= scm_from_latin1_symbol ("<object>");
1008 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
1009 scm_list_1 (scm_class_top
), SCM_EOL
);
1011 DEFVAR (name
, scm_class_object
);
1013 /* <top> <object> and <class> were partially initialized. Correct them here */
1014 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1016 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1017 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1020 /******************************************************************************/
1022 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1024 "Return @code{#t} if @var{obj} is an instance.")
1025 #define FUNC_NAME s_scm_instance_p
1027 return scm_from_bool (SCM_INSTANCEP (obj
));
1032 /******************************************************************************
1034 * Meta object accessors
1036 ******************************************************************************/
1037 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1039 "Return the class name of @var{obj}.")
1040 #define FUNC_NAME s_scm_class_name
1042 SCM_VALIDATE_CLASS (1, obj
);
1043 return scm_slot_ref (obj
, sym_name
);
1047 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1049 "Return the direct superclasses of the class @var{obj}.")
1050 #define FUNC_NAME s_scm_class_direct_supers
1052 SCM_VALIDATE_CLASS (1, obj
);
1053 return scm_slot_ref (obj
, sym_direct_supers
);
1057 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1059 "Return the direct slots of the class @var{obj}.")
1060 #define FUNC_NAME s_scm_class_direct_slots
1062 SCM_VALIDATE_CLASS (1, obj
);
1063 return scm_slot_ref (obj
, sym_direct_slots
);
1067 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1069 "Return the direct subclasses of the class @var{obj}.")
1070 #define FUNC_NAME s_scm_class_direct_subclasses
1072 SCM_VALIDATE_CLASS (1, obj
);
1073 return scm_slot_ref(obj
, sym_direct_subclasses
);
1077 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1079 "Return the direct methods of the class @var{obj}")
1080 #define FUNC_NAME s_scm_class_direct_methods
1082 SCM_VALIDATE_CLASS (1, obj
);
1083 return scm_slot_ref (obj
, sym_direct_methods
);
1087 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1089 "Return the class precedence list of the class @var{obj}.")
1090 #define FUNC_NAME s_scm_class_precedence_list
1092 SCM_VALIDATE_CLASS (1, obj
);
1093 return scm_slot_ref (obj
, sym_cpl
);
1097 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1099 "Return the slot list of the class @var{obj}.")
1100 #define FUNC_NAME s_scm_class_slots
1102 SCM_VALIDATE_CLASS (1, obj
);
1103 return scm_slot_ref (obj
, sym_slots
);
1107 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1109 "Return the name of the generic function @var{obj}.")
1110 #define FUNC_NAME s_scm_generic_function_name
1112 SCM_VALIDATE_GENERIC (1, obj
);
1113 return scm_procedure_property (obj
, scm_sym_name
);
1117 SCM_SYMBOL (sym_methods
, "methods");
1118 SCM_SYMBOL (sym_extended_by
, "extended-by");
1119 SCM_SYMBOL (sym_extends
, "extends");
1122 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1124 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1125 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1126 while (!scm_is_null (gfs
))
1128 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1129 gfs
= SCM_CDR (gfs
);
1131 return method_lists
;
1135 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1137 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1139 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1140 while (!scm_is_null (gfs
))
1142 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1143 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1146 gfs
= SCM_CDR (gfs
);
1149 return method_lists
;
1152 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1154 "Return the methods of the generic function @var{obj}.")
1155 #define FUNC_NAME s_scm_generic_function_methods
1158 SCM_VALIDATE_GENERIC (1, obj
);
1159 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1160 methods
= fold_downward_gf_methods (methods
, obj
);
1161 return scm_append (methods
);
1165 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1167 "Return the generic function for the method @var{obj}.")
1168 #define FUNC_NAME s_scm_method_generic_function
1170 SCM_VALIDATE_METHOD (1, obj
);
1171 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1175 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1177 "Return specializers of the method @var{obj}.")
1178 #define FUNC_NAME s_scm_method_specializers
1180 SCM_VALIDATE_METHOD (1, obj
);
1181 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1185 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1187 "Return the procedure of the method @var{obj}.")
1188 #define FUNC_NAME s_scm_method_procedure
1190 SCM_VALIDATE_METHOD (1, obj
);
1191 return scm_slot_ref (obj
, sym_procedure
);
1195 /******************************************************************************
1197 * S l o t a c c e s s
1199 ******************************************************************************/
1201 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1203 "Return the unbound value.")
1204 #define FUNC_NAME s_scm_make_unbound
1206 return SCM_GOOPS_UNBOUND
;
1210 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1212 "Return @code{#t} if @var{obj} is unbound.")
1213 #define FUNC_NAME s_scm_unbound_p
1215 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1219 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1220 (SCM value
, SCM obj
),
1221 "Return @var{value} if it is bound, and invoke the\n"
1222 "@var{slot-unbound} method of @var{obj} if it is not.")
1223 #define FUNC_NAME s_scm_assert_bound
1225 if (SCM_GOOPS_UNBOUNDP (value
))
1226 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1231 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1232 (SCM obj
, SCM index
),
1233 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1234 "the value from @var{obj}.")
1235 #define FUNC_NAME s_scm_at_assert_bound_ref
1237 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1238 if (SCM_GOOPS_UNBOUNDP (value
))
1239 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1244 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1245 (SCM obj
, SCM index
),
1246 "Return the slot value with index @var{index} from @var{obj}.")
1247 #define FUNC_NAME s_scm_sys_fast_slot_ref
1251 SCM_VALIDATE_INSTANCE (1, obj
);
1252 i
= scm_to_unsigned_integer (index
, 0,
1253 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1256 return SCM_SLOT (obj
, i
);
1260 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1261 (SCM obj
, SCM index
, SCM value
),
1262 "Set the slot with index @var{index} in @var{obj} to\n"
1264 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1268 SCM_VALIDATE_INSTANCE (1, obj
);
1269 i
= scm_to_unsigned_integer (index
, 0,
1270 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1274 SCM_SET_SLOT (obj
, i
, value
);
1276 return SCM_UNSPECIFIED
;
1284 /* In the future, this function will return the effective slot
1285 * definition associated with SLOT_NAME. Now it just returns some of
1286 * the information which will be stored in the effective slot
1291 slot_definition_using_name (SCM
class, SCM slot_name
)
1293 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1294 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1295 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1296 return SCM_CAR (slots
);
1301 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1302 #define FUNC_NAME "%get-slot-value"
1304 SCM access
= SCM_CDDR (slotdef
);
1306 * - access is an integer (the offset of this slot in the slots vector)
1307 * - otherwise (car access) is the getter function to apply
1309 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1310 * we can just assume fixnums here.
1312 if (SCM_I_INUMP (access
))
1313 /* Don't poke at the slots directly, because scm_struct_ref handles the
1314 access bits for us. */
1315 return scm_struct_ref (obj
, access
);
1317 return scm_call_1 (SCM_CAR (access
), obj
);
1322 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1324 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1325 if (scm_is_true (slotdef
))
1326 return get_slot_value (class, obj
, slotdef
);
1328 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1332 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1333 #define FUNC_NAME "%set-slot-value"
1335 SCM access
= SCM_CDDR (slotdef
);
1337 * - access is an integer (the offset of this slot in the slots vector)
1338 * - otherwise (cadr access) is the setter function to apply
1340 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1341 * we can just assume fixnums here.
1343 if (SCM_I_INUMP (access
))
1344 /* obey permissions bits via going through struct-set! */
1345 scm_struct_set_x (obj
, access
, value
);
1347 /* ((cadr l) obj value) */
1348 scm_call_2 (SCM_CADR (access
), obj
, value
);
1349 return SCM_UNSPECIFIED
;
1354 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1356 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1357 if (scm_is_true (slotdef
))
1358 return set_slot_value (class, obj
, slotdef
, value
);
1360 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1364 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1368 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1369 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1375 /* ======================================== */
1377 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1378 (SCM
class, SCM obj
, SCM slot_name
),
1380 #define FUNC_NAME s_scm_slot_ref_using_class
1384 SCM_VALIDATE_CLASS (1, class);
1385 SCM_VALIDATE_INSTANCE (2, obj
);
1386 SCM_VALIDATE_SYMBOL (3, slot_name
);
1388 res
= get_slot_value_using_name (class, obj
, slot_name
);
1389 if (SCM_GOOPS_UNBOUNDP (res
))
1390 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1396 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1397 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1399 #define FUNC_NAME s_scm_slot_set_using_class_x
1401 SCM_VALIDATE_CLASS (1, class);
1402 SCM_VALIDATE_INSTANCE (2, obj
);
1403 SCM_VALIDATE_SYMBOL (3, slot_name
);
1405 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1410 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1411 (SCM
class, SCM obj
, SCM slot_name
),
1413 #define FUNC_NAME s_scm_slot_bound_using_class_p
1415 SCM_VALIDATE_CLASS (1, class);
1416 SCM_VALIDATE_INSTANCE (2, obj
);
1417 SCM_VALIDATE_SYMBOL (3, slot_name
);
1419 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1425 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1426 (SCM
class, SCM obj
, SCM slot_name
),
1428 #define FUNC_NAME s_scm_slot_exists_using_class_p
1430 SCM_VALIDATE_CLASS (1, class);
1431 SCM_VALIDATE_INSTANCE (2, obj
);
1432 SCM_VALIDATE_SYMBOL (3, slot_name
);
1433 return test_slot_existence (class, obj
, slot_name
);
1438 /* ======================================== */
1440 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1441 (SCM obj
, SCM slot_name
),
1442 "Return the value from @var{obj}'s slot with the name\n"
1444 #define FUNC_NAME s_scm_slot_ref
1448 SCM_VALIDATE_INSTANCE (1, obj
);
1449 TEST_CHANGE_CLASS (obj
, class);
1451 res
= get_slot_value_using_name (class, obj
, slot_name
);
1452 if (SCM_GOOPS_UNBOUNDP (res
))
1453 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1458 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1459 (SCM obj
, SCM slot_name
, SCM value
),
1460 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1461 #define FUNC_NAME s_scm_slot_set_x
1465 SCM_VALIDATE_INSTANCE (1, obj
);
1466 TEST_CHANGE_CLASS(obj
, class);
1468 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1472 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1474 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1475 (SCM obj
, SCM slot_name
),
1476 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1478 #define FUNC_NAME s_scm_slot_bound_p
1482 SCM_VALIDATE_INSTANCE (1, obj
);
1483 TEST_CHANGE_CLASS(obj
, class);
1485 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1493 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1494 (SCM obj
, SCM slot_name
),
1495 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1496 #define FUNC_NAME s_scm_slot_exists_p
1500 SCM_VALIDATE_INSTANCE (1, obj
);
1501 SCM_VALIDATE_SYMBOL (2, slot_name
);
1502 TEST_CHANGE_CLASS (obj
, class);
1504 return test_slot_existence (class, obj
, slot_name
);
1509 /******************************************************************************
1511 * %allocate-instance (the low level instance allocation primitive)
1513 ******************************************************************************/
1515 static void clear_method_cache (SCM
);
1517 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1518 (SCM
class, SCM initargs
),
1519 "Create a new instance of class @var{class} and initialize it\n"
1520 "from the arguments @var{initargs}.")
1521 #define FUNC_NAME s_scm_sys_allocate_instance
1524 scm_t_signed_bits n
, i
;
1527 SCM_VALIDATE_CLASS (1, class);
1529 /* FIXME: duplicates some of scm_make_struct. */
1531 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1532 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1534 layout
= SCM_VTABLE_LAYOUT (class);
1536 /* Set all SCM-holding slots to unbound */
1537 for (i
= 0; i
< n
; i
++)
1539 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1541 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1543 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1545 SCM_STRUCT_DATA (obj
)[i
] = 0;
1548 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1549 clear_method_cache (obj
);
1555 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1556 (SCM obj
, SCM setter
),
1558 #define FUNC_NAME s_scm_sys_set_object_setter_x
1560 SCM_ASSERT (SCM_STRUCTP (obj
)
1561 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1565 SCM_SET_GENERIC_SETTER (obj
, setter
);
1566 return SCM_UNSPECIFIED
;
1570 /******************************************************************************
1572 * %modify-instance (used by change-class to modify in place)
1574 ******************************************************************************/
1576 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1579 #define FUNC_NAME s_scm_sys_modify_instance
1581 SCM_VALIDATE_INSTANCE (1, old
);
1582 SCM_VALIDATE_INSTANCE (2, new);
1584 /* Exchange the data contained in old and new. We exchange rather than
1585 * scratch the old value with new to be correct with GC.
1586 * See "Class redefinition protocol above".
1588 SCM_CRITICAL_SECTION_START
;
1590 scm_t_bits word0
, word1
;
1591 word0
= SCM_CELL_WORD_0 (old
);
1592 word1
= SCM_CELL_WORD_1 (old
);
1593 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1594 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1595 SCM_SET_CELL_WORD_0 (new, word0
);
1596 SCM_SET_CELL_WORD_1 (new, word1
);
1598 SCM_CRITICAL_SECTION_END
;
1599 return SCM_UNSPECIFIED
;
1603 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1606 #define FUNC_NAME s_scm_sys_modify_class
1608 SCM_VALIDATE_CLASS (1, old
);
1609 SCM_VALIDATE_CLASS (2, new);
1611 SCM_CRITICAL_SECTION_START
;
1613 scm_t_bits word0
, word1
;
1614 word0
= SCM_CELL_WORD_0 (old
);
1615 word1
= SCM_CELL_WORD_1 (old
);
1616 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1617 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1618 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1619 SCM_SET_CELL_WORD_0 (new, word0
);
1620 SCM_SET_CELL_WORD_1 (new, word1
);
1621 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1623 SCM_CRITICAL_SECTION_END
;
1624 return SCM_UNSPECIFIED
;
1628 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1631 #define FUNC_NAME s_scm_sys_invalidate_class
1633 SCM_VALIDATE_CLASS (1, class);
1634 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1635 return SCM_UNSPECIFIED
;
1639 /* When instances change class, they finally get a new body, but
1640 * before that, they go through purgatory in hell. Odd as it may
1641 * seem, this data structure saves us from eternal suffering in
1642 * infinite recursions.
1645 static scm_t_bits
**hell
;
1646 static long n_hell
= 1; /* one place for the evil one himself */
1647 static long hell_size
= 4;
1648 static SCM hell_mutex
;
1654 for (i
= 1; i
< n_hell
; ++i
)
1655 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1661 go_to_hell (void *o
)
1664 scm_lock_mutex (hell_mutex
);
1665 if (n_hell
>= hell_size
)
1668 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1670 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1671 scm_unlock_mutex (hell_mutex
);
1675 go_to_heaven (void *o
)
1678 scm_lock_mutex (hell_mutex
);
1679 hell
[burnin (obj
)] = hell
[--n_hell
];
1680 scm_unlock_mutex (hell_mutex
);
1684 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1687 purgatory (SCM obj
, SCM new_class
)
1689 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1692 /* This function calls the generic function change-class for all
1693 * instances which aren't currently undergoing class change.
1697 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1701 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1702 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1703 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1704 purgatory (obj
, new_class
);
1709 /******************************************************************************
1715 * GGG E N E R I C F U N C T I O N S
1717 * This implementation provides
1718 * - generic functions (with class specializers)
1721 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1723 ******************************************************************************/
1725 SCM_KEYWORD (k_name
, "name");
1727 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1731 scm_apply_generic (SCM gf
, SCM args
)
1733 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1737 scm_call_generic_0 (SCM gf
)
1739 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1743 scm_call_generic_1 (SCM gf
, SCM a1
)
1745 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1749 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1751 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1755 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1757 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1760 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1762 make_dispatch_procedure (SCM gf
)
1764 static SCM var
= SCM_BOOL_F
;
1765 if (scm_is_false (var
))
1766 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1767 sym_delayed_compile
);
1768 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1772 clear_method_cache (SCM gf
)
1774 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1775 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1778 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1781 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1783 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1784 clear_method_cache (gf
);
1785 return SCM_UNSPECIFIED
;
1789 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1792 #define FUNC_NAME s_scm_generic_capability_p
1794 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1795 proc
, SCM_ARG1
, FUNC_NAME
);
1796 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1800 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1803 #define FUNC_NAME s_scm_enable_primitive_generic_x
1805 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1806 while (!scm_is_null (subrs
))
1808 SCM subr
= SCM_CAR (subrs
);
1809 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1810 SCM_SET_SUBR_GENERIC (subr
,
1811 scm_make (scm_list_3 (scm_class_generic
,
1813 SCM_SUBR_NAME (subr
))));
1814 subrs
= SCM_CDR (subrs
);
1816 return SCM_UNSPECIFIED
;
1820 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1821 (SCM subr
, SCM generic
),
1823 #define FUNC_NAME s_scm_set_primitive_generic_x
1825 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1826 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1827 SCM_SET_SUBR_GENERIC (subr
, generic
);
1828 return SCM_UNSPECIFIED
;
1832 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1835 #define FUNC_NAME s_scm_primitive_generic_generic
1837 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1839 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1840 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1841 return *SCM_SUBR_GENERIC (subr
);
1843 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1847 typedef struct t_extension
{
1848 struct t_extension
*next
;
1854 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1856 static const char extension_gc_hint
[] = "GOOPS extension";
1858 static t_extension
*extensions
= 0;
1861 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1866 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1867 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1868 gf
= *SCM_SUBR_GENERIC (extended
);
1869 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1871 SCM_SUBR_NAME (extension
));
1872 SCM_SET_SUBR_GENERIC (extension
, gext
);
1876 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1878 t_extension
**loc
= &extensions
;
1879 /* Make sure that extensions are placed before their own
1880 * extensions in the extensions list. O(N^2) algorithm, but
1881 * extensions of primitive generics are rare.
1883 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1884 loc
= &(*loc
)->next
;
1886 e
->extended
= extended
;
1887 e
->extension
= extension
;
1893 setup_extended_primitive_generics ()
1897 t_extension
*e
= extensions
;
1898 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1899 extensions
= e
->next
;
1903 /******************************************************************************
1905 * Protocol for calling a generic fumction
1906 * This protocol is roughly equivalent to (parameter are a little bit different
1907 * for efficiency reasons):
1909 * + apply-generic (gf args)
1910 * + compute-applicable-methods (gf args ...)
1911 * + sort-applicable-methods (methods args)
1912 * + apply-methods (gf methods args)
1914 * apply-methods calls make-next-method to build the "continuation" of a a
1915 * method. Applying a next-method will call apply-next-method which in
1916 * turn will call apply again to call effectively the following method.
1918 ******************************************************************************/
1921 applicablep (SCM actual
, SCM formal
)
1923 /* We already know that the cpl is well formed. */
1924 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1928 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1930 register SCM s1
, s2
;
1934 * m1 and m2 can have != length (i.e. one can be one element longer than the
1935 * other when we have a dotted parameter list). For instance, with the call
1938 * (define-method M (a . l) ....)
1939 * (define-method M (a) ....)
1941 * we consider that the second method is more specific.
1943 * BTW, targs is an array of types. We don't need it's size since
1944 * we already know that m1 and m2 are applicable (no risk to go past
1945 * the end of this array).
1948 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1949 if (scm_is_null(s1
)) return 1;
1950 if (scm_is_null(s2
)) return 0;
1951 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1952 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1954 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1955 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1957 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1960 return 0;/* should not occur! */
1963 return 0; /* should not occur! */
1966 #define BUFFSIZE 32 /* big enough for most uses */
1969 scm_i_vector2list (SCM l
, long len
)
1972 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1974 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1975 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1981 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1984 SCM
*v
, vector
= SCM_EOL
;
1985 SCM buffer
[BUFFSIZE
];
1986 SCM save
= method_list
;
1987 scm_t_array_handle handle
;
1989 /* For reasonably sized method_lists we can try to avoid all the
1990 * consing and reorder the list in place...
1991 * This idea is due to David McClain <Dave_McClain@msn.com>
1993 if (size
<= BUFFSIZE
)
1995 for (i
= 0; i
< size
; i
++)
1997 buffer
[i
] = SCM_CAR (method_list
);
1998 method_list
= SCM_CDR (method_list
);
2004 /* Too many elements in method_list to keep everything locally */
2005 vector
= scm_i_vector2list (save
, size
);
2006 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2009 /* Use a simple shell sort since it is generally faster than qsort on
2010 * small vectors (which is probably mostly the case when we have to
2011 * sort a list of applicable methods).
2013 for (incr
= size
/ 2; incr
; incr
/= 2)
2015 for (i
= incr
; i
< size
; i
++)
2017 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2019 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2023 SCM tmp
= v
[j
+ incr
];
2031 if (size
<= BUFFSIZE
)
2033 /* We did it in locally, so restore the original list (reordered) in-place */
2034 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2036 SCM_SETCAR (method_list
, *v
);
2037 method_list
= SCM_CDR (method_list
);
2042 /* If we are here, that's that we did it the hard way... */
2043 scm_array_handle_release (&handle
);
2044 return scm_vector_to_list (vector
);
2048 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2052 SCM l
, fl
, applicable
= SCM_EOL
;
2054 SCM buffer
[BUFFSIZE
];
2058 scm_t_array_handle handle
;
2060 /* Build the list of arguments types */
2061 if (len
>= BUFFSIZE
)
2063 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2064 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2067 note that we don't have to work to reset the generation
2068 count. TMP is a new vector anyway, and it is found
2075 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2076 *p
++ = scm_class_of (SCM_CAR (args
));
2078 /* Build a list of all applicable methods */
2079 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2081 fl
= SPEC_OF (SCM_CAR (l
));
2082 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2084 if (SCM_INSTANCEP (fl
)
2085 /* We have a dotted argument list */
2086 || (i
>= len
&& scm_is_null (fl
)))
2087 { /* both list exhausted */
2088 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2094 || !applicablep (types
[i
], SCM_CAR (fl
)))
2099 if (len
>= BUFFSIZE
)
2100 scm_array_handle_release (&handle
);
2106 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2107 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2113 : sort_applicable_methods (applicable
, count
, types
));
2117 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2120 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2123 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2124 #define FUNC_NAME s_sys_compute_applicable_methods
2127 SCM_VALIDATE_GENERIC (1, gf
);
2128 n
= scm_ilength (args
);
2129 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2130 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2134 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2135 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2136 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2137 scm_sys_compute_applicable_methods
));
2139 /******************************************************************************
2141 * A simple make (which will be redefined later in Scheme)
2142 * This version handles only creation of gf, methods and classes (no instances)
2144 * Since this code will disappear when Goops will be fully booted,
2145 * no precaution is taken to be efficient.
2147 ******************************************************************************/
2149 SCM_KEYWORD (k_setter
, "setter");
2150 SCM_KEYWORD (k_specializers
, "specializers");
2151 SCM_KEYWORD (k_procedure
, "procedure");
2152 SCM_KEYWORD (k_formals
, "formals");
2153 SCM_KEYWORD (k_body
, "body");
2154 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2155 SCM_KEYWORD (k_dsupers
, "dsupers");
2156 SCM_KEYWORD (k_slots
, "slots");
2157 SCM_KEYWORD (k_gf
, "generic-function");
2159 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2161 "Make a new object. @var{args} must contain the class and\n"
2162 "all necessary initialization information.")
2163 #define FUNC_NAME s_scm_make
2166 long len
= scm_ilength (args
);
2168 if (len
<= 0 || (len
& 1) == 0)
2169 SCM_WRONG_NUM_ARGS ();
2171 class = SCM_CAR(args
);
2172 args
= SCM_CDR(args
);
2174 if (scm_is_eq (class, scm_class_generic
)
2175 || scm_is_eq (class, scm_class_accessor
))
2177 z
= scm_make_struct (class, SCM_INUM0
,
2178 scm_list_4 (SCM_BOOL_F
,
2182 scm_set_procedure_property_x (z
, scm_sym_name
,
2183 scm_get_keyword (k_name
,
2186 clear_method_cache (z
);
2187 if (scm_is_eq (class, scm_class_accessor
))
2189 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2190 if (scm_is_true (setter
))
2191 scm_sys_set_object_setter_x (z
, setter
);
2196 z
= scm_sys_allocate_instance (class, args
);
2198 if (scm_is_eq (class, scm_class_method
)
2199 || scm_is_eq (class, scm_class_accessor_method
))
2201 SCM_SET_SLOT (z
, scm_si_generic_function
,
2202 scm_i_get_keyword (k_gf
,
2207 SCM_SET_SLOT (z
, scm_si_specializers
,
2208 scm_i_get_keyword (k_specializers
,
2213 SCM_SET_SLOT (z
, scm_si_procedure
,
2214 scm_i_get_keyword (k_procedure
,
2219 SCM_SET_SLOT (z
, scm_si_formals
,
2220 scm_i_get_keyword (k_formals
,
2225 SCM_SET_SLOT (z
, scm_si_body
,
2226 scm_i_get_keyword (k_body
,
2231 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2232 scm_i_get_keyword (k_make_procedure
,
2240 /* In all the others case, make a new class .... No instance here */
2241 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2242 scm_i_get_keyword (k_name
,
2245 scm_from_latin1_symbol ("???"),
2247 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2248 scm_i_get_keyword (k_dsupers
,
2253 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2254 scm_i_get_keyword (k_slots
,
2265 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2268 #define FUNC_NAME s_scm_find_method
2271 long len
= scm_ilength (l
);
2274 SCM_WRONG_NUM_ARGS ();
2276 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2277 SCM_VALIDATE_GENERIC (1, gf
);
2278 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2279 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2281 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2285 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2286 (SCM m1
, SCM m2
, SCM targs
),
2287 "Return true if method @var{m1} is more specific than @var{m2} "
2288 "given the argument types (classes) listed in @var{targs}.")
2289 #define FUNC_NAME s_scm_sys_method_more_specific_p
2293 long i
, len
, m1_specs
, m2_specs
;
2294 scm_t_array_handle handle
;
2296 SCM_VALIDATE_METHOD (1, m1
);
2297 SCM_VALIDATE_METHOD (2, m2
);
2299 len
= scm_ilength (targs
);
2300 m1_specs
= scm_ilength (SPEC_OF (m1
));
2301 m2_specs
= scm_ilength (SPEC_OF (m2
));
2302 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2303 targs
, SCM_ARG3
, FUNC_NAME
);
2305 /* Verify that all the arguments of TARGS are classes and place them
2308 v
= scm_c_make_vector (len
, SCM_EOL
);
2309 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2311 for (i
= 0, l
= targs
;
2312 i
< len
&& scm_is_pair (l
);
2313 i
++, l
= SCM_CDR (l
))
2315 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2316 v_elts
[i
] = SCM_CAR (l
);
2318 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2320 scm_array_handle_release (&handle
);
2328 /******************************************************************************
2332 ******************************************************************************/
2334 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2335 assuming that currently the reverse is true. Recalculate slots and
2336 associated getters-n-setters. */
2338 fix_cpl (SCM c
, SCM before
, SCM after
)
2340 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2341 SCM ls
= scm_c_memq (after
, cpl
);
2344 if (scm_is_false (ls
))
2345 /* if this condition occurs, fix_cpl should not be applied this way */
2348 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2349 SCM_SETCAR (ls
, before
);
2350 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2352 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2353 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2354 SCM g_n_s
= compute_getters_n_setters (slots
);
2355 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2356 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2362 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2364 SCM tmp
= scm_from_locale_symbol (name
);
2366 *var
= scm_basic_make_class (meta
, tmp
,
2367 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2373 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2376 create_standard_classes (void)
2379 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2380 scm_from_latin1_symbol ("specializers"),
2382 scm_from_latin1_symbol ("formals"),
2383 scm_from_latin1_symbol ("body"),
2384 scm_from_latin1_symbol ("make-procedure"),
2386 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2388 k_slot_definition
));
2389 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2390 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2393 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2396 scm_from_latin1_symbol ("effective-methods"));
2397 SCM setter_slots
= scm_list_1 (sym_setter
);
2398 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2401 /* Foreign class slot classes */
2402 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2403 scm_class_class
, scm_class_top
, SCM_EOL
);
2404 make_stdcls (&scm_class_protected
, "<protected-slot>",
2405 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2406 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2407 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2408 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2409 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2410 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2411 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2412 make_stdcls (&scm_class_self
, "<self-slot>",
2413 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2414 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2416 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2418 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2420 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2422 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2424 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2426 make_stdcls (&scm_class_scm
, "<scm-slot>",
2427 scm_class_class
, scm_class_protected
, SCM_EOL
);
2428 make_stdcls (&scm_class_int
, "<int-slot>",
2429 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2430 make_stdcls (&scm_class_float
, "<float-slot>",
2431 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2432 make_stdcls (&scm_class_double
, "<double-slot>",
2433 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2435 /* Continue initialization of class <class> */
2437 slots
= build_class_class_slots ();
2438 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2439 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2440 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2441 compute_getters_n_setters (slots
));
2443 /* scm_class_generic functions classes */
2444 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2445 scm_class_class
, scm_class_class
, SCM_EOL
);
2446 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2447 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2448 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2449 make_stdcls (&scm_class_method
, "<method>",
2450 scm_class_class
, scm_class_object
, method_slots
);
2451 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2452 scm_class_class
, scm_class_method
, amethod_slots
);
2453 make_stdcls (&scm_class_applicable
, "<applicable>",
2454 scm_class_class
, scm_class_top
, SCM_EOL
);
2455 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2456 scm_class_applicable_struct_class
,
2457 scm_list_2 (scm_class_object
, scm_class_applicable
),
2458 scm_list_1 (sym_procedure
));
2459 make_stdcls (&scm_class_generic
, "<generic>",
2460 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2461 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2462 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2463 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2464 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2465 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2466 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2467 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2468 make_stdcls (&scm_class_accessor
, "<accessor>",
2469 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2470 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2471 make_stdcls (&scm_class_extended_generic_with_setter
,
2472 "<extended-generic-with-setter>",
2473 scm_class_applicable_struct_class
,
2474 scm_list_2 (scm_class_extended_generic
,
2475 scm_class_generic_with_setter
),
2477 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2478 SCM_CLASSF_PURE_GENERIC
);
2479 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2480 scm_class_applicable_struct_class
,
2481 scm_list_2 (scm_class_accessor
,
2482 scm_class_extended_generic_with_setter
),
2484 /* <extended-generic> is misplaced. */
2485 fix_cpl (scm_class_extended_accessor
,
2486 scm_class_extended_generic
, scm_class_generic_with_setter
);
2487 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2489 /* Primitive types classes */
2490 make_stdcls (&scm_class_boolean
, "<boolean>",
2491 scm_class_class
, scm_class_top
, SCM_EOL
);
2492 make_stdcls (&scm_class_char
, "<char>",
2493 scm_class_class
, scm_class_top
, SCM_EOL
);
2494 make_stdcls (&scm_class_list
, "<list>",
2495 scm_class_class
, scm_class_top
, SCM_EOL
);
2496 make_stdcls (&scm_class_pair
, "<pair>",
2497 scm_class_class
, scm_class_list
, SCM_EOL
);
2498 make_stdcls (&scm_class_null
, "<null>",
2499 scm_class_class
, scm_class_list
, SCM_EOL
);
2500 make_stdcls (&scm_class_string
, "<string>",
2501 scm_class_class
, scm_class_top
, SCM_EOL
);
2502 make_stdcls (&scm_class_symbol
, "<symbol>",
2503 scm_class_class
, scm_class_top
, SCM_EOL
);
2504 make_stdcls (&scm_class_vector
, "<vector>",
2505 scm_class_class
, scm_class_top
, SCM_EOL
);
2506 make_stdcls (&class_foreign
, "<foreign>",
2507 scm_class_class
, scm_class_top
, SCM_EOL
);
2508 make_stdcls (&class_hashtable
, "<hashtable>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&class_fluid
, "<fluid>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_frame
, "<frame>",
2515 scm_class_class
, scm_class_top
, SCM_EOL
);
2516 make_stdcls (&class_objcode
, "<objcode>",
2517 scm_class_class
, scm_class_top
, SCM_EOL
);
2518 make_stdcls (&class_vm
, "<vm>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2521 scm_class_class
, scm_class_top
, SCM_EOL
);
2522 make_stdcls (&class_bytevector
, "<bytevector>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&class_uvec
, "<uvec>",
2525 scm_class_class
, class_bytevector
, SCM_EOL
);
2526 make_stdcls (&scm_class_number
, "<number>",
2527 scm_class_class
, scm_class_top
, SCM_EOL
);
2528 make_stdcls (&scm_class_complex
, "<complex>",
2529 scm_class_class
, scm_class_number
, SCM_EOL
);
2530 make_stdcls (&scm_class_real
, "<real>",
2531 scm_class_class
, scm_class_complex
, SCM_EOL
);
2532 make_stdcls (&scm_class_integer
, "<integer>",
2533 scm_class_class
, scm_class_real
, SCM_EOL
);
2534 make_stdcls (&scm_class_fraction
, "<fraction>",
2535 scm_class_class
, scm_class_real
, SCM_EOL
);
2536 make_stdcls (&scm_class_keyword
, "<keyword>",
2537 scm_class_class
, scm_class_top
, SCM_EOL
);
2538 make_stdcls (&scm_class_unknown
, "<unknown>",
2539 scm_class_class
, scm_class_top
, SCM_EOL
);
2540 make_stdcls (&scm_class_procedure
, "<procedure>",
2541 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2542 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2543 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2544 make_stdcls (&scm_class_port
, "<port>",
2545 scm_class_class
, scm_class_top
, SCM_EOL
);
2546 make_stdcls (&scm_class_input_port
, "<input-port>",
2547 scm_class_class
, scm_class_port
, SCM_EOL
);
2548 make_stdcls (&scm_class_output_port
, "<output-port>",
2549 scm_class_class
, scm_class_port
, SCM_EOL
);
2550 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2552 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2556 /**********************************************************************
2560 **********************************************************************/
2563 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2569 sprintf (buffer
, template, type_name
);
2570 name
= scm_from_locale_symbol (buffer
);
2573 name
= SCM_GOOPS_UNBOUND
;
2575 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2576 name
, supers
, SCM_EOL
);
2578 /* Only define name if doesn't already exist. */
2579 if (!SCM_GOOPS_UNBOUNDP (name
)
2580 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2581 DEFVAR (name
, class);
2586 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2589 if (scm_is_true (type_name_sym
))
2591 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2592 scm_symbol_to_string (type_name_sym
),
2593 scm_from_locale_string (">")));
2594 name
= scm_string_to_symbol (name
);
2597 name
= SCM_GOOPS_UNBOUND
;
2599 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2600 name
, supers
, SCM_EOL
);
2602 /* Only define name if doesn't already exist. */
2603 if (!SCM_GOOPS_UNBOUNDP (name
)
2604 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2605 DEFVAR (name
, class);
2610 scm_make_extended_class (char const *type_name
, int applicablep
)
2612 return make_class_from_template ("<%s>",
2614 scm_list_1 (applicablep
2615 ? scm_class_applicable
2621 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2623 return make_class_from_symbol (type_name_sym
,
2624 scm_list_1 (applicablep
2625 ? scm_class_applicable
2631 scm_i_inherit_applicable (SCM c
)
2633 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2635 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2636 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2637 /* patch scm_class_applicable into direct-supers */
2638 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2639 if (scm_is_false (top
))
2640 dsupers
= scm_append (scm_list_2 (dsupers
,
2641 scm_list_1 (scm_class_applicable
)));
2644 SCM_SETCAR (top
, scm_class_applicable
);
2645 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2647 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2648 /* patch scm_class_applicable into cpl */
2649 top
= scm_c_memq (scm_class_top
, cpl
);
2650 if (scm_is_false (top
))
2654 SCM_SETCAR (top
, scm_class_applicable
);
2655 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2657 /* add class to direct-subclasses of scm_class_applicable */
2658 SCM_SET_SLOT (scm_class_applicable
,
2659 scm_si_direct_subclasses
,
2660 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2661 scm_si_direct_subclasses
)));
2666 create_smob_classes (void)
2670 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2671 scm_smob_class
[i
] = SCM_BOOL_F
;
2673 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2675 for (i
= 0; i
< scm_numsmob
; ++i
)
2676 if (scm_is_false (scm_smob_class
[i
]))
2677 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2678 scm_smobs
[i
].apply
!= 0);
2682 scm_make_port_classes (long ptobnum
, char *type_name
)
2684 SCM c
, class = make_class_from_template ("<%s-port>",
2686 scm_list_1 (scm_class_port
),
2688 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2689 = make_class_from_template ("<%s-input-port>",
2691 scm_list_2 (class, scm_class_input_port
),
2693 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2694 = make_class_from_template ("<%s-output-port>",
2696 scm_list_2 (class, scm_class_output_port
),
2698 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2700 = make_class_from_template ("<%s-input-output-port>",
2702 scm_list_2 (class, scm_class_input_output_port
),
2704 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2705 SCM_SET_SLOT (c
, scm_si_cpl
,
2706 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2710 create_port_classes (void)
2714 for (i
= 0; i
< scm_numptob
; ++i
)
2715 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2719 make_struct_class (void *closure SCM_UNUSED
,
2720 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2722 if (scm_is_false (data
))
2723 scm_i_define_class_for_vtable (vtable
);
2724 return SCM_UNSPECIFIED
;
2728 create_struct_classes (void)
2730 /* FIXME: take the vtable_class_map while initializing goops? */
2731 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2735 /**********************************************************************
2739 **********************************************************************/
2744 if (!goops_loaded_p
)
2745 scm_c_resolve_module ("oop goops");
2749 SCM_SYMBOL (sym_o
, "o");
2750 SCM_SYMBOL (sym_x
, "x");
2752 SCM_KEYWORD (k_accessor
, "accessor");
2753 SCM_KEYWORD (k_getter
, "getter");
2756 scm_ensure_accessor (SCM name
)
2758 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2759 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2761 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2762 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2763 k_name
, name
, k_setter
, gf
));
2770 * Debugging utilities
2773 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2775 "Return @code{#t} if @var{obj} is a pure generic.")
2776 #define FUNC_NAME s_scm_pure_generic_p
2778 return scm_from_bool (SCM_PUREGENERICP (obj
));
2782 #endif /* GUILE_DEBUG */
2788 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2790 "Announce that GOOPS is loaded and perform initialization\n"
2791 "on the C level which depends on the loaded GOOPS modules.")
2792 #define FUNC_NAME s_scm_sys_goops_loaded
2795 var_compute_applicable_methods
=
2796 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2798 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2800 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2802 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2803 var_no_applicable_method
=
2804 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2806 scm_module_variable (scm_module_goops
, sym_change_class
);
2807 setup_extended_primitive_generics ();
2808 return SCM_UNSPECIFIED
;
2812 SCM scm_module_goops
;
2815 scm_init_goops_builtins (void)
2817 scm_module_goops
= scm_current_module ();
2819 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2821 #include "libguile/goops.x"
2823 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2824 hell_mutex
= scm_make_mutex ();
2826 create_basic_classes ();
2827 create_standard_classes ();
2828 create_smob_classes ();
2829 create_struct_classes ();
2830 create_port_classes ();
2833 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2834 scm_no_applicable_method
=
2835 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2836 DEFVAR (name
, scm_no_applicable_method
);
2839 return SCM_UNSPECIFIED
;
2845 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2846 scm_init_goops_builtins
);