1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/chars.h"
38 #include "libguile/debug.h"
39 #include "libguile/dynl.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eval.h"
42 #include "libguile/gsubr.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/vm.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
61 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
64 #define SCM_IN_PCLASS_INDEX 0
65 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
66 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
68 /* this file is a mess. in theory, though, we shouldn't have many SCM references
69 -- most of the references should be to vars. */
71 static SCM var_slot_unbound
= SCM_BOOL_F
;
72 static SCM var_slot_missing
= SCM_BOOL_F
;
73 static SCM var_compute_cpl
= SCM_BOOL_F
;
74 static SCM var_no_applicable_method
= SCM_BOOL_F
;
75 static SCM var_change_class
= SCM_BOOL_F
;
77 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
78 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
79 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
80 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
81 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
82 SCM_SYMBOL (sym_change_class
, "change-class");
84 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
87 /* Class redefinition protocol:
89 A class is represented by a heap header h1 which points to a
90 malloc:ed memory block m1.
92 When a new version of a class is created, a new header h2 and
93 memory block m2 are allocated. The headers h1 and h2 then switch
94 pointers so that h1 refers to m2 and h2 to m1. In this way, names
95 bound to h1 will point to the new class at the same time as h2 will
96 be a handle which the GC will use to free m1.
98 The `redefined' slot of m1 will be set to point to h1. An old
99 instance will have its class pointer (the CAR of the heap header)
100 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
101 the class modification and the new class pointer can be found via
105 #define TEST_CHANGE_CLASS(obj, class) \
107 class = SCM_CLASS_OF (obj); \
108 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
110 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
111 class = SCM_CLASS_OF (obj); \
115 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
116 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
118 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
119 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
121 static int goops_loaded_p
= 0;
122 static scm_t_rstate
*goops_rstate
;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
126 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
127 SCM scm_class_primitive_generic
;
128 SCM scm_class_vector
, scm_class_null
;
129 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
130 SCM scm_class_unknown
;
131 SCM scm_class_top
, scm_class_object
, scm_class_class
;
132 SCM scm_class_applicable
;
133 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
134 SCM scm_class_generic
, scm_class_generic_with_setter
;
135 SCM scm_class_accessor
;
136 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
137 SCM scm_class_extended_accessor
;
138 SCM scm_class_method
;
139 SCM scm_class_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_applicable_struct_class
;
142 SCM scm_class_number
, scm_class_list
;
143 SCM scm_class_keyword
;
144 SCM scm_class_port
, scm_class_input_output_port
;
145 SCM scm_class_input_port
, scm_class_output_port
;
146 SCM scm_class_foreign_slot
;
147 SCM scm_class_self
, scm_class_protected
;
148 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
149 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
151 SCM scm_class_int
, scm_class_float
, scm_class_double
;
153 static SCM class_foreign
;
154 static SCM class_hashtable
;
155 static SCM class_fluid
;
156 static SCM class_dynamic_state
;
157 static SCM class_frame
;
158 static SCM class_objcode
;
160 static SCM class_vm_cont
;
161 static SCM class_bytevector
;
162 static SCM class_uvec
;
164 static SCM vtable_class_map
= SCM_BOOL_F
;
166 /* Port classes. Allocate 3 times the maximum number of port types so that
167 input ports, output ports, and in/out ports can be stored at different
168 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
169 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
172 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
174 SCM scm_no_applicable_method
;
176 SCM_SYMBOL (scm_sym_define_public
, "define-public");
178 static SCM
scm_make_unbound (void);
179 static SCM
scm_unbound_p (SCM obj
);
180 static SCM
scm_assert_bound (SCM value
, SCM obj
);
181 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
182 static SCM
scm_sys_goops_loaded (void);
183 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
188 scm_i_define_class_for_vtable (SCM vtable
)
192 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
193 if (scm_is_false (vtable_class_map
))
194 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
195 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
197 if (scm_is_false (scm_struct_vtable_p (vtable
)))
200 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
202 if (scm_is_false (class))
204 if (SCM_UNPACK (scm_class_class
))
206 SCM name
= SCM_VTABLE_NAME (vtable
);
207 if (!scm_is_symbol (name
))
208 name
= scm_string_to_symbol (scm_nullstr
);
210 class = scm_make_extended_class_from_symbol
211 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
214 /* `create_struct_classes' will fill this in later. */
217 /* Don't worry about races. This only happens when creating a
218 vtable, which happens by definition in one thread. */
219 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
225 /* This function is used for efficient type dispatch. */
226 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
228 "Return the class of @var{x}.")
229 #define FUNC_NAME s_scm_class_of
231 switch (SCM_ITAG3 (x
))
235 return scm_class_integer
;
239 return scm_class_char
;
240 else if (scm_is_bool (x
))
241 return scm_class_boolean
;
242 else if (scm_is_null (x
))
243 return scm_class_null
;
245 return scm_class_unknown
;
248 switch (SCM_TYP7 (x
))
250 case scm_tcs_cons_nimcar
:
251 return scm_class_pair
;
253 return scm_class_symbol
;
256 return scm_class_vector
;
257 case scm_tc7_pointer
:
258 return class_foreign
;
259 case scm_tc7_hashtable
:
260 return class_hashtable
;
263 case scm_tc7_dynamic_state
:
264 return class_dynamic_state
;
267 case scm_tc7_objcode
:
268 return class_objcode
;
271 case scm_tc7_vm_cont
:
272 return class_vm_cont
;
273 case scm_tc7_bytevector
:
274 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
275 return class_bytevector
;
279 return scm_class_string
;
281 switch SCM_TYP16 (x
) {
283 return scm_class_integer
;
285 return scm_class_real
;
286 case scm_tc16_complex
:
287 return scm_class_complex
;
288 case scm_tc16_fraction
:
289 return scm_class_fraction
;
291 case scm_tc7_program
:
292 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
293 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
294 return scm_class_primitive_generic
;
296 return scm_class_procedure
;
300 scm_t_bits type
= SCM_TYP16 (x
);
301 if (type
!= scm_tc16_port_with_ps
)
302 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
303 x
= SCM_PORT_WITH_PS_PORT (x
);
304 /* fall through to ports */
307 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
308 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
309 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
310 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
311 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
313 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
314 return SCM_CLASS_OF (x
);
315 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
318 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
319 scm_change_object_class (x
,
320 SCM_CLASS_OF (x
), /* old */
321 SCM_OBJ_CLASS_REDEF (x
)); /* new */
322 return SCM_CLASS_OF (x
);
325 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
328 return scm_class_pair
;
330 return scm_class_unknown
;
336 /* case scm_tc3_unused: */
340 return scm_class_unknown
;
344 /******************************************************************************
348 * This version doesn't fully handle multiple-inheritance. It serves
349 * only for booting classes and will be overloaded in Scheme
351 ******************************************************************************/
354 map (SCM (*proc
) (SCM
), SCM ls
)
356 if (scm_is_null (ls
))
360 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
363 while (scm_is_pair (ls
))
365 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
377 while (scm_is_pair (ls
))
379 SCM el
= SCM_CAR (ls
);
380 if (scm_is_false (scm_c_memq (el
, res
)))
381 res
= scm_cons (el
, res
);
388 compute_cpl (SCM
class)
391 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
394 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
395 SCM ls
= scm_append (scm_acons (class, supers
,
396 map (compute_cpl
, supers
)));
397 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
401 /******************************************************************************
405 ******************************************************************************/
408 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
412 if (!scm_is_pair (l
))
416 if (!scm_is_symbol (tmp
))
417 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
419 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
420 res
= scm_cons (SCM_CAR (l
), res
);
421 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
424 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
428 check_cpl (SCM slots
, SCM bslots
)
430 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
431 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
432 scm_misc_error ("init-object", "a predefined <class> inherited "
433 "field cannot be redefined", SCM_EOL
);
437 build_class_class_slots (void);
440 build_slots_list (SCM dslots
, SCM cpl
)
442 SCM bslots
, class_slots
;
446 class_slots
= SCM_EOL
;
447 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
451 bslots
= build_class_class_slots ();
452 check_cpl (res
, bslots
);
457 if (scm_is_pair (cpl
))
459 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
461 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
462 scm_si_direct_slots
);
465 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
466 check_cpl (new_slots
, bslots
);
469 /* Move class slots to the head of the list. */
470 class_slots
= new_slots
;
474 res
= scm_append (scm_list_2 (new_slots
, res
));
478 scm_misc_error ("%compute-slots", "malformed cpl argument in "
479 "build_slots_list", SCM_EOL
);
481 /* make sure to add the <class> slots to the head of the list */
483 res
= scm_append (scm_list_2 (class_slots
, res
));
485 /* res contains a list of slots. Remove slots which appears more than once */
486 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
493 while (!scm_is_null (ls
))
495 if (!scm_is_pair (ls
))
496 scm_misc_error ("%compute-slots", "malformed ls argument in "
498 if (!scm_is_pair (SCM_CAR (ls
)))
499 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
506 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
508 "Return a list consisting of the names of all slots belonging to\n"
509 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
511 #define FUNC_NAME s_scm_sys_compute_slots
513 SCM_VALIDATE_CLASS (1, class);
514 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
515 SCM_SLOT (class, scm_si_cpl
));
520 /******************************************************************************
522 * compute-getters-n-setters
524 * This version doesn't handle slot options. It serves only for booting
525 * classes and will be overloaded in Scheme.
527 ******************************************************************************/
529 SCM_KEYWORD (k_init_value
, "init-value");
530 SCM_KEYWORD (k_init_thunk
, "init-thunk");
533 compute_getters_n_setters (SCM slots
)
539 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
541 SCM init
= SCM_BOOL_F
;
542 SCM options
= SCM_CDAR (slots
);
543 if (!scm_is_null (options
))
545 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
546 if (SCM_UNPACK (init
))
548 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
550 scm_list_2 (scm_sym_quote
,
554 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
556 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
558 scm_from_int (i
++))),
560 cdrloc
= SCM_CDRLOC (*cdrloc
);
565 /******************************************************************************
569 ******************************************************************************/
571 /*fixme* Manufacture keywords in advance */
573 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
577 for (i
= 0; i
!= len
; i
+= 2)
579 SCM obj
= SCM_CAR (l
);
581 if (!scm_is_keyword (obj
))
582 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
583 else if (scm_is_eq (obj
, key
))
589 return default_value
;
593 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
594 (SCM key
, SCM l
, SCM default_value
),
595 "Determine an associated value for the keyword @var{key} from\n"
596 "the list @var{l}. The list @var{l} has to consist of an even\n"
597 "number of elements, where, starting with the first, every\n"
598 "second element is a keyword, followed by its associated value.\n"
599 "If @var{l} does not hold a value for @var{key}, the value\n"
600 "@var{default_value} is returned.")
601 #define FUNC_NAME s_scm_get_keyword
605 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
606 len
= scm_ilength (l
);
607 if (len
< 0 || len
% 2 == 1)
608 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
610 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
615 SCM_KEYWORD (k_init_keyword
, "init-keyword");
617 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
618 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
620 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
621 (SCM obj
, SCM initargs
),
622 "Initialize the object @var{obj} with the given arguments\n"
624 #define FUNC_NAME s_scm_sys_initialize_object
626 SCM tmp
, get_n_set
, slots
;
627 SCM
class = SCM_CLASS_OF (obj
);
630 SCM_VALIDATE_INSTANCE (1, obj
);
631 n_initargs
= scm_ilength (initargs
);
632 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
634 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
635 slots
= SCM_SLOT (class, scm_si_slots
);
637 /* See for each slot how it must be initialized */
639 !scm_is_null (slots
);
640 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
642 SCM slot_name
= SCM_CAR (slots
);
643 SCM slot_value
= SCM_PACK (0);
645 if (!scm_is_null (SCM_CDR (slot_name
)))
647 /* This slot admits (perhaps) to be initialized at creation time */
648 long n
= scm_ilength (SCM_CDR (slot_name
));
649 if (n
& 1) /* odd or -1 */
650 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
651 scm_list_1 (slot_name
));
652 tmp
= scm_i_get_keyword (k_init_keyword
,
657 slot_name
= SCM_CAR (slot_name
);
658 if (SCM_UNPACK (tmp
))
660 /* an initarg was provided for this slot */
661 if (!scm_is_keyword (tmp
))
662 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
664 slot_value
= scm_i_get_keyword (tmp
,
672 if (SCM_UNPACK (slot_value
))
673 /* set slot to provided value */
674 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
677 /* set slot to its :init-form if it exists */
678 tmp
= SCM_CADAR (get_n_set
);
679 if (scm_is_true (tmp
))
681 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
682 if (SCM_GOOPS_UNBOUNDP (slot_value
))
683 set_slot_value (class,
695 /* NOTE: The following macros are interdependent with code
696 * in goops.scm:compute-getters-n-setters
698 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
699 (SCM_I_INUMP (SCM_CDDR (gns)) \
700 || (scm_is_pair (SCM_CDDR (gns)) \
701 && scm_is_pair (SCM_CDDDR (gns)) \
702 && scm_is_pair (SCM_CDDDDR (gns))))
703 #define SCM_GNS_INDEX(gns) \
704 (SCM_I_INUMP (SCM_CDDR (gns)) \
705 ? SCM_I_INUM (SCM_CDDR (gns)) \
706 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
707 #define SCM_GNS_SIZE(gns) \
708 (SCM_I_INUMP (SCM_CDDR (gns)) \
710 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
712 SCM_KEYWORD (k_class
, "class");
713 SCM_KEYWORD (k_allocation
, "allocation");
714 SCM_KEYWORD (k_instance
, "instance");
716 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
719 #define FUNC_NAME s_scm_sys_prep_layout_x
721 SCM slots
, getters_n_setters
, nfields
;
722 unsigned long int n
, i
;
726 SCM_VALIDATE_INSTANCE (1, class);
727 slots
= SCM_SLOT (class, scm_si_slots
);
728 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
729 nfields
= SCM_SLOT (class, scm_si_nfields
);
730 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
731 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
732 scm_list_1 (nfields
));
733 n
= 2 * SCM_I_INUM (nfields
);
734 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
735 && SCM_SUBCLASSP (class, scm_class_class
))
736 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
737 scm_list_1 (nfields
));
739 layout
= scm_i_make_string (n
, &s
, 0);
741 while (scm_is_pair (getters_n_setters
))
743 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
746 int len
, index
, size
;
749 if (i
>= n
|| !scm_is_pair (slots
))
752 /* extract slot type */
753 len
= scm_ilength (SCM_CDAR (slots
));
754 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
755 len
, SCM_BOOL_F
, FUNC_NAME
);
756 /* determine slot GC protection and access mode */
757 if (scm_is_false (type
))
764 if (!SCM_CLASSP (type
))
765 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
766 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
768 if (SCM_SUBCLASSP (type
, scm_class_self
))
770 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
775 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
777 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
779 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
791 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
792 if (index
!= (i
>> 1))
794 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
802 slots
= SCM_CDR (slots
);
803 getters_n_setters
= SCM_CDR (getters_n_setters
);
805 if (!scm_is_null (slots
))
808 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
810 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
811 return SCM_UNSPECIFIED
;
815 static void prep_hashsets (SCM
);
817 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
818 (SCM
class, SCM dsupers
),
820 #define FUNC_NAME s_scm_sys_inherit_magic_x
822 SCM_VALIDATE_INSTANCE (1, class);
823 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
824 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
826 prep_hashsets (class);
828 return SCM_UNSPECIFIED
;
833 prep_hashsets (SCM
class)
837 for (i
= 0; i
< 8; ++i
)
838 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
841 /******************************************************************************/
844 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
846 SCM z
, cpl
, slots
, nfields
, g_n_s
;
848 /* Allocate one instance */
849 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
851 /* Initialize its slots */
852 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
853 cpl
= compute_cpl (z
);
854 slots
= build_slots_list (maplist (dslots
), cpl
);
855 nfields
= scm_from_int (scm_ilength (slots
));
856 g_n_s
= compute_getters_n_setters (slots
);
858 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
859 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
860 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
861 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
862 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
863 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
864 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
865 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
866 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
868 /* Add this class in the direct-subclasses slot of dsupers */
871 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
872 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
873 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
874 scm_si_direct_subclasses
)));
881 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
883 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
884 scm_sys_prep_layout_x (z
);
885 scm_sys_inherit_magic_x (z
, dsupers
);
889 /******************************************************************************/
891 SCM_SYMBOL (sym_layout
, "layout");
892 SCM_SYMBOL (sym_flags
, "flags");
893 SCM_SYMBOL (sym_self
, "%self");
894 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
895 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
896 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
897 SCM_SYMBOL (sym_print
, "print");
898 SCM_SYMBOL (sym_procedure
, "procedure");
899 SCM_SYMBOL (sym_setter
, "setter");
900 SCM_SYMBOL (sym_redefined
, "redefined");
901 SCM_SYMBOL (sym_h0
, "h0");
902 SCM_SYMBOL (sym_h1
, "h1");
903 SCM_SYMBOL (sym_h2
, "h2");
904 SCM_SYMBOL (sym_h3
, "h3");
905 SCM_SYMBOL (sym_h4
, "h4");
906 SCM_SYMBOL (sym_h5
, "h5");
907 SCM_SYMBOL (sym_h6
, "h6");
908 SCM_SYMBOL (sym_h7
, "h7");
909 SCM_SYMBOL (sym_name
, "name");
910 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
911 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
912 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
913 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
914 SCM_SYMBOL (sym_cpl
, "cpl");
915 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
916 SCM_SYMBOL (sym_slots
, "slots");
917 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
918 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
919 SCM_SYMBOL (sym_nfields
, "nfields");
923 build_class_class_slots (void)
925 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
926 SCM_CLASS_CLASS_LAYOUT */
928 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
929 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
930 scm_list_3 (sym_self
, k_class
, scm_class_self
),
931 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
932 scm_list_1 (sym_print
),
933 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
934 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
935 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
936 scm_list_1 (sym_redefined
),
937 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
938 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
939 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
940 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
941 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
942 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
943 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
944 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
945 scm_list_1 (sym_direct_supers
),
946 scm_list_1 (sym_direct_slots
),
947 scm_list_1 (sym_direct_subclasses
),
948 scm_list_1 (sym_direct_methods
),
949 scm_list_1 (sym_cpl
),
950 scm_list_1 (sym_default_slot_definition_class
),
951 scm_list_1 (sym_slots
),
952 scm_list_1 (sym_getters_n_setters
),
953 scm_list_1 (sym_keyword_access
),
954 scm_list_1 (sym_nfields
),
959 create_basic_classes (void)
961 /* SCM slots_of_class = build_class_class_slots (); */
964 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
965 SCM name
= scm_from_latin1_symbol ("<class>");
966 scm_class_class
= scm_make_vtable_vtable (cs
, SCM_INUM0
, SCM_EOL
);
967 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
968 | SCM_CLASSF_METACLASS
));
970 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
971 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
972 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
973 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
974 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
975 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
976 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
977 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
978 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
979 compute_getters_n_setters (slots_of_class)); */
980 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
982 prep_hashsets (scm_class_class
);
984 scm_module_define (scm_module_goops
, name
, scm_class_class
);
987 name
= scm_from_latin1_symbol ("<top>");
988 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
991 scm_module_define (scm_module_goops
, name
, scm_class_top
);
994 name
= scm_from_latin1_symbol ("<object>");
995 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
996 scm_list_1 (scm_class_top
), SCM_EOL
);
998 scm_module_define (scm_module_goops
, name
, scm_class_object
);
1000 /* <top> <object> and <class> were partially initialized. Correct them here */
1001 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1003 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1004 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1007 /******************************************************************************/
1009 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1011 "Return @code{#t} if @var{obj} is an instance.")
1012 #define FUNC_NAME s_scm_instance_p
1014 return scm_from_bool (SCM_INSTANCEP (obj
));
1019 /******************************************************************************
1021 * Meta object accessors
1023 ******************************************************************************/
1024 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1026 "Return the class name of @var{obj}.")
1027 #define FUNC_NAME s_scm_class_name
1029 SCM_VALIDATE_CLASS (1, obj
);
1030 return scm_slot_ref (obj
, sym_name
);
1034 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1036 "Return the direct superclasses of the class @var{obj}.")
1037 #define FUNC_NAME s_scm_class_direct_supers
1039 SCM_VALIDATE_CLASS (1, obj
);
1040 return scm_slot_ref (obj
, sym_direct_supers
);
1044 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1046 "Return the direct slots of the class @var{obj}.")
1047 #define FUNC_NAME s_scm_class_direct_slots
1049 SCM_VALIDATE_CLASS (1, obj
);
1050 return scm_slot_ref (obj
, sym_direct_slots
);
1054 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1056 "Return the direct subclasses of the class @var{obj}.")
1057 #define FUNC_NAME s_scm_class_direct_subclasses
1059 SCM_VALIDATE_CLASS (1, obj
);
1060 return scm_slot_ref(obj
, sym_direct_subclasses
);
1064 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1066 "Return the direct methods of the class @var{obj}")
1067 #define FUNC_NAME s_scm_class_direct_methods
1069 SCM_VALIDATE_CLASS (1, obj
);
1070 return scm_slot_ref (obj
, sym_direct_methods
);
1074 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1076 "Return the class precedence list of the class @var{obj}.")
1077 #define FUNC_NAME s_scm_class_precedence_list
1079 SCM_VALIDATE_CLASS (1, obj
);
1080 return scm_slot_ref (obj
, sym_cpl
);
1084 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1086 "Return the slot list of the class @var{obj}.")
1087 #define FUNC_NAME s_scm_class_slots
1089 SCM_VALIDATE_CLASS (1, obj
);
1090 return scm_slot_ref (obj
, sym_slots
);
1094 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1096 "Return the name of the generic function @var{obj}.")
1097 #define FUNC_NAME s_scm_generic_function_name
1099 SCM_VALIDATE_GENERIC (1, obj
);
1100 return scm_procedure_property (obj
, scm_sym_name
);
1104 SCM_SYMBOL (sym_methods
, "methods");
1105 SCM_SYMBOL (sym_extended_by
, "extended-by");
1106 SCM_SYMBOL (sym_extends
, "extends");
1109 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1111 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1112 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1113 while (!scm_is_null (gfs
))
1115 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1116 gfs
= SCM_CDR (gfs
);
1118 return method_lists
;
1122 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1124 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1126 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1127 while (!scm_is_null (gfs
))
1129 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1130 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1133 gfs
= SCM_CDR (gfs
);
1136 return method_lists
;
1139 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1141 "Return the methods of the generic function @var{obj}.")
1142 #define FUNC_NAME s_scm_generic_function_methods
1145 SCM_VALIDATE_GENERIC (1, obj
);
1146 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1147 methods
= fold_downward_gf_methods (methods
, obj
);
1148 return scm_append (methods
);
1152 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1154 "Return the generic function for the method @var{obj}.")
1155 #define FUNC_NAME s_scm_method_generic_function
1157 SCM_VALIDATE_METHOD (1, obj
);
1158 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1162 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1164 "Return specializers of the method @var{obj}.")
1165 #define FUNC_NAME s_scm_method_specializers
1167 SCM_VALIDATE_METHOD (1, obj
);
1168 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1172 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1174 "Return the procedure of the method @var{obj}.")
1175 #define FUNC_NAME s_scm_method_procedure
1177 SCM_VALIDATE_METHOD (1, obj
);
1178 return scm_slot_ref (obj
, sym_procedure
);
1182 /******************************************************************************
1184 * S l o t a c c e s s
1186 ******************************************************************************/
1188 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1190 "Return the unbound value.")
1191 #define FUNC_NAME s_scm_make_unbound
1193 return SCM_GOOPS_UNBOUND
;
1197 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1199 "Return @code{#t} if @var{obj} is unbound.")
1200 #define FUNC_NAME s_scm_unbound_p
1202 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1206 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1207 (SCM value
, SCM obj
),
1208 "Return @var{value} if it is bound, and invoke the\n"
1209 "@var{slot-unbound} method of @var{obj} if it is not.")
1210 #define FUNC_NAME s_scm_assert_bound
1212 if (SCM_GOOPS_UNBOUNDP (value
))
1213 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1218 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1219 (SCM obj
, SCM index
),
1220 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1221 "the value from @var{obj}.")
1222 #define FUNC_NAME s_scm_at_assert_bound_ref
1224 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1225 if (SCM_GOOPS_UNBOUNDP (value
))
1226 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1231 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1232 (SCM obj
, SCM index
),
1233 "Return the slot value with index @var{index} from @var{obj}.")
1234 #define FUNC_NAME s_scm_sys_fast_slot_ref
1238 SCM_VALIDATE_INSTANCE (1, obj
);
1239 i
= scm_to_unsigned_integer (index
, 0,
1240 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1243 return SCM_SLOT (obj
, i
);
1247 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1248 (SCM obj
, SCM index
, SCM value
),
1249 "Set the slot with index @var{index} in @var{obj} to\n"
1251 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1255 SCM_VALIDATE_INSTANCE (1, obj
);
1256 i
= scm_to_unsigned_integer (index
, 0,
1257 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1261 SCM_SET_SLOT (obj
, i
, value
);
1263 return SCM_UNSPECIFIED
;
1271 /* In the future, this function will return the effective slot
1272 * definition associated with SLOT_NAME. Now it just returns some of
1273 * the information which will be stored in the effective slot
1278 slot_definition_using_name (SCM
class, SCM slot_name
)
1280 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1281 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1282 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1283 return SCM_CAR (slots
);
1288 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1289 #define FUNC_NAME "%get-slot-value"
1291 SCM access
= SCM_CDDR (slotdef
);
1293 * - access is an integer (the offset of this slot in the slots vector)
1294 * - otherwise (car access) is the getter function to apply
1296 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1297 * we can just assume fixnums here.
1299 if (SCM_I_INUMP (access
))
1300 /* Don't poke at the slots directly, because scm_struct_ref handles the
1301 access bits for us. */
1302 return scm_struct_ref (obj
, access
);
1304 return scm_call_1 (SCM_CAR (access
), obj
);
1309 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1311 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1312 if (scm_is_true (slotdef
))
1313 return get_slot_value (class, obj
, slotdef
);
1315 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1319 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1320 #define FUNC_NAME "%set-slot-value"
1322 SCM access
= SCM_CDDR (slotdef
);
1324 * - access is an integer (the offset of this slot in the slots vector)
1325 * - otherwise (cadr access) is the setter function to apply
1327 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1328 * we can just assume fixnums here.
1330 if (SCM_I_INUMP (access
))
1331 /* obey permissions bits via going through struct-set! */
1332 scm_struct_set_x (obj
, access
, value
);
1334 /* ((cadr l) obj value) */
1335 scm_call_2 (SCM_CADR (access
), obj
, value
);
1336 return SCM_UNSPECIFIED
;
1341 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1343 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1344 if (scm_is_true (slotdef
))
1345 return set_slot_value (class, obj
, slotdef
, value
);
1347 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1351 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1355 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1356 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1362 /* ======================================== */
1364 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1365 (SCM
class, SCM obj
, SCM slot_name
),
1367 #define FUNC_NAME s_scm_slot_ref_using_class
1371 SCM_VALIDATE_CLASS (1, class);
1372 SCM_VALIDATE_INSTANCE (2, obj
);
1373 SCM_VALIDATE_SYMBOL (3, slot_name
);
1375 res
= get_slot_value_using_name (class, obj
, slot_name
);
1376 if (SCM_GOOPS_UNBOUNDP (res
))
1377 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1383 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1384 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1386 #define FUNC_NAME s_scm_slot_set_using_class_x
1388 SCM_VALIDATE_CLASS (1, class);
1389 SCM_VALIDATE_INSTANCE (2, obj
);
1390 SCM_VALIDATE_SYMBOL (3, slot_name
);
1392 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1397 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1398 (SCM
class, SCM obj
, SCM slot_name
),
1400 #define FUNC_NAME s_scm_slot_bound_using_class_p
1402 SCM_VALIDATE_CLASS (1, class);
1403 SCM_VALIDATE_INSTANCE (2, obj
);
1404 SCM_VALIDATE_SYMBOL (3, slot_name
);
1406 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1412 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1413 (SCM
class, SCM obj
, SCM slot_name
),
1415 #define FUNC_NAME s_scm_slot_exists_using_class_p
1417 SCM_VALIDATE_CLASS (1, class);
1418 SCM_VALIDATE_INSTANCE (2, obj
);
1419 SCM_VALIDATE_SYMBOL (3, slot_name
);
1420 return test_slot_existence (class, obj
, slot_name
);
1425 /* ======================================== */
1427 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1428 (SCM obj
, SCM slot_name
),
1429 "Return the value from @var{obj}'s slot with the name\n"
1431 #define FUNC_NAME s_scm_slot_ref
1435 SCM_VALIDATE_INSTANCE (1, obj
);
1436 TEST_CHANGE_CLASS (obj
, class);
1438 res
= get_slot_value_using_name (class, obj
, slot_name
);
1439 if (SCM_GOOPS_UNBOUNDP (res
))
1440 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1445 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1446 (SCM obj
, SCM slot_name
, SCM value
),
1447 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1448 #define FUNC_NAME s_scm_slot_set_x
1452 SCM_VALIDATE_INSTANCE (1, obj
);
1453 TEST_CHANGE_CLASS(obj
, class);
1455 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1459 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1461 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1462 (SCM obj
, SCM slot_name
),
1463 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1465 #define FUNC_NAME s_scm_slot_bound_p
1469 SCM_VALIDATE_INSTANCE (1, obj
);
1470 TEST_CHANGE_CLASS(obj
, class);
1472 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1480 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1481 (SCM obj
, SCM slot_name
),
1482 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1483 #define FUNC_NAME s_scm_slot_exists_p
1487 SCM_VALIDATE_INSTANCE (1, obj
);
1488 SCM_VALIDATE_SYMBOL (2, slot_name
);
1489 TEST_CHANGE_CLASS (obj
, class);
1491 return test_slot_existence (class, obj
, slot_name
);
1496 /******************************************************************************
1498 * %allocate-instance (the low level instance allocation primitive)
1500 ******************************************************************************/
1502 static void clear_method_cache (SCM
);
1504 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1505 (SCM
class, SCM initargs
),
1506 "Create a new instance of class @var{class} and initialize it\n"
1507 "from the arguments @var{initargs}.")
1508 #define FUNC_NAME s_scm_sys_allocate_instance
1511 scm_t_signed_bits n
, i
;
1514 SCM_VALIDATE_CLASS (1, class);
1516 /* FIXME: duplicates some of scm_make_struct. */
1518 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1519 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1521 layout
= SCM_VTABLE_LAYOUT (class);
1523 /* Set all SCM-holding slots to unbound */
1524 for (i
= 0; i
< n
; i
++)
1526 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1528 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1530 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1532 SCM_STRUCT_DATA (obj
)[i
] = 0;
1535 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1536 clear_method_cache (obj
);
1542 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1543 (SCM obj
, SCM setter
),
1545 #define FUNC_NAME s_scm_sys_set_object_setter_x
1547 SCM_ASSERT (SCM_STRUCTP (obj
)
1548 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1552 SCM_SET_GENERIC_SETTER (obj
, setter
);
1553 return SCM_UNSPECIFIED
;
1557 /******************************************************************************
1559 * %modify-instance (used by change-class to modify in place)
1561 ******************************************************************************/
1563 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1566 #define FUNC_NAME s_scm_sys_modify_instance
1568 SCM_VALIDATE_INSTANCE (1, old
);
1569 SCM_VALIDATE_INSTANCE (2, new);
1571 /* Exchange the data contained in old and new. We exchange rather than
1572 * scratch the old value with new to be correct with GC.
1573 * See "Class redefinition protocol above".
1575 SCM_CRITICAL_SECTION_START
;
1577 scm_t_bits word0
, word1
;
1578 word0
= SCM_CELL_WORD_0 (old
);
1579 word1
= SCM_CELL_WORD_1 (old
);
1580 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1581 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1582 SCM_SET_CELL_WORD_0 (new, word0
);
1583 SCM_SET_CELL_WORD_1 (new, word1
);
1585 SCM_CRITICAL_SECTION_END
;
1586 return SCM_UNSPECIFIED
;
1590 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1593 #define FUNC_NAME s_scm_sys_modify_class
1595 SCM_VALIDATE_CLASS (1, old
);
1596 SCM_VALIDATE_CLASS (2, new);
1598 SCM_CRITICAL_SECTION_START
;
1600 scm_t_bits word0
, word1
;
1601 word0
= SCM_CELL_WORD_0 (old
);
1602 word1
= SCM_CELL_WORD_1 (old
);
1603 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1604 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1605 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1606 SCM_SET_CELL_WORD_0 (new, word0
);
1607 SCM_SET_CELL_WORD_1 (new, word1
);
1608 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1610 SCM_CRITICAL_SECTION_END
;
1611 return SCM_UNSPECIFIED
;
1615 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1618 #define FUNC_NAME s_scm_sys_invalidate_class
1620 SCM_VALIDATE_CLASS (1, class);
1621 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1622 return SCM_UNSPECIFIED
;
1626 /* When instances change class, they finally get a new body, but
1627 * before that, they go through purgatory in hell. Odd as it may
1628 * seem, this data structure saves us from eternal suffering in
1629 * infinite recursions.
1632 static scm_t_bits
**hell
;
1633 static long n_hell
= 1; /* one place for the evil one himself */
1634 static long hell_size
= 4;
1635 static SCM hell_mutex
;
1641 for (i
= 1; i
< n_hell
; ++i
)
1642 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1648 go_to_hell (void *o
)
1651 scm_lock_mutex (hell_mutex
);
1652 if (n_hell
>= hell_size
)
1655 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1657 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1658 scm_unlock_mutex (hell_mutex
);
1662 go_to_heaven (void *o
)
1665 scm_lock_mutex (hell_mutex
);
1666 hell
[burnin (obj
)] = hell
[--n_hell
];
1667 scm_unlock_mutex (hell_mutex
);
1671 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1674 purgatory (SCM obj
, SCM new_class
)
1676 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1679 /* This function calls the generic function change-class for all
1680 * instances which aren't currently undergoing class change.
1684 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1688 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1689 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1690 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1691 purgatory (obj
, new_class
);
1696 /******************************************************************************
1702 * GGG E N E R I C F U N C T I O N S
1704 * This implementation provides
1705 * - generic functions (with class specializers)
1708 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1710 ******************************************************************************/
1712 SCM_KEYWORD (k_name
, "name");
1714 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1717 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1719 make_dispatch_procedure (SCM gf
)
1721 static SCM var
= SCM_BOOL_F
;
1722 if (scm_is_false (var
))
1723 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1724 sym_delayed_compile
);
1725 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1729 clear_method_cache (SCM gf
)
1731 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1732 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1735 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1738 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1740 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1741 clear_method_cache (gf
);
1742 return SCM_UNSPECIFIED
;
1746 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1749 #define FUNC_NAME s_scm_generic_capability_p
1751 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1752 proc
, SCM_ARG1
, FUNC_NAME
);
1753 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1757 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1760 #define FUNC_NAME s_scm_enable_primitive_generic_x
1762 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1763 while (!scm_is_null (subrs
))
1765 SCM subr
= SCM_CAR (subrs
);
1766 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1767 SCM_SET_SUBR_GENERIC (subr
,
1768 scm_make (scm_list_3 (scm_class_generic
,
1770 SCM_SUBR_NAME (subr
))));
1771 subrs
= SCM_CDR (subrs
);
1773 return SCM_UNSPECIFIED
;
1777 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1778 (SCM subr
, SCM generic
),
1780 #define FUNC_NAME s_scm_set_primitive_generic_x
1782 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1783 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1784 SCM_SET_SUBR_GENERIC (subr
, generic
);
1785 return SCM_UNSPECIFIED
;
1789 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1792 #define FUNC_NAME s_scm_primitive_generic_generic
1794 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1796 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1797 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1798 return *SCM_SUBR_GENERIC (subr
);
1800 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1804 typedef struct t_extension
{
1805 struct t_extension
*next
;
1811 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1813 static const char extension_gc_hint
[] = "GOOPS extension";
1815 static t_extension
*extensions
= 0;
1818 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1823 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1824 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1825 gf
= *SCM_SUBR_GENERIC (extended
);
1826 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1828 SCM_SUBR_NAME (extension
));
1829 SCM_SET_SUBR_GENERIC (extension
, gext
);
1833 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1835 t_extension
**loc
= &extensions
;
1836 /* Make sure that extensions are placed before their own
1837 * extensions in the extensions list. O(N^2) algorithm, but
1838 * extensions of primitive generics are rare.
1840 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1841 loc
= &(*loc
)->next
;
1843 e
->extended
= extended
;
1844 e
->extension
= extension
;
1850 setup_extended_primitive_generics ()
1854 t_extension
*e
= extensions
;
1855 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1856 extensions
= e
->next
;
1860 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1861 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1862 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1866 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1868 if (!SCM_UNPACK (gf
))
1869 scm_error_num_args_subr (subr
);
1871 return scm_call_0 (gf
);
1875 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1877 if (!SCM_UNPACK (gf
))
1878 scm_wrong_type_arg (subr
, pos
, a1
);
1880 return scm_call_1 (gf
, a1
);
1884 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1886 if (!SCM_UNPACK (gf
))
1887 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1889 return scm_call_2 (gf
, a1
, a2
);
1893 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1895 if (!SCM_UNPACK (gf
))
1896 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1898 return scm_apply_0 (gf
, args
);
1901 /******************************************************************************
1903 * Protocol for calling a generic fumction
1904 * This protocol is roughly equivalent to (parameter are a little bit different
1905 * for efficiency reasons):
1907 * + apply-generic (gf args)
1908 * + compute-applicable-methods (gf args ...)
1909 * + sort-applicable-methods (methods args)
1910 * + apply-methods (gf methods args)
1912 * apply-methods calls make-next-method to build the "continuation" of a a
1913 * method. Applying a next-method will call apply-next-method which in
1914 * turn will call apply again to call effectively the following method.
1916 ******************************************************************************/
1919 applicablep (SCM actual
, SCM formal
)
1921 /* We already know that the cpl is well formed. */
1922 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1926 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1928 register SCM s1
, s2
;
1932 * m1 and m2 can have != length (i.e. one can be one element longer than the
1933 * other when we have a dotted parameter list). For instance, with the call
1936 * (define-method M (a . l) ....)
1937 * (define-method M (a) ....)
1939 * we consider that the second method is more specific.
1941 * BTW, targs is an array of types. We don't need it's size since
1942 * we already know that m1 and m2 are applicable (no risk to go past
1943 * the end of this array).
1946 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1947 if (scm_is_null(s1
)) return 1;
1948 if (scm_is_null(s2
)) return 0;
1949 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1950 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1952 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1953 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1955 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1958 return 0;/* should not occur! */
1961 return 0; /* should not occur! */
1964 #define BUFFSIZE 32 /* big enough for most uses */
1967 scm_i_vector2list (SCM l
, long len
)
1970 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1972 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1973 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1979 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1982 SCM
*v
, vector
= SCM_EOL
;
1983 SCM buffer
[BUFFSIZE
];
1984 SCM save
= method_list
;
1985 scm_t_array_handle handle
;
1987 /* For reasonably sized method_lists we can try to avoid all the
1988 * consing and reorder the list in place...
1989 * This idea is due to David McClain <Dave_McClain@msn.com>
1991 if (size
<= BUFFSIZE
)
1993 for (i
= 0; i
< size
; i
++)
1995 buffer
[i
] = SCM_CAR (method_list
);
1996 method_list
= SCM_CDR (method_list
);
2002 /* Too many elements in method_list to keep everything locally */
2003 vector
= scm_i_vector2list (save
, size
);
2004 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2007 /* Use a simple shell sort since it is generally faster than qsort on
2008 * small vectors (which is probably mostly the case when we have to
2009 * sort a list of applicable methods).
2011 for (incr
= size
/ 2; incr
; incr
/= 2)
2013 for (i
= incr
; i
< size
; i
++)
2015 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2017 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2021 SCM tmp
= v
[j
+ incr
];
2029 if (size
<= BUFFSIZE
)
2031 /* We did it in locally, so restore the original list (reordered) in-place */
2032 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2034 SCM_SETCAR (method_list
, *v
);
2035 method_list
= SCM_CDR (method_list
);
2040 /* If we are here, that's that we did it the hard way... */
2041 scm_array_handle_release (&handle
);
2042 return scm_vector_to_list (vector
);
2046 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2050 SCM l
, fl
, applicable
= SCM_EOL
;
2052 SCM buffer
[BUFFSIZE
];
2056 scm_t_array_handle handle
;
2058 /* Build the list of arguments types */
2059 if (len
>= BUFFSIZE
)
2061 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2062 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2065 note that we don't have to work to reset the generation
2066 count. TMP is a new vector anyway, and it is found
2073 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2074 *p
++ = scm_class_of (SCM_CAR (args
));
2076 /* Build a list of all applicable methods */
2077 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2079 fl
= SPEC_OF (SCM_CAR (l
));
2080 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2082 if (SCM_INSTANCEP (fl
)
2083 /* We have a dotted argument list */
2084 || (i
>= len
&& scm_is_null (fl
)))
2085 { /* both list exhausted */
2086 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2092 || !applicablep (types
[i
], SCM_CAR (fl
)))
2097 if (len
>= BUFFSIZE
)
2098 scm_array_handle_release (&handle
);
2104 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2105 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2111 : sort_applicable_methods (applicable
, count
, types
));
2115 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2118 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2121 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2122 #define FUNC_NAME s_sys_compute_applicable_methods
2125 SCM_VALIDATE_GENERIC (1, gf
);
2126 n
= scm_ilength (args
);
2127 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2128 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2132 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2133 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2134 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2135 scm_sys_compute_applicable_methods
));
2137 /******************************************************************************
2139 * A simple make (which will be redefined later in Scheme)
2140 * This version handles only creation of gf, methods and classes (no instances)
2142 * Since this code will disappear when Goops will be fully booted,
2143 * no precaution is taken to be efficient.
2145 ******************************************************************************/
2147 SCM_KEYWORD (k_setter
, "setter");
2148 SCM_KEYWORD (k_specializers
, "specializers");
2149 SCM_KEYWORD (k_procedure
, "procedure");
2150 SCM_KEYWORD (k_formals
, "formals");
2151 SCM_KEYWORD (k_body
, "body");
2152 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2153 SCM_KEYWORD (k_dsupers
, "dsupers");
2154 SCM_KEYWORD (k_slots
, "slots");
2155 SCM_KEYWORD (k_gf
, "generic-function");
2157 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2159 "Make a new object. @var{args} must contain the class and\n"
2160 "all necessary initialization information.")
2161 #define FUNC_NAME s_scm_make
2164 long len
= scm_ilength (args
);
2166 if (len
<= 0 || (len
& 1) == 0)
2167 SCM_WRONG_NUM_ARGS ();
2169 class = SCM_CAR(args
);
2170 args
= SCM_CDR(args
);
2172 if (scm_is_eq (class, scm_class_generic
)
2173 || scm_is_eq (class, scm_class_accessor
))
2175 z
= scm_make_struct (class, SCM_INUM0
,
2176 scm_list_4 (SCM_BOOL_F
,
2180 scm_set_procedure_property_x (z
, scm_sym_name
,
2181 scm_get_keyword (k_name
,
2184 clear_method_cache (z
);
2185 if (scm_is_eq (class, scm_class_accessor
))
2187 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2188 if (scm_is_true (setter
))
2189 scm_sys_set_object_setter_x (z
, setter
);
2194 z
= scm_sys_allocate_instance (class, args
);
2196 if (scm_is_eq (class, scm_class_method
)
2197 || scm_is_eq (class, scm_class_accessor_method
))
2199 SCM_SET_SLOT (z
, scm_si_generic_function
,
2200 scm_i_get_keyword (k_gf
,
2205 SCM_SET_SLOT (z
, scm_si_specializers
,
2206 scm_i_get_keyword (k_specializers
,
2211 SCM_SET_SLOT (z
, scm_si_procedure
,
2212 scm_i_get_keyword (k_procedure
,
2217 SCM_SET_SLOT (z
, scm_si_formals
,
2218 scm_i_get_keyword (k_formals
,
2223 SCM_SET_SLOT (z
, scm_si_body
,
2224 scm_i_get_keyword (k_body
,
2229 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2230 scm_i_get_keyword (k_make_procedure
,
2238 /* In all the others case, make a new class .... No instance here */
2239 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2240 scm_i_get_keyword (k_name
,
2243 scm_from_latin1_symbol ("???"),
2245 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2246 scm_i_get_keyword (k_dsupers
,
2251 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2252 scm_i_get_keyword (k_slots
,
2263 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2266 #define FUNC_NAME s_scm_find_method
2269 long len
= scm_ilength (l
);
2272 SCM_WRONG_NUM_ARGS ();
2274 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2275 SCM_VALIDATE_GENERIC (1, gf
);
2276 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2277 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2279 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2283 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2284 (SCM m1
, SCM m2
, SCM targs
),
2285 "Return true if method @var{m1} is more specific than @var{m2} "
2286 "given the argument types (classes) listed in @var{targs}.")
2287 #define FUNC_NAME s_scm_sys_method_more_specific_p
2291 long i
, len
, m1_specs
, m2_specs
;
2292 scm_t_array_handle handle
;
2294 SCM_VALIDATE_METHOD (1, m1
);
2295 SCM_VALIDATE_METHOD (2, m2
);
2297 len
= scm_ilength (targs
);
2298 m1_specs
= scm_ilength (SPEC_OF (m1
));
2299 m2_specs
= scm_ilength (SPEC_OF (m2
));
2300 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2301 targs
, SCM_ARG3
, FUNC_NAME
);
2303 /* Verify that all the arguments of TARGS are classes and place them
2306 v
= scm_c_make_vector (len
, SCM_EOL
);
2307 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2309 for (i
= 0, l
= targs
;
2310 i
< len
&& scm_is_pair (l
);
2311 i
++, l
= SCM_CDR (l
))
2313 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2314 v_elts
[i
] = SCM_CAR (l
);
2316 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2318 scm_array_handle_release (&handle
);
2326 /******************************************************************************
2330 ******************************************************************************/
2332 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2333 assuming that currently the reverse is true. Recalculate slots and
2334 associated getters-n-setters. */
2336 fix_cpl (SCM c
, SCM before
, SCM after
)
2338 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2339 SCM ls
= scm_c_memq (after
, cpl
);
2342 if (scm_is_false (ls
))
2343 /* if this condition occurs, fix_cpl should not be applied this way */
2346 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2347 SCM_SETCAR (ls
, before
);
2348 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2350 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2351 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2352 SCM g_n_s
= compute_getters_n_setters (slots
);
2353 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2354 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2360 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2362 SCM tmp
= scm_from_utf8_symbol (name
);
2364 *var
= scm_basic_make_class (meta
, tmp
,
2365 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2367 scm_module_define (scm_module_goops
, tmp
, *var
);
2371 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2374 create_standard_classes (void)
2377 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2378 scm_from_latin1_symbol ("specializers"),
2380 scm_from_latin1_symbol ("formals"),
2381 scm_from_latin1_symbol ("body"),
2382 scm_from_latin1_symbol ("make-procedure"),
2384 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2386 k_slot_definition
));
2387 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2388 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2391 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2394 scm_from_latin1_symbol ("effective-methods"));
2395 SCM setter_slots
= scm_list_1 (sym_setter
);
2396 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2399 /* Foreign class slot classes */
2400 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2401 scm_class_class
, scm_class_top
, SCM_EOL
);
2402 make_stdcls (&scm_class_protected
, "<protected-slot>",
2403 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2404 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2405 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2406 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2407 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2408 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2409 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2410 make_stdcls (&scm_class_self
, "<self-slot>",
2411 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2412 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2414 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2416 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2418 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2420 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2422 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2424 make_stdcls (&scm_class_scm
, "<scm-slot>",
2425 scm_class_class
, scm_class_protected
, SCM_EOL
);
2426 make_stdcls (&scm_class_int
, "<int-slot>",
2427 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2428 make_stdcls (&scm_class_float
, "<float-slot>",
2429 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2430 make_stdcls (&scm_class_double
, "<double-slot>",
2431 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2433 /* Continue initialization of class <class> */
2435 slots
= build_class_class_slots ();
2436 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2437 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2438 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2439 compute_getters_n_setters (slots
));
2441 /* scm_class_generic functions classes */
2442 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2443 scm_class_class
, scm_class_class
, SCM_EOL
);
2444 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2445 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2446 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2447 make_stdcls (&scm_class_method
, "<method>",
2448 scm_class_class
, scm_class_object
, method_slots
);
2449 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2450 scm_class_class
, scm_class_method
, amethod_slots
);
2451 make_stdcls (&scm_class_applicable
, "<applicable>",
2452 scm_class_class
, scm_class_top
, SCM_EOL
);
2453 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2454 scm_class_applicable_struct_class
,
2455 scm_list_2 (scm_class_object
, scm_class_applicable
),
2456 scm_list_1 (sym_procedure
));
2457 make_stdcls (&scm_class_generic
, "<generic>",
2458 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2459 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2460 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2461 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2462 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2463 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2464 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2465 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2466 make_stdcls (&scm_class_accessor
, "<accessor>",
2467 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2468 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2469 make_stdcls (&scm_class_extended_generic_with_setter
,
2470 "<extended-generic-with-setter>",
2471 scm_class_applicable_struct_class
,
2472 scm_list_2 (scm_class_extended_generic
,
2473 scm_class_generic_with_setter
),
2475 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2476 SCM_CLASSF_PURE_GENERIC
);
2477 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2478 scm_class_applicable_struct_class
,
2479 scm_list_2 (scm_class_accessor
,
2480 scm_class_extended_generic_with_setter
),
2482 /* <extended-generic> is misplaced. */
2483 fix_cpl (scm_class_extended_accessor
,
2484 scm_class_extended_generic
, scm_class_generic_with_setter
);
2485 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2487 /* Primitive types classes */
2488 make_stdcls (&scm_class_boolean
, "<boolean>",
2489 scm_class_class
, scm_class_top
, SCM_EOL
);
2490 make_stdcls (&scm_class_char
, "<char>",
2491 scm_class_class
, scm_class_top
, SCM_EOL
);
2492 make_stdcls (&scm_class_list
, "<list>",
2493 scm_class_class
, scm_class_top
, SCM_EOL
);
2494 make_stdcls (&scm_class_pair
, "<pair>",
2495 scm_class_class
, scm_class_list
, SCM_EOL
);
2496 make_stdcls (&scm_class_null
, "<null>",
2497 scm_class_class
, scm_class_list
, SCM_EOL
);
2498 make_stdcls (&scm_class_string
, "<string>",
2499 scm_class_class
, scm_class_top
, SCM_EOL
);
2500 make_stdcls (&scm_class_symbol
, "<symbol>",
2501 scm_class_class
, scm_class_top
, SCM_EOL
);
2502 make_stdcls (&scm_class_vector
, "<vector>",
2503 scm_class_class
, scm_class_top
, SCM_EOL
);
2504 make_stdcls (&class_foreign
, "<foreign>",
2505 scm_class_class
, scm_class_top
, SCM_EOL
);
2506 make_stdcls (&class_hashtable
, "<hashtable>",
2507 scm_class_class
, scm_class_top
, SCM_EOL
);
2508 make_stdcls (&class_fluid
, "<fluid>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&class_frame
, "<frame>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_objcode
, "<objcode>",
2515 scm_class_class
, scm_class_top
, SCM_EOL
);
2516 make_stdcls (&class_vm
, "<vm>",
2517 scm_class_class
, scm_class_top
, SCM_EOL
);
2518 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&class_bytevector
, "<bytevector>",
2521 scm_class_class
, scm_class_top
, SCM_EOL
);
2522 make_stdcls (&class_uvec
, "<uvec>",
2523 scm_class_class
, class_bytevector
, SCM_EOL
);
2524 make_stdcls (&scm_class_number
, "<number>",
2525 scm_class_class
, scm_class_top
, SCM_EOL
);
2526 make_stdcls (&scm_class_complex
, "<complex>",
2527 scm_class_class
, scm_class_number
, SCM_EOL
);
2528 make_stdcls (&scm_class_real
, "<real>",
2529 scm_class_class
, scm_class_complex
, SCM_EOL
);
2530 make_stdcls (&scm_class_integer
, "<integer>",
2531 scm_class_class
, scm_class_real
, SCM_EOL
);
2532 make_stdcls (&scm_class_fraction
, "<fraction>",
2533 scm_class_class
, scm_class_real
, SCM_EOL
);
2534 make_stdcls (&scm_class_keyword
, "<keyword>",
2535 scm_class_class
, scm_class_top
, SCM_EOL
);
2536 make_stdcls (&scm_class_unknown
, "<unknown>",
2537 scm_class_class
, scm_class_top
, SCM_EOL
);
2538 make_stdcls (&scm_class_procedure
, "<procedure>",
2539 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2540 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2541 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2542 make_stdcls (&scm_class_port
, "<port>",
2543 scm_class_class
, scm_class_top
, SCM_EOL
);
2544 make_stdcls (&scm_class_input_port
, "<input-port>",
2545 scm_class_class
, scm_class_port
, SCM_EOL
);
2546 make_stdcls (&scm_class_output_port
, "<output-port>",
2547 scm_class_class
, scm_class_port
, SCM_EOL
);
2548 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2550 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2554 /**********************************************************************
2558 **********************************************************************/
2561 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2567 sprintf (buffer
, template, type_name
);
2568 name
= scm_from_utf8_symbol (buffer
);
2571 name
= SCM_GOOPS_UNBOUND
;
2573 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2574 name
, supers
, SCM_EOL
);
2578 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2582 if (scm_is_true (type_name_sym
))
2584 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2585 scm_symbol_to_string (type_name_sym
),
2586 scm_from_locale_string (">")));
2587 name
= scm_string_to_symbol (name
);
2590 name
= SCM_GOOPS_UNBOUND
;
2592 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2593 name
, supers
, SCM_EOL
);
2597 scm_make_extended_class (char const *type_name
, int applicablep
)
2599 return make_class_from_template ("<%s>",
2601 scm_list_1 (applicablep
2602 ? scm_class_applicable
2608 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2610 return make_class_from_symbol (type_name_sym
,
2611 scm_list_1 (applicablep
2612 ? scm_class_applicable
2618 scm_i_inherit_applicable (SCM c
)
2620 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2622 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2623 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2624 /* patch scm_class_applicable into direct-supers */
2625 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2626 if (scm_is_false (top
))
2627 dsupers
= scm_append (scm_list_2 (dsupers
,
2628 scm_list_1 (scm_class_applicable
)));
2631 SCM_SETCAR (top
, scm_class_applicable
);
2632 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2634 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2635 /* patch scm_class_applicable into cpl */
2636 top
= scm_c_memq (scm_class_top
, cpl
);
2637 if (scm_is_false (top
))
2641 SCM_SETCAR (top
, scm_class_applicable
);
2642 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2644 /* add class to direct-subclasses of scm_class_applicable */
2645 SCM_SET_SLOT (scm_class_applicable
,
2646 scm_si_direct_subclasses
,
2647 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2648 scm_si_direct_subclasses
)));
2653 create_smob_classes (void)
2657 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2658 scm_smob_class
[i
] = SCM_BOOL_F
;
2660 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2662 for (i
= 0; i
< scm_numsmob
; ++i
)
2663 if (scm_is_false (scm_smob_class
[i
]))
2664 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2665 scm_smobs
[i
].apply
!= 0);
2669 scm_make_port_classes (long ptobnum
, char *type_name
)
2671 SCM c
, class = make_class_from_template ("<%s-port>",
2673 scm_list_1 (scm_class_port
),
2675 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2676 = make_class_from_template ("<%s-input-port>",
2678 scm_list_2 (class, scm_class_input_port
),
2680 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2681 = make_class_from_template ("<%s-output-port>",
2683 scm_list_2 (class, scm_class_output_port
),
2685 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2687 = make_class_from_template ("<%s-input-output-port>",
2689 scm_list_2 (class, scm_class_input_output_port
),
2691 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2692 SCM_SET_SLOT (c
, scm_si_cpl
,
2693 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2697 create_port_classes (void)
2701 for (i
= 0; i
< scm_numptob
; ++i
)
2702 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2706 make_struct_class (void *closure SCM_UNUSED
,
2707 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2709 if (scm_is_false (data
))
2710 scm_i_define_class_for_vtable (vtable
);
2711 return SCM_UNSPECIFIED
;
2715 create_struct_classes (void)
2717 /* FIXME: take the vtable_class_map while initializing goops? */
2718 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2722 /**********************************************************************
2726 **********************************************************************/
2731 if (!goops_loaded_p
)
2732 scm_c_resolve_module ("oop goops");
2736 SCM_SYMBOL (sym_o
, "o");
2737 SCM_SYMBOL (sym_x
, "x");
2739 SCM_KEYWORD (k_accessor
, "accessor");
2740 SCM_KEYWORD (k_getter
, "getter");
2743 scm_ensure_accessor (SCM name
)
2745 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2746 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2748 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2749 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2750 k_name
, name
, k_setter
, gf
));
2757 * Debugging utilities
2760 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2762 "Return @code{#t} if @var{obj} is a pure generic.")
2763 #define FUNC_NAME s_scm_pure_generic_p
2765 return scm_from_bool (SCM_PUREGENERICP (obj
));
2769 #endif /* GUILE_DEBUG */
2775 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2777 "Announce that GOOPS is loaded and perform initialization\n"
2778 "on the C level which depends on the loaded GOOPS modules.")
2779 #define FUNC_NAME s_scm_sys_goops_loaded
2782 var_compute_applicable_methods
=
2783 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2785 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2787 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2789 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2790 var_no_applicable_method
=
2791 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2793 scm_module_variable (scm_module_goops
, sym_change_class
);
2794 setup_extended_primitive_generics ();
2795 return SCM_UNSPECIFIED
;
2799 SCM scm_module_goops
;
2802 scm_init_goops_builtins (void)
2804 scm_module_goops
= scm_current_module ();
2806 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2808 #include "libguile/goops.x"
2810 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2811 hell_mutex
= scm_make_mutex ();
2813 create_basic_classes ();
2814 create_standard_classes ();
2815 create_smob_classes ();
2816 create_struct_classes ();
2817 create_port_classes ();
2820 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2821 scm_no_applicable_method
=
2822 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2823 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2826 return SCM_UNSPECIFIED
;
2832 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2833 scm_init_goops_builtins
);