1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
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
;
159 static SCM class_vm_cont
;
160 static SCM class_bytevector
;
161 static SCM class_uvec
;
162 static SCM class_array
;
163 static SCM class_bitvector
;
165 static SCM vtable_class_map
= SCM_BOOL_F
;
167 /* Port classes. Allocate 3 times the maximum number of port types so that
168 input ports, output ports, and in/out ports can be stored at different
169 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
170 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
173 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
175 SCM scm_no_applicable_method
;
177 SCM_SYMBOL (scm_sym_define_public
, "define-public");
179 static SCM
scm_make_unbound (void);
180 static SCM
scm_unbound_p (SCM obj
);
181 static SCM
scm_assert_bound (SCM value
, SCM obj
);
182 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
183 static SCM
scm_sys_goops_loaded (void);
184 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
189 scm_i_define_class_for_vtable (SCM vtable
)
193 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
194 if (scm_is_false (vtable_class_map
))
195 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
196 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
198 if (scm_is_false (scm_struct_vtable_p (vtable
)))
201 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
203 if (scm_is_false (class))
205 if (SCM_UNPACK (scm_class_class
))
207 SCM name
= SCM_VTABLE_NAME (vtable
);
208 if (!scm_is_symbol (name
))
209 name
= scm_string_to_symbol (scm_nullstr
);
211 class = scm_make_extended_class_from_symbol
212 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
215 /* `create_struct_classes' will fill this in later. */
218 /* Don't worry about races. This only happens when creating a
219 vtable, which happens by definition in one thread. */
220 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
226 /* This function is used for efficient type dispatch. */
227 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
229 "Return the class of @var{x}.")
230 #define FUNC_NAME s_scm_class_of
232 switch (SCM_ITAG3 (x
))
236 return scm_class_integer
;
240 return scm_class_char
;
241 else if (scm_is_bool (x
))
242 return scm_class_boolean
;
243 else if (scm_is_null (x
))
244 return scm_class_null
;
246 return scm_class_unknown
;
249 switch (SCM_TYP7 (x
))
251 case scm_tcs_cons_nimcar
:
252 return scm_class_pair
;
254 return scm_class_symbol
;
257 return scm_class_vector
;
258 case scm_tc7_pointer
:
259 return class_foreign
;
260 case scm_tc7_hashtable
:
261 return class_hashtable
;
264 case scm_tc7_dynamic_state
:
265 return class_dynamic_state
;
270 case scm_tc7_vm_cont
:
271 return class_vm_cont
;
272 case scm_tc7_bytevector
:
273 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
274 return class_bytevector
;
279 case scm_tc7_bitvector
:
280 return class_bitvector
;
282 return scm_class_string
;
284 switch SCM_TYP16 (x
) {
286 return scm_class_integer
;
288 return scm_class_real
;
289 case scm_tc16_complex
:
290 return scm_class_complex
;
291 case scm_tc16_fraction
:
292 return scm_class_fraction
;
294 case scm_tc7_program
:
295 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
296 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
297 return scm_class_primitive_generic
;
299 return scm_class_procedure
;
303 scm_t_bits type
= SCM_TYP16 (x
);
304 if (type
!= scm_tc16_port_with_ps
)
305 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
306 x
= SCM_PORT_WITH_PS_PORT (x
);
307 /* fall through to ports */
310 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
311 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
312 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
313 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
314 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
316 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
317 return SCM_CLASS_OF (x
);
318 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
321 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
322 scm_change_object_class (x
,
323 SCM_CLASS_OF (x
), /* old */
324 SCM_OBJ_CLASS_REDEF (x
)); /* new */
325 return SCM_CLASS_OF (x
);
328 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
331 return scm_class_pair
;
333 return scm_class_unknown
;
339 /* case scm_tc3_unused: */
343 return scm_class_unknown
;
347 /******************************************************************************
351 * This version doesn't fully handle multiple-inheritance. It serves
352 * only for booting classes and will be overloaded in Scheme
354 ******************************************************************************/
357 map (SCM (*proc
) (SCM
), SCM ls
)
359 if (scm_is_null (ls
))
363 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
366 while (scm_is_pair (ls
))
368 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
380 while (scm_is_pair (ls
))
382 SCM el
= SCM_CAR (ls
);
383 if (scm_is_false (scm_c_memq (el
, res
)))
384 res
= scm_cons (el
, res
);
391 compute_cpl (SCM
class)
394 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
397 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
398 SCM ls
= scm_append (scm_acons (class, supers
,
399 map (compute_cpl
, supers
)));
400 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
404 /******************************************************************************
408 ******************************************************************************/
411 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
415 if (!scm_is_pair (l
))
419 if (!scm_is_symbol (tmp
))
420 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
422 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
423 res
= scm_cons (SCM_CAR (l
), res
);
424 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
427 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
431 check_cpl (SCM slots
, SCM bslots
)
433 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
434 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
435 scm_misc_error ("init-object", "a predefined <class> inherited "
436 "field cannot be redefined", SCM_EOL
);
440 build_class_class_slots (void);
443 build_slots_list (SCM dslots
, SCM cpl
)
445 SCM bslots
, class_slots
;
449 class_slots
= SCM_EOL
;
450 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
454 bslots
= build_class_class_slots ();
455 check_cpl (res
, bslots
);
460 if (scm_is_pair (cpl
))
462 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
464 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
465 scm_si_direct_slots
);
468 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
469 check_cpl (new_slots
, bslots
);
472 /* Move class slots to the head of the list. */
473 class_slots
= new_slots
;
477 res
= scm_append (scm_list_2 (new_slots
, res
));
481 scm_misc_error ("%compute-slots", "malformed cpl argument in "
482 "build_slots_list", SCM_EOL
);
484 /* make sure to add the <class> slots to the head of the list */
486 res
= scm_append (scm_list_2 (class_slots
, res
));
488 /* res contains a list of slots. Remove slots which appears more than once */
489 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
496 while (!scm_is_null (ls
))
498 if (!scm_is_pair (ls
))
499 scm_misc_error ("%compute-slots", "malformed ls argument in "
501 if (!scm_is_pair (SCM_CAR (ls
)))
502 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
509 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
511 "Return a list consisting of the names of all slots belonging to\n"
512 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
514 #define FUNC_NAME s_scm_sys_compute_slots
516 SCM_VALIDATE_CLASS (1, class);
517 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
518 SCM_SLOT (class, scm_si_cpl
));
523 /******************************************************************************
525 * compute-getters-n-setters
527 * This version doesn't handle slot options. It serves only for booting
528 * classes and will be overloaded in Scheme.
530 ******************************************************************************/
532 SCM_KEYWORD (k_init_value
, "init-value");
533 SCM_KEYWORD (k_init_thunk
, "init-thunk");
536 compute_getters_n_setters (SCM slots
)
542 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
544 SCM init
= SCM_BOOL_F
;
545 SCM options
= SCM_CDAR (slots
);
546 if (!scm_is_null (options
))
548 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
549 if (SCM_UNPACK (init
))
551 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
553 scm_list_2 (scm_sym_quote
,
557 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
559 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
561 scm_from_int (i
++))),
563 cdrloc
= SCM_CDRLOC (*cdrloc
);
568 /******************************************************************************
572 ******************************************************************************/
574 /*fixme* Manufacture keywords in advance */
576 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
580 for (i
= 0; i
!= len
; i
+= 2)
582 SCM obj
= SCM_CAR (l
);
584 if (!scm_is_keyword (obj
))
585 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
586 else if (scm_is_eq (obj
, key
))
592 return default_value
;
596 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
597 (SCM key
, SCM l
, SCM default_value
),
598 "Determine an associated value for the keyword @var{key} from\n"
599 "the list @var{l}. The list @var{l} has to consist of an even\n"
600 "number of elements, where, starting with the first, every\n"
601 "second element is a keyword, followed by its associated value.\n"
602 "If @var{l} does not hold a value for @var{key}, the value\n"
603 "@var{default_value} is returned.")
604 #define FUNC_NAME s_scm_get_keyword
608 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
609 len
= scm_ilength (l
);
610 if (len
< 0 || len
% 2 == 1)
611 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
613 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
618 SCM_KEYWORD (k_init_keyword
, "init-keyword");
620 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
621 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
623 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
624 (SCM obj
, SCM initargs
),
625 "Initialize the object @var{obj} with the given arguments\n"
627 #define FUNC_NAME s_scm_sys_initialize_object
629 SCM tmp
, get_n_set
, slots
;
630 SCM
class = SCM_CLASS_OF (obj
);
633 SCM_VALIDATE_INSTANCE (1, obj
);
634 n_initargs
= scm_ilength (initargs
);
635 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
637 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
638 slots
= SCM_SLOT (class, scm_si_slots
);
640 /* See for each slot how it must be initialized */
642 !scm_is_null (slots
);
643 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
645 SCM slot_name
= SCM_CAR (slots
);
646 SCM slot_value
= SCM_PACK (0);
648 if (!scm_is_null (SCM_CDR (slot_name
)))
650 /* This slot admits (perhaps) to be initialized at creation time */
651 long n
= scm_ilength (SCM_CDR (slot_name
));
652 if (n
& 1) /* odd or -1 */
653 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
654 scm_list_1 (slot_name
));
655 tmp
= scm_i_get_keyword (k_init_keyword
,
660 slot_name
= SCM_CAR (slot_name
);
661 if (SCM_UNPACK (tmp
))
663 /* an initarg was provided for this slot */
664 if (!scm_is_keyword (tmp
))
665 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
667 slot_value
= scm_i_get_keyword (tmp
,
675 if (SCM_UNPACK (slot_value
))
676 /* set slot to provided value */
677 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
680 /* set slot to its :init-form if it exists */
681 tmp
= SCM_CADAR (get_n_set
);
682 if (scm_is_true (tmp
))
684 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
685 if (SCM_GOOPS_UNBOUNDP (slot_value
))
686 set_slot_value (class,
698 /* NOTE: The following macros are interdependent with code
699 * in goops.scm:compute-getters-n-setters
701 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
702 (SCM_I_INUMP (SCM_CDDR (gns)) \
703 || (scm_is_pair (SCM_CDDR (gns)) \
704 && scm_is_pair (SCM_CDDDR (gns)) \
705 && scm_is_pair (SCM_CDDDDR (gns))))
706 #define SCM_GNS_INDEX(gns) \
707 (SCM_I_INUMP (SCM_CDDR (gns)) \
708 ? SCM_I_INUM (SCM_CDDR (gns)) \
709 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
710 #define SCM_GNS_SIZE(gns) \
711 (SCM_I_INUMP (SCM_CDDR (gns)) \
713 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
715 SCM_KEYWORD (k_class
, "class");
716 SCM_KEYWORD (k_allocation
, "allocation");
717 SCM_KEYWORD (k_instance
, "instance");
719 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
722 #define FUNC_NAME s_scm_sys_prep_layout_x
724 SCM slots
, getters_n_setters
, nfields
;
725 unsigned long int n
, i
;
729 SCM_VALIDATE_INSTANCE (1, class);
730 slots
= SCM_SLOT (class, scm_si_slots
);
731 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
732 nfields
= SCM_SLOT (class, scm_si_nfields
);
733 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
734 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
735 scm_list_1 (nfields
));
736 n
= 2 * SCM_I_INUM (nfields
);
737 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
738 && SCM_SUBCLASSP (class, scm_class_class
))
739 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
740 scm_list_1 (nfields
));
742 layout
= scm_i_make_string (n
, &s
, 0);
744 while (scm_is_pair (getters_n_setters
))
746 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
749 int len
, index
, size
;
752 if (i
>= n
|| !scm_is_pair (slots
))
755 /* extract slot type */
756 len
= scm_ilength (SCM_CDAR (slots
));
757 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
758 len
, SCM_BOOL_F
, FUNC_NAME
);
759 /* determine slot GC protection and access mode */
760 if (scm_is_false (type
))
767 if (!SCM_CLASSP (type
))
768 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
769 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
771 if (SCM_SUBCLASSP (type
, scm_class_self
))
773 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
778 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
780 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
782 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
794 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
795 if (index
!= (i
>> 1))
797 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
805 slots
= SCM_CDR (slots
);
806 getters_n_setters
= SCM_CDR (getters_n_setters
);
808 if (!scm_is_null (slots
))
811 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
813 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
814 return SCM_UNSPECIFIED
;
818 static void prep_hashsets (SCM
);
820 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
821 (SCM
class, SCM dsupers
),
823 #define FUNC_NAME s_scm_sys_inherit_magic_x
825 SCM_VALIDATE_INSTANCE (1, class);
826 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
827 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
829 prep_hashsets (class);
831 return SCM_UNSPECIFIED
;
836 prep_hashsets (SCM
class)
840 for (i
= 0; i
< 8; ++i
)
841 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
844 /******************************************************************************/
847 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
849 SCM z
, cpl
, slots
, nfields
, g_n_s
;
851 /* Allocate one instance */
852 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
854 /* Initialize its slots */
855 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
856 cpl
= compute_cpl (z
);
857 slots
= build_slots_list (maplist (dslots
), cpl
);
858 nfields
= scm_from_int (scm_ilength (slots
));
859 g_n_s
= compute_getters_n_setters (slots
);
861 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
862 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
863 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
864 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
865 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
866 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
867 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
868 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
869 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
871 /* Add this class in the direct-subclasses slot of dsupers */
874 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
875 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
876 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
877 scm_si_direct_subclasses
)));
884 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
886 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
887 scm_sys_prep_layout_x (z
);
888 scm_sys_inherit_magic_x (z
, dsupers
);
892 /******************************************************************************/
894 SCM_SYMBOL (sym_layout
, "layout");
895 SCM_SYMBOL (sym_flags
, "flags");
896 SCM_SYMBOL (sym_self
, "%self");
897 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
898 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
899 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
900 SCM_SYMBOL (sym_print
, "print");
901 SCM_SYMBOL (sym_procedure
, "procedure");
902 SCM_SYMBOL (sym_setter
, "setter");
903 SCM_SYMBOL (sym_redefined
, "redefined");
904 SCM_SYMBOL (sym_h0
, "h0");
905 SCM_SYMBOL (sym_h1
, "h1");
906 SCM_SYMBOL (sym_h2
, "h2");
907 SCM_SYMBOL (sym_h3
, "h3");
908 SCM_SYMBOL (sym_h4
, "h4");
909 SCM_SYMBOL (sym_h5
, "h5");
910 SCM_SYMBOL (sym_h6
, "h6");
911 SCM_SYMBOL (sym_h7
, "h7");
912 SCM_SYMBOL (sym_name
, "name");
913 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
914 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
915 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
916 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
917 SCM_SYMBOL (sym_cpl
, "cpl");
918 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
919 SCM_SYMBOL (sym_slots
, "slots");
920 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
921 SCM_SYMBOL (sym_nfields
, "nfields");
925 build_class_class_slots (void)
927 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
928 SCM_CLASS_CLASS_LAYOUT */
930 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
931 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
932 scm_list_3 (sym_self
, k_class
, scm_class_self
),
933 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
934 scm_list_1 (sym_print
),
935 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
936 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
937 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
938 scm_list_1 (sym_redefined
),
939 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
940 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
941 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
942 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
943 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
944 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
945 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
946 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
947 scm_list_1 (sym_direct_supers
),
948 scm_list_1 (sym_direct_slots
),
949 scm_list_1 (sym_direct_subclasses
),
950 scm_list_1 (sym_direct_methods
),
951 scm_list_1 (sym_cpl
),
952 scm_list_1 (sym_default_slot_definition_class
),
953 scm_list_1 (sym_slots
),
954 scm_list_1 (sym_getters_n_setters
),
955 scm_list_1 (sym_nfields
),
960 create_basic_classes (void)
962 /* SCM slots_of_class = build_class_class_slots (); */
965 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
966 SCM name
= scm_from_latin1_symbol ("<class>");
967 scm_class_class
= scm_i_make_vtable_vtable (cs
);
968 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
969 | SCM_CLASSF_METACLASS
));
971 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
972 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
973 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
974 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
975 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
976 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
977 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
978 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
979 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
980 compute_getters_n_setters (slots_of_class)); */
981 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
983 prep_hashsets (scm_class_class
);
985 scm_module_define (scm_module_goops
, name
, scm_class_class
);
988 name
= scm_from_latin1_symbol ("<top>");
989 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
992 scm_module_define (scm_module_goops
, name
, scm_class_top
);
995 name
= scm_from_latin1_symbol ("<object>");
996 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
997 scm_list_1 (scm_class_top
), SCM_EOL
);
999 scm_module_define (scm_module_goops
, name
, scm_class_object
);
1001 /* <top> <object> and <class> were partially initialized. Correct them here */
1002 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1004 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1005 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1008 /******************************************************************************/
1010 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1012 "Return @code{#t} if @var{obj} is an instance.")
1013 #define FUNC_NAME s_scm_instance_p
1015 return scm_from_bool (SCM_INSTANCEP (obj
));
1020 /******************************************************************************
1022 * Meta object accessors
1024 ******************************************************************************/
1025 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1027 "Return the class name of @var{obj}.")
1028 #define FUNC_NAME s_scm_class_name
1030 SCM_VALIDATE_CLASS (1, obj
);
1031 return scm_slot_ref (obj
, sym_name
);
1035 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1037 "Return the direct superclasses of the class @var{obj}.")
1038 #define FUNC_NAME s_scm_class_direct_supers
1040 SCM_VALIDATE_CLASS (1, obj
);
1041 return scm_slot_ref (obj
, sym_direct_supers
);
1045 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1047 "Return the direct slots of the class @var{obj}.")
1048 #define FUNC_NAME s_scm_class_direct_slots
1050 SCM_VALIDATE_CLASS (1, obj
);
1051 return scm_slot_ref (obj
, sym_direct_slots
);
1055 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1057 "Return the direct subclasses of the class @var{obj}.")
1058 #define FUNC_NAME s_scm_class_direct_subclasses
1060 SCM_VALIDATE_CLASS (1, obj
);
1061 return scm_slot_ref(obj
, sym_direct_subclasses
);
1065 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1067 "Return the direct methods of the class @var{obj}")
1068 #define FUNC_NAME s_scm_class_direct_methods
1070 SCM_VALIDATE_CLASS (1, obj
);
1071 return scm_slot_ref (obj
, sym_direct_methods
);
1075 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1077 "Return the class precedence list of the class @var{obj}.")
1078 #define FUNC_NAME s_scm_class_precedence_list
1080 SCM_VALIDATE_CLASS (1, obj
);
1081 return scm_slot_ref (obj
, sym_cpl
);
1085 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1087 "Return the slot list of the class @var{obj}.")
1088 #define FUNC_NAME s_scm_class_slots
1090 SCM_VALIDATE_CLASS (1, obj
);
1091 return scm_slot_ref (obj
, sym_slots
);
1095 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1097 "Return the name of the generic function @var{obj}.")
1098 #define FUNC_NAME s_scm_generic_function_name
1100 SCM_VALIDATE_GENERIC (1, obj
);
1101 return scm_procedure_property (obj
, scm_sym_name
);
1105 SCM_SYMBOL (sym_methods
, "methods");
1106 SCM_SYMBOL (sym_extended_by
, "extended-by");
1107 SCM_SYMBOL (sym_extends
, "extends");
1110 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1112 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1113 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1114 while (!scm_is_null (gfs
))
1116 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1117 gfs
= SCM_CDR (gfs
);
1119 return method_lists
;
1123 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1125 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1127 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1128 while (!scm_is_null (gfs
))
1130 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1131 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1134 gfs
= SCM_CDR (gfs
);
1137 return method_lists
;
1140 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1142 "Return the methods of the generic function @var{obj}.")
1143 #define FUNC_NAME s_scm_generic_function_methods
1146 SCM_VALIDATE_GENERIC (1, obj
);
1147 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1148 methods
= fold_downward_gf_methods (methods
, obj
);
1149 return scm_append (methods
);
1153 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1155 "Return the generic function for the method @var{obj}.")
1156 #define FUNC_NAME s_scm_method_generic_function
1158 SCM_VALIDATE_METHOD (1, obj
);
1159 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1163 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1165 "Return specializers of the method @var{obj}.")
1166 #define FUNC_NAME s_scm_method_specializers
1168 SCM_VALIDATE_METHOD (1, obj
);
1169 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1173 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1175 "Return the procedure of the method @var{obj}.")
1176 #define FUNC_NAME s_scm_method_procedure
1178 SCM_VALIDATE_METHOD (1, obj
);
1179 return scm_slot_ref (obj
, sym_procedure
);
1183 /******************************************************************************
1185 * S l o t a c c e s s
1187 ******************************************************************************/
1189 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1191 "Return the unbound value.")
1192 #define FUNC_NAME s_scm_make_unbound
1194 return SCM_GOOPS_UNBOUND
;
1198 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1200 "Return @code{#t} if @var{obj} is unbound.")
1201 #define FUNC_NAME s_scm_unbound_p
1203 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1207 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1208 (SCM value
, SCM obj
),
1209 "Return @var{value} if it is bound, and invoke the\n"
1210 "@var{slot-unbound} method of @var{obj} if it is not.")
1211 #define FUNC_NAME s_scm_assert_bound
1213 if (SCM_GOOPS_UNBOUNDP (value
))
1214 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1219 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1220 (SCM obj
, SCM index
),
1221 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1222 "the value from @var{obj}.")
1223 #define FUNC_NAME s_scm_at_assert_bound_ref
1225 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1226 if (SCM_GOOPS_UNBOUNDP (value
))
1227 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1232 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1233 (SCM obj
, SCM index
),
1234 "Return the slot value with index @var{index} from @var{obj}.")
1235 #define FUNC_NAME s_scm_sys_fast_slot_ref
1239 SCM_VALIDATE_INSTANCE (1, obj
);
1240 i
= scm_to_unsigned_integer (index
, 0,
1241 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1244 return SCM_SLOT (obj
, i
);
1248 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1249 (SCM obj
, SCM index
, SCM value
),
1250 "Set the slot with index @var{index} in @var{obj} to\n"
1252 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1256 SCM_VALIDATE_INSTANCE (1, obj
);
1257 i
= scm_to_unsigned_integer (index
, 0,
1258 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1262 SCM_SET_SLOT (obj
, i
, value
);
1264 return SCM_UNSPECIFIED
;
1272 /* In the future, this function will return the effective slot
1273 * definition associated with SLOT_NAME. Now it just returns some of
1274 * the information which will be stored in the effective slot
1279 slot_definition_using_name (SCM
class, SCM slot_name
)
1281 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1282 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1283 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1284 return SCM_CAR (slots
);
1289 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1290 #define FUNC_NAME "%get-slot-value"
1292 SCM access
= SCM_CDDR (slotdef
);
1294 * - access is an integer (the offset of this slot in the slots vector)
1295 * - otherwise (car access) is the getter function to apply
1297 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1298 * we can just assume fixnums here.
1300 if (SCM_I_INUMP (access
))
1301 /* Don't poke at the slots directly, because scm_struct_ref handles the
1302 access bits for us. */
1303 return scm_struct_ref (obj
, access
);
1305 return scm_call_1 (SCM_CAR (access
), obj
);
1310 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1312 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1313 if (scm_is_true (slotdef
))
1314 return get_slot_value (class, obj
, slotdef
);
1316 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1320 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1321 #define FUNC_NAME "%set-slot-value"
1323 SCM access
= SCM_CDDR (slotdef
);
1325 * - access is an integer (the offset of this slot in the slots vector)
1326 * - otherwise (cadr access) is the setter function to apply
1328 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1329 * we can just assume fixnums here.
1331 if (SCM_I_INUMP (access
))
1332 /* obey permissions bits via going through struct-set! */
1333 scm_struct_set_x (obj
, access
, value
);
1335 /* ((cadr l) obj value) */
1336 scm_call_2 (SCM_CADR (access
), obj
, value
);
1337 return SCM_UNSPECIFIED
;
1342 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1344 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1345 if (scm_is_true (slotdef
))
1346 return set_slot_value (class, obj
, slotdef
, value
);
1348 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1352 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1356 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1357 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1363 /* ======================================== */
1365 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1366 (SCM
class, SCM obj
, SCM slot_name
),
1368 #define FUNC_NAME s_scm_slot_ref_using_class
1372 SCM_VALIDATE_CLASS (1, class);
1373 SCM_VALIDATE_INSTANCE (2, obj
);
1374 SCM_VALIDATE_SYMBOL (3, slot_name
);
1376 res
= get_slot_value_using_name (class, obj
, slot_name
);
1377 if (SCM_GOOPS_UNBOUNDP (res
))
1378 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1384 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1385 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1387 #define FUNC_NAME s_scm_slot_set_using_class_x
1389 SCM_VALIDATE_CLASS (1, class);
1390 SCM_VALIDATE_INSTANCE (2, obj
);
1391 SCM_VALIDATE_SYMBOL (3, slot_name
);
1393 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1398 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1399 (SCM
class, SCM obj
, SCM slot_name
),
1401 #define FUNC_NAME s_scm_slot_bound_using_class_p
1403 SCM_VALIDATE_CLASS (1, class);
1404 SCM_VALIDATE_INSTANCE (2, obj
);
1405 SCM_VALIDATE_SYMBOL (3, slot_name
);
1407 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1413 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1414 (SCM
class, SCM obj
, SCM slot_name
),
1416 #define FUNC_NAME s_scm_slot_exists_using_class_p
1418 SCM_VALIDATE_CLASS (1, class);
1419 SCM_VALIDATE_INSTANCE (2, obj
);
1420 SCM_VALIDATE_SYMBOL (3, slot_name
);
1421 return test_slot_existence (class, obj
, slot_name
);
1426 /* ======================================== */
1428 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1429 (SCM obj
, SCM slot_name
),
1430 "Return the value from @var{obj}'s slot with the name\n"
1432 #define FUNC_NAME s_scm_slot_ref
1436 SCM_VALIDATE_INSTANCE (1, obj
);
1437 TEST_CHANGE_CLASS (obj
, class);
1439 res
= get_slot_value_using_name (class, obj
, slot_name
);
1440 if (SCM_GOOPS_UNBOUNDP (res
))
1441 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1446 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1447 (SCM obj
, SCM slot_name
, SCM value
),
1448 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1449 #define FUNC_NAME s_scm_slot_set_x
1453 SCM_VALIDATE_INSTANCE (1, obj
);
1454 TEST_CHANGE_CLASS(obj
, class);
1456 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1460 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1462 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1463 (SCM obj
, SCM slot_name
),
1464 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1466 #define FUNC_NAME s_scm_slot_bound_p
1470 SCM_VALIDATE_INSTANCE (1, obj
);
1471 TEST_CHANGE_CLASS(obj
, class);
1473 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1481 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1482 (SCM obj
, SCM slot_name
),
1483 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1484 #define FUNC_NAME s_scm_slot_exists_p
1488 SCM_VALIDATE_INSTANCE (1, obj
);
1489 SCM_VALIDATE_SYMBOL (2, slot_name
);
1490 TEST_CHANGE_CLASS (obj
, class);
1492 return test_slot_existence (class, obj
, slot_name
);
1497 /******************************************************************************
1499 * %allocate-instance (the low level instance allocation primitive)
1501 ******************************************************************************/
1503 static void clear_method_cache (SCM
);
1505 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1506 (SCM
class, SCM initargs
),
1507 "Create a new instance of class @var{class} and initialize it\n"
1508 "from the arguments @var{initargs}.")
1509 #define FUNC_NAME s_scm_sys_allocate_instance
1512 scm_t_signed_bits n
, i
;
1515 SCM_VALIDATE_CLASS (1, class);
1517 /* FIXME: duplicates some of scm_make_struct. */
1519 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1520 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1522 layout
= SCM_VTABLE_LAYOUT (class);
1524 /* Set all SCM-holding slots to unbound */
1525 for (i
= 0; i
< n
; i
++)
1527 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1529 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1531 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1533 SCM_STRUCT_DATA (obj
)[i
] = 0;
1536 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1537 clear_method_cache (obj
);
1543 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1544 (SCM obj
, SCM setter
),
1546 #define FUNC_NAME s_scm_sys_set_object_setter_x
1548 SCM_ASSERT (SCM_STRUCTP (obj
)
1549 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1553 SCM_SET_GENERIC_SETTER (obj
, setter
);
1554 return SCM_UNSPECIFIED
;
1558 /******************************************************************************
1560 * %modify-instance (used by change-class to modify in place)
1562 ******************************************************************************/
1564 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1567 #define FUNC_NAME s_scm_sys_modify_instance
1569 SCM_VALIDATE_INSTANCE (1, old
);
1570 SCM_VALIDATE_INSTANCE (2, new);
1572 /* Exchange the data contained in old and new. We exchange rather than
1573 * scratch the old value with new to be correct with GC.
1574 * See "Class redefinition protocol above".
1576 SCM_CRITICAL_SECTION_START
;
1578 scm_t_bits word0
, word1
;
1579 word0
= SCM_CELL_WORD_0 (old
);
1580 word1
= SCM_CELL_WORD_1 (old
);
1581 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1582 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1583 SCM_SET_CELL_WORD_0 (new, word0
);
1584 SCM_SET_CELL_WORD_1 (new, word1
);
1586 SCM_CRITICAL_SECTION_END
;
1587 return SCM_UNSPECIFIED
;
1591 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1594 #define FUNC_NAME s_scm_sys_modify_class
1596 SCM_VALIDATE_CLASS (1, old
);
1597 SCM_VALIDATE_CLASS (2, new);
1599 SCM_CRITICAL_SECTION_START
;
1601 scm_t_bits word0
, word1
;
1602 word0
= SCM_CELL_WORD_0 (old
);
1603 word1
= SCM_CELL_WORD_1 (old
);
1604 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1605 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1606 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1607 SCM_SET_CELL_WORD_0 (new, word0
);
1608 SCM_SET_CELL_WORD_1 (new, word1
);
1609 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1611 SCM_CRITICAL_SECTION_END
;
1612 return SCM_UNSPECIFIED
;
1616 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1619 #define FUNC_NAME s_scm_sys_invalidate_class
1621 SCM_VALIDATE_CLASS (1, class);
1622 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1623 return SCM_UNSPECIFIED
;
1627 /* When instances change class, they finally get a new body, but
1628 * before that, they go through purgatory in hell. Odd as it may
1629 * seem, this data structure saves us from eternal suffering in
1630 * infinite recursions.
1633 static scm_t_bits
**hell
;
1634 static long n_hell
= 1; /* one place for the evil one himself */
1635 static long hell_size
= 4;
1636 static SCM hell_mutex
;
1642 for (i
= 1; i
< n_hell
; ++i
)
1643 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1649 go_to_hell (void *o
)
1652 scm_lock_mutex (hell_mutex
);
1653 if (n_hell
>= hell_size
)
1656 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1658 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1659 scm_unlock_mutex (hell_mutex
);
1663 go_to_heaven (void *o
)
1666 scm_lock_mutex (hell_mutex
);
1667 hell
[burnin (obj
)] = hell
[--n_hell
];
1668 scm_unlock_mutex (hell_mutex
);
1672 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1675 purgatory (SCM obj
, SCM new_class
)
1677 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1680 /* This function calls the generic function change-class for all
1681 * instances which aren't currently undergoing class change.
1685 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1689 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1690 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1691 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1692 purgatory (obj
, new_class
);
1697 /******************************************************************************
1703 * GGG E N E R I C F U N C T I O N S
1705 * This implementation provides
1706 * - generic functions (with class specializers)
1709 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1711 ******************************************************************************/
1713 SCM_KEYWORD (k_name
, "name");
1715 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1718 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1720 make_dispatch_procedure (SCM gf
)
1722 static SCM var
= SCM_BOOL_F
;
1723 if (scm_is_false (var
))
1724 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1725 sym_delayed_compile
);
1726 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1730 clear_method_cache (SCM gf
)
1732 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1733 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1736 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1739 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1741 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1742 clear_method_cache (gf
);
1743 return SCM_UNSPECIFIED
;
1747 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1750 #define FUNC_NAME s_scm_generic_capability_p
1752 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1753 proc
, SCM_ARG1
, FUNC_NAME
);
1754 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1758 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1761 #define FUNC_NAME s_scm_enable_primitive_generic_x
1763 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1764 while (!scm_is_null (subrs
))
1766 SCM subr
= SCM_CAR (subrs
);
1767 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1768 SCM_SET_SUBR_GENERIC (subr
,
1769 scm_make (scm_list_3 (scm_class_generic
,
1771 SCM_SUBR_NAME (subr
))));
1772 subrs
= SCM_CDR (subrs
);
1774 return SCM_UNSPECIFIED
;
1778 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1779 (SCM subr
, SCM generic
),
1781 #define FUNC_NAME s_scm_set_primitive_generic_x
1783 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1784 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1785 SCM_SET_SUBR_GENERIC (subr
, generic
);
1786 return SCM_UNSPECIFIED
;
1790 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1793 #define FUNC_NAME s_scm_primitive_generic_generic
1795 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1797 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1798 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1799 return *SCM_SUBR_GENERIC (subr
);
1801 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1805 typedef struct t_extension
{
1806 struct t_extension
*next
;
1812 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1814 static const char extension_gc_hint
[] = "GOOPS extension";
1816 static t_extension
*extensions
= 0;
1819 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1824 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1825 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1826 gf
= *SCM_SUBR_GENERIC (extended
);
1827 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1829 SCM_SUBR_NAME (extension
));
1830 SCM_SET_SUBR_GENERIC (extension
, gext
);
1834 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1836 t_extension
**loc
= &extensions
;
1837 /* Make sure that extensions are placed before their own
1838 * extensions in the extensions list. O(N^2) algorithm, but
1839 * extensions of primitive generics are rare.
1841 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1842 loc
= &(*loc
)->next
;
1844 e
->extended
= extended
;
1845 e
->extension
= extension
;
1851 setup_extended_primitive_generics ()
1855 t_extension
*e
= extensions
;
1856 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1857 extensions
= e
->next
;
1861 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1862 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1863 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1867 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1869 if (!SCM_UNPACK (gf
))
1870 scm_error_num_args_subr (subr
);
1872 return scm_call_0 (gf
);
1876 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1878 if (!SCM_UNPACK (gf
))
1879 scm_wrong_type_arg (subr
, pos
, a1
);
1881 return scm_call_1 (gf
, a1
);
1885 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1887 if (!SCM_UNPACK (gf
))
1888 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1890 return scm_call_2 (gf
, a1
, a2
);
1894 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1896 if (!SCM_UNPACK (gf
))
1897 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1899 return scm_apply_0 (gf
, args
);
1902 /******************************************************************************
1904 * Protocol for calling a generic fumction
1905 * This protocol is roughly equivalent to (parameter are a little bit different
1906 * for efficiency reasons):
1908 * + apply-generic (gf args)
1909 * + compute-applicable-methods (gf args ...)
1910 * + sort-applicable-methods (methods args)
1911 * + apply-methods (gf methods args)
1913 * apply-methods calls make-next-method to build the "continuation" of a a
1914 * method. Applying a next-method will call apply-next-method which in
1915 * turn will call apply again to call effectively the following method.
1917 ******************************************************************************/
1920 applicablep (SCM actual
, SCM formal
)
1922 /* We already know that the cpl is well formed. */
1923 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1927 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1929 register SCM s1
, s2
;
1933 * m1 and m2 can have != length (i.e. one can be one element longer than the
1934 * other when we have a dotted parameter list). For instance, with the call
1937 * (define-method M (a . l) ....)
1938 * (define-method M (a) ....)
1940 * we consider that the second method is more specific.
1942 * BTW, targs is an array of types. We don't need it's size since
1943 * we already know that m1 and m2 are applicable (no risk to go past
1944 * the end of this array).
1947 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1948 if (scm_is_null(s1
)) return 1;
1949 if (scm_is_null(s2
)) return 0;
1950 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1951 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1953 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1954 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1956 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1959 return 0;/* should not occur! */
1962 return 0; /* should not occur! */
1965 #define BUFFSIZE 32 /* big enough for most uses */
1968 scm_i_vector2list (SCM l
, long len
)
1971 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1973 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1974 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1980 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1983 SCM
*v
, vector
= SCM_EOL
;
1984 SCM buffer
[BUFFSIZE
];
1985 SCM save
= method_list
;
1986 scm_t_array_handle handle
;
1988 /* For reasonably sized method_lists we can try to avoid all the
1989 * consing and reorder the list in place...
1990 * This idea is due to David McClain <Dave_McClain@msn.com>
1992 if (size
<= BUFFSIZE
)
1994 for (i
= 0; i
< size
; i
++)
1996 buffer
[i
] = SCM_CAR (method_list
);
1997 method_list
= SCM_CDR (method_list
);
2003 /* Too many elements in method_list to keep everything locally */
2004 vector
= scm_i_vector2list (save
, size
);
2005 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2008 /* Use a simple shell sort since it is generally faster than qsort on
2009 * small vectors (which is probably mostly the case when we have to
2010 * sort a list of applicable methods).
2012 for (incr
= size
/ 2; incr
; incr
/= 2)
2014 for (i
= incr
; i
< size
; i
++)
2016 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2018 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2022 SCM tmp
= v
[j
+ incr
];
2030 if (size
<= BUFFSIZE
)
2032 /* We did it in locally, so restore the original list (reordered) in-place */
2033 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2035 SCM_SETCAR (method_list
, *v
);
2036 method_list
= SCM_CDR (method_list
);
2041 /* If we are here, that's that we did it the hard way... */
2042 scm_array_handle_release (&handle
);
2043 return scm_vector_to_list (vector
);
2047 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2051 SCM l
, fl
, applicable
= SCM_EOL
;
2053 SCM buffer
[BUFFSIZE
];
2057 scm_t_array_handle handle
;
2059 /* Build the list of arguments types */
2060 if (len
>= BUFFSIZE
)
2062 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2063 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2066 note that we don't have to work to reset the generation
2067 count. TMP is a new vector anyway, and it is found
2074 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2075 *p
++ = scm_class_of (SCM_CAR (args
));
2077 /* Build a list of all applicable methods */
2078 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2080 fl
= SPEC_OF (SCM_CAR (l
));
2081 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2083 if (SCM_INSTANCEP (fl
)
2084 /* We have a dotted argument list */
2085 || (i
>= len
&& scm_is_null (fl
)))
2086 { /* both list exhausted */
2087 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2093 || !applicablep (types
[i
], SCM_CAR (fl
)))
2098 if (len
>= BUFFSIZE
)
2099 scm_array_handle_release (&handle
);
2105 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2106 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2112 : sort_applicable_methods (applicable
, count
, types
));
2116 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2119 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2122 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2123 #define FUNC_NAME s_sys_compute_applicable_methods
2126 SCM_VALIDATE_GENERIC (1, gf
);
2127 n
= scm_ilength (args
);
2128 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2129 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2133 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2134 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2135 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2136 scm_sys_compute_applicable_methods
));
2138 /******************************************************************************
2140 * A simple make (which will be redefined later in Scheme)
2141 * This version handles only creation of gf, methods and classes (no instances)
2143 * Since this code will disappear when Goops will be fully booted,
2144 * no precaution is taken to be efficient.
2146 ******************************************************************************/
2148 SCM_KEYWORD (k_setter
, "setter");
2149 SCM_KEYWORD (k_specializers
, "specializers");
2150 SCM_KEYWORD (k_procedure
, "procedure");
2151 SCM_KEYWORD (k_formals
, "formals");
2152 SCM_KEYWORD (k_body
, "body");
2153 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2154 SCM_KEYWORD (k_dsupers
, "dsupers");
2155 SCM_KEYWORD (k_slots
, "slots");
2156 SCM_KEYWORD (k_gf
, "generic-function");
2158 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2160 "Make a new object. @var{args} must contain the class and\n"
2161 "all necessary initialization information.")
2162 #define FUNC_NAME s_scm_make
2165 long len
= scm_ilength (args
);
2167 if (len
<= 0 || (len
& 1) == 0)
2168 SCM_WRONG_NUM_ARGS ();
2170 class = SCM_CAR(args
);
2171 args
= SCM_CDR(args
);
2173 if (scm_is_eq (class, scm_class_generic
)
2174 || scm_is_eq (class, scm_class_accessor
))
2176 z
= scm_make_struct (class, SCM_INUM0
,
2177 scm_list_4 (SCM_BOOL_F
,
2181 scm_set_procedure_property_x (z
, scm_sym_name
,
2182 scm_get_keyword (k_name
,
2185 clear_method_cache (z
);
2186 if (scm_is_eq (class, scm_class_accessor
))
2188 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2189 if (scm_is_true (setter
))
2190 scm_sys_set_object_setter_x (z
, setter
);
2195 z
= scm_sys_allocate_instance (class, args
);
2197 if (scm_is_eq (class, scm_class_method
)
2198 || scm_is_eq (class, scm_class_accessor_method
))
2200 SCM_SET_SLOT (z
, scm_si_generic_function
,
2201 scm_i_get_keyword (k_gf
,
2206 SCM_SET_SLOT (z
, scm_si_specializers
,
2207 scm_i_get_keyword (k_specializers
,
2212 SCM_SET_SLOT (z
, scm_si_procedure
,
2213 scm_i_get_keyword (k_procedure
,
2218 SCM_SET_SLOT (z
, scm_si_formals
,
2219 scm_i_get_keyword (k_formals
,
2224 SCM_SET_SLOT (z
, scm_si_body
,
2225 scm_i_get_keyword (k_body
,
2230 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2231 scm_i_get_keyword (k_make_procedure
,
2239 /* In all the others case, make a new class .... No instance here */
2240 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2241 scm_i_get_keyword (k_name
,
2244 scm_from_latin1_symbol ("???"),
2246 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2247 scm_i_get_keyword (k_dsupers
,
2252 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2253 scm_i_get_keyword (k_slots
,
2264 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2267 #define FUNC_NAME s_scm_find_method
2270 long len
= scm_ilength (l
);
2273 SCM_WRONG_NUM_ARGS ();
2275 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2276 SCM_VALIDATE_GENERIC (1, gf
);
2277 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2278 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2280 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2284 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2285 (SCM m1
, SCM m2
, SCM targs
),
2286 "Return true if method @var{m1} is more specific than @var{m2} "
2287 "given the argument types (classes) listed in @var{targs}.")
2288 #define FUNC_NAME s_scm_sys_method_more_specific_p
2292 long i
, len
, m1_specs
, m2_specs
;
2293 scm_t_array_handle handle
;
2295 SCM_VALIDATE_METHOD (1, m1
);
2296 SCM_VALIDATE_METHOD (2, m2
);
2298 len
= scm_ilength (targs
);
2299 m1_specs
= scm_ilength (SPEC_OF (m1
));
2300 m2_specs
= scm_ilength (SPEC_OF (m2
));
2301 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2302 targs
, SCM_ARG3
, FUNC_NAME
);
2304 /* Verify that all the arguments of TARGS are classes and place them
2307 v
= scm_c_make_vector (len
, SCM_EOL
);
2308 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2310 for (i
= 0, l
= targs
;
2311 i
< len
&& scm_is_pair (l
);
2312 i
++, l
= SCM_CDR (l
))
2314 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2315 v_elts
[i
] = SCM_CAR (l
);
2317 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2319 scm_array_handle_release (&handle
);
2327 /******************************************************************************
2331 ******************************************************************************/
2333 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2334 assuming that currently the reverse is true. Recalculate slots and
2335 associated getters-n-setters. */
2337 fix_cpl (SCM c
, SCM before
, SCM after
)
2339 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2340 SCM ls
= scm_c_memq (after
, cpl
);
2343 if (scm_is_false (ls
))
2344 /* if this condition occurs, fix_cpl should not be applied this way */
2347 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2348 SCM_SETCAR (ls
, before
);
2349 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2351 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2352 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2353 SCM g_n_s
= compute_getters_n_setters (slots
);
2354 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2355 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2361 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2363 SCM tmp
= scm_from_utf8_symbol (name
);
2365 *var
= scm_basic_make_class (meta
, tmp
,
2366 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2368 scm_module_define (scm_module_goops
, tmp
, *var
);
2372 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2375 create_standard_classes (void)
2378 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2379 scm_from_latin1_symbol ("specializers"),
2381 scm_from_latin1_symbol ("formals"),
2382 scm_from_latin1_symbol ("body"),
2383 scm_from_latin1_symbol ("make-procedure"),
2385 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2387 k_slot_definition
));
2388 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2389 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2392 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2395 scm_from_latin1_symbol ("effective-methods"));
2396 SCM setter_slots
= scm_list_1 (sym_setter
);
2397 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2400 /* Foreign class slot classes */
2401 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_protected
, "<protected-slot>",
2404 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2405 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2406 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2407 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2408 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2409 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2410 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2411 make_stdcls (&scm_class_self
, "<self-slot>",
2412 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2413 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2415 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2417 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2419 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2421 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2423 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2425 make_stdcls (&scm_class_scm
, "<scm-slot>",
2426 scm_class_class
, scm_class_protected
, SCM_EOL
);
2427 make_stdcls (&scm_class_int
, "<int-slot>",
2428 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2429 make_stdcls (&scm_class_float
, "<float-slot>",
2430 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2431 make_stdcls (&scm_class_double
, "<double-slot>",
2432 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2434 /* Continue initialization of class <class> */
2436 slots
= build_class_class_slots ();
2437 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2438 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2439 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2440 compute_getters_n_setters (slots
));
2442 /* scm_class_generic functions classes */
2443 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2444 scm_class_class
, scm_class_class
, SCM_EOL
);
2445 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2446 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2447 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2448 make_stdcls (&scm_class_method
, "<method>",
2449 scm_class_class
, scm_class_object
, method_slots
);
2450 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2451 scm_class_class
, scm_class_method
, amethod_slots
);
2452 make_stdcls (&scm_class_applicable
, "<applicable>",
2453 scm_class_class
, scm_class_top
, SCM_EOL
);
2454 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2455 scm_class_applicable_struct_class
,
2456 scm_list_2 (scm_class_object
, scm_class_applicable
),
2457 scm_list_1 (sym_procedure
));
2458 make_stdcls (&scm_class_generic
, "<generic>",
2459 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2460 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2461 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2462 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2463 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2464 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2465 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2466 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2467 make_stdcls (&scm_class_accessor
, "<accessor>",
2468 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2469 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2470 make_stdcls (&scm_class_extended_generic_with_setter
,
2471 "<extended-generic-with-setter>",
2472 scm_class_applicable_struct_class
,
2473 scm_list_2 (scm_class_extended_generic
,
2474 scm_class_generic_with_setter
),
2476 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2477 SCM_CLASSF_PURE_GENERIC
);
2478 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2479 scm_class_applicable_struct_class
,
2480 scm_list_2 (scm_class_accessor
,
2481 scm_class_extended_generic_with_setter
),
2483 /* <extended-generic> is misplaced. */
2484 fix_cpl (scm_class_extended_accessor
,
2485 scm_class_extended_generic
, scm_class_generic_with_setter
);
2486 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2488 /* Primitive types classes */
2489 make_stdcls (&scm_class_boolean
, "<boolean>",
2490 scm_class_class
, scm_class_top
, SCM_EOL
);
2491 make_stdcls (&scm_class_char
, "<char>",
2492 scm_class_class
, scm_class_top
, SCM_EOL
);
2493 make_stdcls (&scm_class_list
, "<list>",
2494 scm_class_class
, scm_class_top
, SCM_EOL
);
2495 make_stdcls (&scm_class_pair
, "<pair>",
2496 scm_class_class
, scm_class_list
, SCM_EOL
);
2497 make_stdcls (&scm_class_null
, "<null>",
2498 scm_class_class
, scm_class_list
, SCM_EOL
);
2499 make_stdcls (&scm_class_string
, "<string>",
2500 scm_class_class
, scm_class_top
, SCM_EOL
);
2501 make_stdcls (&scm_class_symbol
, "<symbol>",
2502 scm_class_class
, scm_class_top
, SCM_EOL
);
2503 make_stdcls (&scm_class_vector
, "<vector>",
2504 scm_class_class
, scm_class_top
, SCM_EOL
);
2505 make_stdcls (&class_foreign
, "<foreign>",
2506 scm_class_class
, scm_class_top
, SCM_EOL
);
2507 make_stdcls (&class_hashtable
, "<hashtable>",
2508 scm_class_class
, scm_class_top
, SCM_EOL
);
2509 make_stdcls (&class_fluid
, "<fluid>",
2510 scm_class_class
, scm_class_top
, SCM_EOL
);
2511 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2512 scm_class_class
, scm_class_top
, SCM_EOL
);
2513 make_stdcls (&class_frame
, "<frame>",
2514 scm_class_class
, scm_class_top
, SCM_EOL
);
2515 make_stdcls (&class_vm
, "<vm>",
2516 scm_class_class
, scm_class_top
, SCM_EOL
);
2517 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2518 scm_class_class
, scm_class_top
, SCM_EOL
);
2519 make_stdcls (&class_bytevector
, "<bytevector>",
2520 scm_class_class
, scm_class_top
, SCM_EOL
);
2521 make_stdcls (&class_uvec
, "<uvec>",
2522 scm_class_class
, class_bytevector
, SCM_EOL
);
2523 make_stdcls (&class_array
, "<array>",
2524 scm_class_class
, scm_class_top
, SCM_EOL
);
2525 make_stdcls (&class_bitvector
, "<bitvector>",
2526 scm_class_class
, scm_class_top
, SCM_EOL
);
2527 make_stdcls (&scm_class_number
, "<number>",
2528 scm_class_class
, scm_class_top
, SCM_EOL
);
2529 make_stdcls (&scm_class_complex
, "<complex>",
2530 scm_class_class
, scm_class_number
, SCM_EOL
);
2531 make_stdcls (&scm_class_real
, "<real>",
2532 scm_class_class
, scm_class_complex
, SCM_EOL
);
2533 make_stdcls (&scm_class_integer
, "<integer>",
2534 scm_class_class
, scm_class_real
, SCM_EOL
);
2535 make_stdcls (&scm_class_fraction
, "<fraction>",
2536 scm_class_class
, scm_class_real
, SCM_EOL
);
2537 make_stdcls (&scm_class_keyword
, "<keyword>",
2538 scm_class_class
, scm_class_top
, SCM_EOL
);
2539 make_stdcls (&scm_class_unknown
, "<unknown>",
2540 scm_class_class
, scm_class_top
, SCM_EOL
);
2541 make_stdcls (&scm_class_procedure
, "<procedure>",
2542 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2543 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2544 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2545 make_stdcls (&scm_class_port
, "<port>",
2546 scm_class_class
, scm_class_top
, SCM_EOL
);
2547 make_stdcls (&scm_class_input_port
, "<input-port>",
2548 scm_class_class
, scm_class_port
, SCM_EOL
);
2549 make_stdcls (&scm_class_output_port
, "<output-port>",
2550 scm_class_class
, scm_class_port
, SCM_EOL
);
2551 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2553 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2557 /**********************************************************************
2561 **********************************************************************/
2564 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2570 sprintf (buffer
, template, type_name
);
2571 name
= scm_from_utf8_symbol (buffer
);
2574 name
= SCM_GOOPS_UNBOUND
;
2576 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2577 name
, supers
, SCM_EOL
);
2581 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2585 if (scm_is_true (type_name_sym
))
2587 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2588 scm_symbol_to_string (type_name_sym
),
2589 scm_from_locale_string (">")));
2590 name
= scm_string_to_symbol (name
);
2593 name
= SCM_GOOPS_UNBOUND
;
2595 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2596 name
, supers
, SCM_EOL
);
2600 scm_make_extended_class (char const *type_name
, int applicablep
)
2602 return make_class_from_template ("<%s>",
2604 scm_list_1 (applicablep
2605 ? scm_class_applicable
2611 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2613 return make_class_from_symbol (type_name_sym
,
2614 scm_list_1 (applicablep
2615 ? scm_class_applicable
2621 scm_i_inherit_applicable (SCM c
)
2623 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2625 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2626 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2627 /* patch scm_class_applicable into direct-supers */
2628 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2629 if (scm_is_false (top
))
2630 dsupers
= scm_append (scm_list_2 (dsupers
,
2631 scm_list_1 (scm_class_applicable
)));
2634 SCM_SETCAR (top
, scm_class_applicable
);
2635 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2637 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2638 /* patch scm_class_applicable into cpl */
2639 top
= scm_c_memq (scm_class_top
, cpl
);
2640 if (scm_is_false (top
))
2644 SCM_SETCAR (top
, scm_class_applicable
);
2645 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2647 /* add class to direct-subclasses of scm_class_applicable */
2648 SCM_SET_SLOT (scm_class_applicable
,
2649 scm_si_direct_subclasses
,
2650 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2651 scm_si_direct_subclasses
)));
2656 create_smob_classes (void)
2660 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2661 scm_smob_class
[i
] = SCM_BOOL_F
;
2663 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2665 for (i
= 0; i
< scm_numsmob
; ++i
)
2666 if (scm_is_false (scm_smob_class
[i
]))
2667 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2668 scm_smobs
[i
].apply
!= 0);
2672 scm_make_port_classes (long ptobnum
, char *type_name
)
2674 SCM c
, class = make_class_from_template ("<%s-port>",
2676 scm_list_1 (scm_class_port
),
2678 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2679 = make_class_from_template ("<%s-input-port>",
2681 scm_list_2 (class, scm_class_input_port
),
2683 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2684 = make_class_from_template ("<%s-output-port>",
2686 scm_list_2 (class, scm_class_output_port
),
2688 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2690 = make_class_from_template ("<%s-input-output-port>",
2692 scm_list_2 (class, scm_class_input_output_port
),
2694 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2695 SCM_SET_SLOT (c
, scm_si_cpl
,
2696 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2700 create_port_classes (void)
2704 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2705 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2709 make_struct_class (void *closure SCM_UNUSED
,
2710 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2712 if (scm_is_false (data
))
2713 scm_i_define_class_for_vtable (vtable
);
2714 return SCM_UNSPECIFIED
;
2718 create_struct_classes (void)
2720 /* FIXME: take the vtable_class_map while initializing goops? */
2721 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2725 /**********************************************************************
2729 **********************************************************************/
2734 if (!goops_loaded_p
)
2735 scm_c_resolve_module ("oop goops");
2739 SCM_SYMBOL (sym_o
, "o");
2740 SCM_SYMBOL (sym_x
, "x");
2742 SCM_KEYWORD (k_accessor
, "accessor");
2743 SCM_KEYWORD (k_getter
, "getter");
2746 scm_ensure_accessor (SCM name
)
2750 var
= scm_module_variable (scm_current_module (), name
);
2751 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2752 gf
= SCM_VARIABLE_REF (var
);
2756 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2758 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2759 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2760 k_name
, name
, k_setter
, gf
));
2768 * Debugging utilities
2771 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2773 "Return @code{#t} if @var{obj} is a pure generic.")
2774 #define FUNC_NAME s_scm_pure_generic_p
2776 return scm_from_bool (SCM_PUREGENERICP (obj
));
2780 #endif /* GUILE_DEBUG */
2786 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2788 "Announce that GOOPS is loaded and perform initialization\n"
2789 "on the C level which depends on the loaded GOOPS modules.")
2790 #define FUNC_NAME s_scm_sys_goops_loaded
2793 var_compute_applicable_methods
=
2794 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2796 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2798 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2800 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2801 var_no_applicable_method
=
2802 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2804 scm_module_variable (scm_module_goops
, sym_change_class
);
2805 setup_extended_primitive_generics ();
2806 return SCM_UNSPECIFIED
;
2810 SCM scm_module_goops
;
2813 scm_init_goops_builtins (void)
2815 scm_module_goops
= scm_current_module ();
2817 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2819 #include "libguile/goops.x"
2821 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2822 hell_mutex
= scm_make_mutex ();
2824 create_basic_classes ();
2825 create_standard_classes ();
2826 create_smob_classes ();
2827 create_struct_classes ();
2828 create_port_classes ();
2831 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2832 scm_no_applicable_method
=
2833 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2834 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2837 return SCM_UNSPECIFIED
;
2843 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2844 scm_init_goops_builtins
);