1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014
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_vm_cont
;
159 static SCM class_bytevector
;
160 static SCM class_uvec
;
161 static SCM class_array
;
162 static SCM class_bitvector
;
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_vm_cont
:
268 return class_vm_cont
;
269 case scm_tc7_bytevector
:
270 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
271 return class_bytevector
;
276 case scm_tc7_bitvector
:
277 return class_bitvector
;
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_GOOPS_UNBOUND
;
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_GOOPS_UNBOUNDP (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
))
680 set_slot_value (class,
691 /* NOTE: The following macros are interdependent with code
692 * in goops.scm:compute-getters-n-setters
694 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
695 (SCM_I_INUMP (SCM_CDDR (gns)) \
696 || (scm_is_pair (SCM_CDDR (gns)) \
697 && scm_is_pair (SCM_CDDDR (gns)) \
698 && scm_is_pair (SCM_CDDDDR (gns))))
699 #define SCM_GNS_INDEX(gns) \
700 (SCM_I_INUMP (SCM_CDDR (gns)) \
701 ? SCM_I_INUM (SCM_CDDR (gns)) \
702 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
703 #define SCM_GNS_SIZE(gns) \
704 (SCM_I_INUMP (SCM_CDDR (gns)) \
706 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
708 SCM_KEYWORD (k_class
, "class");
709 SCM_KEYWORD (k_allocation
, "allocation");
710 SCM_KEYWORD (k_instance
, "instance");
712 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
715 #define FUNC_NAME s_scm_sys_prep_layout_x
717 SCM slots
, getters_n_setters
, nfields
;
718 unsigned long int n
, i
;
722 SCM_VALIDATE_INSTANCE (1, class);
723 slots
= SCM_SLOT (class, scm_si_slots
);
724 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
725 nfields
= SCM_SLOT (class, scm_si_nfields
);
726 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
727 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
728 scm_list_1 (nfields
));
729 n
= 2 * SCM_I_INUM (nfields
);
730 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
731 && SCM_SUBCLASSP (class, scm_class_class
))
732 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
733 scm_list_1 (nfields
));
735 layout
= scm_i_make_string (n
, &s
, 0);
737 while (scm_is_pair (getters_n_setters
))
739 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
742 int len
, index
, size
;
745 if (i
>= n
|| !scm_is_pair (slots
))
748 /* extract slot type */
749 len
= scm_ilength (SCM_CDAR (slots
));
750 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
751 len
, SCM_BOOL_F
, FUNC_NAME
);
752 /* determine slot GC protection and access mode */
753 if (scm_is_false (type
))
760 if (!SCM_CLASSP (type
))
761 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
762 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
764 if (SCM_SUBCLASSP (type
, scm_class_self
))
766 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
771 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
773 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
775 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
787 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
788 if (index
!= (i
>> 1))
790 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
798 slots
= SCM_CDR (slots
);
799 getters_n_setters
= SCM_CDR (getters_n_setters
);
801 if (!scm_is_null (slots
))
804 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
806 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
807 return SCM_UNSPECIFIED
;
811 static void prep_hashsets (SCM
);
813 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
814 (SCM
class, SCM dsupers
),
816 #define FUNC_NAME s_scm_sys_inherit_magic_x
818 SCM_VALIDATE_INSTANCE (1, class);
819 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
820 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
822 prep_hashsets (class);
824 return SCM_UNSPECIFIED
;
829 prep_hashsets (SCM
class)
833 for (i
= 0; i
< 8; ++i
)
834 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
837 /******************************************************************************/
840 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
842 SCM z
, cpl
, slots
, nfields
, g_n_s
;
844 /* Allocate one instance */
845 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
847 /* Initialize its slots */
848 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
849 cpl
= compute_cpl (z
);
850 slots
= build_slots_list (maplist (dslots
), cpl
);
851 nfields
= scm_from_int (scm_ilength (slots
));
852 g_n_s
= compute_getters_n_setters (slots
);
854 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
855 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
856 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
857 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
858 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
859 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
860 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
861 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
862 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
864 /* Add this class in the direct-subclasses slot of dsupers */
867 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
868 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
869 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
870 scm_si_direct_subclasses
)));
877 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
879 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
880 scm_sys_prep_layout_x (z
);
881 scm_sys_inherit_magic_x (z
, dsupers
);
885 /******************************************************************************/
887 SCM_SYMBOL (sym_layout
, "layout");
888 SCM_SYMBOL (sym_flags
, "flags");
889 SCM_SYMBOL (sym_self
, "%self");
890 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
891 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
892 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
893 SCM_SYMBOL (sym_print
, "print");
894 SCM_SYMBOL (sym_procedure
, "procedure");
895 SCM_SYMBOL (sym_setter
, "setter");
896 SCM_SYMBOL (sym_redefined
, "redefined");
897 SCM_SYMBOL (sym_h0
, "h0");
898 SCM_SYMBOL (sym_h1
, "h1");
899 SCM_SYMBOL (sym_h2
, "h2");
900 SCM_SYMBOL (sym_h3
, "h3");
901 SCM_SYMBOL (sym_h4
, "h4");
902 SCM_SYMBOL (sym_h5
, "h5");
903 SCM_SYMBOL (sym_h6
, "h6");
904 SCM_SYMBOL (sym_h7
, "h7");
905 SCM_SYMBOL (sym_name
, "name");
906 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
907 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
908 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
909 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
910 SCM_SYMBOL (sym_cpl
, "cpl");
911 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
912 SCM_SYMBOL (sym_slots
, "slots");
913 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
914 SCM_SYMBOL (sym_nfields
, "nfields");
918 build_class_class_slots (void)
920 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
921 SCM_CLASS_CLASS_LAYOUT */
923 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
924 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
925 scm_list_3 (sym_self
, k_class
, scm_class_self
),
926 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
927 scm_list_1 (sym_print
),
928 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
929 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
930 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
931 scm_list_1 (sym_redefined
),
932 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
933 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
934 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
935 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
936 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
937 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
938 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
939 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
940 scm_list_1 (sym_direct_supers
),
941 scm_list_1 (sym_direct_slots
),
942 scm_list_1 (sym_direct_subclasses
),
943 scm_list_1 (sym_direct_methods
),
944 scm_list_1 (sym_cpl
),
945 scm_list_1 (sym_default_slot_definition_class
),
946 scm_list_1 (sym_slots
),
947 scm_list_1 (sym_getters_n_setters
),
948 scm_list_1 (sym_nfields
),
953 create_basic_classes (void)
955 /* SCM slots_of_class = build_class_class_slots (); */
958 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
959 SCM name
= scm_from_latin1_symbol ("<class>");
960 scm_class_class
= scm_i_make_vtable_vtable (cs
);
961 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
962 | SCM_CLASSF_METACLASS
));
964 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
965 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
966 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
967 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
968 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
969 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
970 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
971 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
972 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
973 compute_getters_n_setters (slots_of_class)); */
974 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
976 prep_hashsets (scm_class_class
);
978 scm_module_define (scm_module_goops
, name
, scm_class_class
);
981 name
= scm_from_latin1_symbol ("<top>");
982 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
985 scm_module_define (scm_module_goops
, name
, scm_class_top
);
988 name
= scm_from_latin1_symbol ("<object>");
989 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
990 scm_list_1 (scm_class_top
), SCM_EOL
);
992 scm_module_define (scm_module_goops
, name
, scm_class_object
);
994 /* <top> <object> and <class> were partially initialized. Correct them here */
995 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
997 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
998 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1001 /******************************************************************************/
1003 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1005 "Return @code{#t} if @var{obj} is an instance.")
1006 #define FUNC_NAME s_scm_instance_p
1008 return scm_from_bool (SCM_INSTANCEP (obj
));
1013 /******************************************************************************
1015 * Meta object accessors
1017 ******************************************************************************/
1018 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1020 "Return the class name of @var{obj}.")
1021 #define FUNC_NAME s_scm_class_name
1023 SCM_VALIDATE_CLASS (1, obj
);
1024 return scm_slot_ref (obj
, sym_name
);
1028 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1030 "Return the direct superclasses of the class @var{obj}.")
1031 #define FUNC_NAME s_scm_class_direct_supers
1033 SCM_VALIDATE_CLASS (1, obj
);
1034 return scm_slot_ref (obj
, sym_direct_supers
);
1038 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1040 "Return the direct slots of the class @var{obj}.")
1041 #define FUNC_NAME s_scm_class_direct_slots
1043 SCM_VALIDATE_CLASS (1, obj
);
1044 return scm_slot_ref (obj
, sym_direct_slots
);
1048 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1050 "Return the direct subclasses of the class @var{obj}.")
1051 #define FUNC_NAME s_scm_class_direct_subclasses
1053 SCM_VALIDATE_CLASS (1, obj
);
1054 return scm_slot_ref(obj
, sym_direct_subclasses
);
1058 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1060 "Return the direct methods of the class @var{obj}")
1061 #define FUNC_NAME s_scm_class_direct_methods
1063 SCM_VALIDATE_CLASS (1, obj
);
1064 return scm_slot_ref (obj
, sym_direct_methods
);
1068 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1070 "Return the class precedence list of the class @var{obj}.")
1071 #define FUNC_NAME s_scm_class_precedence_list
1073 SCM_VALIDATE_CLASS (1, obj
);
1074 return scm_slot_ref (obj
, sym_cpl
);
1078 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1080 "Return the slot list of the class @var{obj}.")
1081 #define FUNC_NAME s_scm_class_slots
1083 SCM_VALIDATE_CLASS (1, obj
);
1084 return scm_slot_ref (obj
, sym_slots
);
1088 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1090 "Return the name of the generic function @var{obj}.")
1091 #define FUNC_NAME s_scm_generic_function_name
1093 SCM_VALIDATE_GENERIC (1, obj
);
1094 return scm_procedure_property (obj
, scm_sym_name
);
1098 SCM_SYMBOL (sym_methods
, "methods");
1099 SCM_SYMBOL (sym_extended_by
, "extended-by");
1100 SCM_SYMBOL (sym_extends
, "extends");
1103 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1105 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1106 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1107 while (!scm_is_null (gfs
))
1109 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1110 gfs
= SCM_CDR (gfs
);
1112 return method_lists
;
1116 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1118 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1120 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1121 while (!scm_is_null (gfs
))
1123 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1124 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1127 gfs
= SCM_CDR (gfs
);
1130 return method_lists
;
1133 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1135 "Return the methods of the generic function @var{obj}.")
1136 #define FUNC_NAME s_scm_generic_function_methods
1139 SCM_VALIDATE_GENERIC (1, obj
);
1140 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1141 methods
= fold_downward_gf_methods (methods
, obj
);
1142 return scm_append (methods
);
1146 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1148 "Return the generic function for the method @var{obj}.")
1149 #define FUNC_NAME s_scm_method_generic_function
1151 SCM_VALIDATE_METHOD (1, obj
);
1152 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1156 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1158 "Return specializers of the method @var{obj}.")
1159 #define FUNC_NAME s_scm_method_specializers
1161 SCM_VALIDATE_METHOD (1, obj
);
1162 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1166 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1168 "Return the procedure of the method @var{obj}.")
1169 #define FUNC_NAME s_scm_method_procedure
1171 SCM_VALIDATE_METHOD (1, obj
);
1172 return scm_slot_ref (obj
, sym_procedure
);
1176 /******************************************************************************
1178 * S l o t a c c e s s
1180 ******************************************************************************/
1182 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1184 "Return the unbound value.")
1185 #define FUNC_NAME s_scm_make_unbound
1187 return SCM_GOOPS_UNBOUND
;
1191 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1193 "Return @code{#t} if @var{obj} is unbound.")
1194 #define FUNC_NAME s_scm_unbound_p
1196 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1200 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1201 (SCM value
, SCM obj
),
1202 "Return @var{value} if it is bound, and invoke the\n"
1203 "@var{slot-unbound} method of @var{obj} if it is not.")
1204 #define FUNC_NAME s_scm_assert_bound
1206 if (SCM_GOOPS_UNBOUNDP (value
))
1207 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1212 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1213 (SCM obj
, SCM index
),
1214 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1215 "the value from @var{obj}.")
1216 #define FUNC_NAME s_scm_at_assert_bound_ref
1218 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1219 if (SCM_GOOPS_UNBOUNDP (value
))
1220 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1225 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1226 (SCM obj
, SCM index
),
1227 "Return the slot value with index @var{index} from @var{obj}.")
1228 #define FUNC_NAME s_scm_sys_fast_slot_ref
1232 SCM_VALIDATE_INSTANCE (1, obj
);
1233 i
= scm_to_unsigned_integer (index
, 0,
1234 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1237 return SCM_SLOT (obj
, i
);
1241 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1242 (SCM obj
, SCM index
, SCM value
),
1243 "Set the slot with index @var{index} in @var{obj} to\n"
1245 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1249 SCM_VALIDATE_INSTANCE (1, obj
);
1250 i
= scm_to_unsigned_integer (index
, 0,
1251 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1255 SCM_SET_SLOT (obj
, i
, value
);
1257 return SCM_UNSPECIFIED
;
1265 /* In the future, this function will return the effective slot
1266 * definition associated with SLOT_NAME. Now it just returns some of
1267 * the information which will be stored in the effective slot
1272 slot_definition_using_name (SCM
class, SCM slot_name
)
1274 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1275 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1276 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1277 return SCM_CAR (slots
);
1282 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1283 #define FUNC_NAME "%get-slot-value"
1285 SCM access
= SCM_CDDR (slotdef
);
1287 * - access is an integer (the offset of this slot in the slots vector)
1288 * - otherwise (car access) is the getter function to apply
1290 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1291 * we can just assume fixnums here.
1293 if (SCM_I_INUMP (access
))
1294 /* Don't poke at the slots directly, because scm_struct_ref handles the
1295 access bits for us. */
1296 return scm_struct_ref (obj
, access
);
1298 return scm_call_1 (SCM_CAR (access
), obj
);
1303 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1305 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1306 if (scm_is_true (slotdef
))
1307 return get_slot_value (class, obj
, slotdef
);
1309 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1313 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1314 #define FUNC_NAME "%set-slot-value"
1316 SCM access
= SCM_CDDR (slotdef
);
1318 * - access is an integer (the offset of this slot in the slots vector)
1319 * - otherwise (cadr access) is the setter function to apply
1321 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1322 * we can just assume fixnums here.
1324 if (SCM_I_INUMP (access
))
1325 /* obey permissions bits via going through struct-set! */
1326 scm_struct_set_x (obj
, access
, value
);
1328 /* ((cadr l) obj value) */
1329 scm_call_2 (SCM_CADR (access
), obj
, value
);
1330 return SCM_UNSPECIFIED
;
1335 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1337 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1338 if (scm_is_true (slotdef
))
1339 return set_slot_value (class, obj
, slotdef
, value
);
1341 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1345 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1349 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1350 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1356 /* ======================================== */
1358 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1359 (SCM
class, SCM obj
, SCM slot_name
),
1361 #define FUNC_NAME s_scm_slot_ref_using_class
1365 SCM_VALIDATE_CLASS (1, class);
1366 SCM_VALIDATE_INSTANCE (2, obj
);
1367 SCM_VALIDATE_SYMBOL (3, slot_name
);
1369 res
= get_slot_value_using_name (class, obj
, slot_name
);
1370 if (SCM_GOOPS_UNBOUNDP (res
))
1371 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1377 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1378 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1380 #define FUNC_NAME s_scm_slot_set_using_class_x
1382 SCM_VALIDATE_CLASS (1, class);
1383 SCM_VALIDATE_INSTANCE (2, obj
);
1384 SCM_VALIDATE_SYMBOL (3, slot_name
);
1386 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1391 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1392 (SCM
class, SCM obj
, SCM slot_name
),
1394 #define FUNC_NAME s_scm_slot_bound_using_class_p
1396 SCM_VALIDATE_CLASS (1, class);
1397 SCM_VALIDATE_INSTANCE (2, obj
);
1398 SCM_VALIDATE_SYMBOL (3, slot_name
);
1400 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1406 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1407 (SCM
class, SCM obj
, SCM slot_name
),
1409 #define FUNC_NAME s_scm_slot_exists_using_class_p
1411 SCM_VALIDATE_CLASS (1, class);
1412 SCM_VALIDATE_INSTANCE (2, obj
);
1413 SCM_VALIDATE_SYMBOL (3, slot_name
);
1414 return test_slot_existence (class, obj
, slot_name
);
1419 /* ======================================== */
1421 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1422 (SCM obj
, SCM slot_name
),
1423 "Return the value from @var{obj}'s slot with the name\n"
1425 #define FUNC_NAME s_scm_slot_ref
1429 SCM_VALIDATE_INSTANCE (1, obj
);
1430 TEST_CHANGE_CLASS (obj
, class);
1432 res
= get_slot_value_using_name (class, obj
, slot_name
);
1433 if (SCM_GOOPS_UNBOUNDP (res
))
1434 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1439 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1440 (SCM obj
, SCM slot_name
, SCM value
),
1441 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1442 #define FUNC_NAME s_scm_slot_set_x
1446 SCM_VALIDATE_INSTANCE (1, obj
);
1447 TEST_CHANGE_CLASS(obj
, class);
1449 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1453 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1455 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1456 (SCM obj
, SCM slot_name
),
1457 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1459 #define FUNC_NAME s_scm_slot_bound_p
1463 SCM_VALIDATE_INSTANCE (1, obj
);
1464 TEST_CHANGE_CLASS(obj
, class);
1466 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1474 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1475 (SCM obj
, SCM slot_name
),
1476 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1477 #define FUNC_NAME s_scm_slot_exists_p
1481 SCM_VALIDATE_INSTANCE (1, obj
);
1482 SCM_VALIDATE_SYMBOL (2, slot_name
);
1483 TEST_CHANGE_CLASS (obj
, class);
1485 return test_slot_existence (class, obj
, slot_name
);
1490 /******************************************************************************
1492 * %allocate-instance (the low level instance allocation primitive)
1494 ******************************************************************************/
1496 static void clear_method_cache (SCM
);
1498 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1499 (SCM
class, SCM initargs
),
1500 "Create a new instance of class @var{class} and initialize it\n"
1501 "from the arguments @var{initargs}.")
1502 #define FUNC_NAME s_scm_sys_allocate_instance
1505 scm_t_signed_bits n
, i
;
1508 SCM_VALIDATE_CLASS (1, class);
1510 /* FIXME: duplicates some of scm_make_struct. */
1512 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1513 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1515 layout
= SCM_VTABLE_LAYOUT (class);
1517 /* Set all SCM-holding slots to unbound */
1518 for (i
= 0; i
< n
; i
++)
1520 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1522 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1524 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1526 SCM_STRUCT_DATA (obj
)[i
] = 0;
1529 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1530 clear_method_cache (obj
);
1536 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1537 (SCM obj
, SCM setter
),
1539 #define FUNC_NAME s_scm_sys_set_object_setter_x
1541 SCM_ASSERT (SCM_STRUCTP (obj
)
1542 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1546 SCM_SET_GENERIC_SETTER (obj
, setter
);
1547 return SCM_UNSPECIFIED
;
1551 /******************************************************************************
1553 * %modify-instance (used by change-class to modify in place)
1555 ******************************************************************************/
1557 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1560 #define FUNC_NAME s_scm_sys_modify_instance
1562 SCM_VALIDATE_INSTANCE (1, old
);
1563 SCM_VALIDATE_INSTANCE (2, new);
1565 /* Exchange the data contained in old and new. We exchange rather than
1566 * scratch the old value with new to be correct with GC.
1567 * See "Class redefinition protocol above".
1569 SCM_CRITICAL_SECTION_START
;
1571 scm_t_bits word0
, word1
;
1572 word0
= SCM_CELL_WORD_0 (old
);
1573 word1
= SCM_CELL_WORD_1 (old
);
1574 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1575 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1576 SCM_SET_CELL_WORD_0 (new, word0
);
1577 SCM_SET_CELL_WORD_1 (new, word1
);
1579 SCM_CRITICAL_SECTION_END
;
1580 return SCM_UNSPECIFIED
;
1584 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1587 #define FUNC_NAME s_scm_sys_modify_class
1589 SCM_VALIDATE_CLASS (1, old
);
1590 SCM_VALIDATE_CLASS (2, new);
1592 SCM_CRITICAL_SECTION_START
;
1594 scm_t_bits word0
, word1
;
1595 word0
= SCM_CELL_WORD_0 (old
);
1596 word1
= SCM_CELL_WORD_1 (old
);
1597 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1598 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1599 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1600 SCM_SET_CELL_WORD_0 (new, word0
);
1601 SCM_SET_CELL_WORD_1 (new, word1
);
1602 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1604 SCM_CRITICAL_SECTION_END
;
1605 return SCM_UNSPECIFIED
;
1609 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1612 #define FUNC_NAME s_scm_sys_invalidate_class
1614 SCM_VALIDATE_CLASS (1, class);
1615 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1616 return SCM_UNSPECIFIED
;
1620 /* When instances change class, they finally get a new body, but
1621 * before that, they go through purgatory in hell. Odd as it may
1622 * seem, this data structure saves us from eternal suffering in
1623 * infinite recursions.
1626 static scm_t_bits
**hell
;
1627 static long n_hell
= 1; /* one place for the evil one himself */
1628 static long hell_size
= 4;
1629 static SCM hell_mutex
;
1635 for (i
= 1; i
< n_hell
; ++i
)
1636 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1642 go_to_hell (void *o
)
1645 scm_lock_mutex (hell_mutex
);
1646 if (n_hell
>= hell_size
)
1649 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1651 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1652 scm_unlock_mutex (hell_mutex
);
1656 go_to_heaven (void *o
)
1659 scm_lock_mutex (hell_mutex
);
1660 hell
[burnin (obj
)] = hell
[--n_hell
];
1661 scm_unlock_mutex (hell_mutex
);
1665 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1668 purgatory (SCM obj
, SCM new_class
)
1670 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1673 /* This function calls the generic function change-class for all
1674 * instances which aren't currently undergoing class change.
1678 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1682 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1683 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1684 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1685 purgatory (obj
, new_class
);
1690 /******************************************************************************
1696 * GGG E N E R I C F U N C T I O N S
1698 * This implementation provides
1699 * - generic functions (with class specializers)
1702 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1704 ******************************************************************************/
1706 SCM_KEYWORD (k_name
, "name");
1708 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1710 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1712 static SCM delayed_compile_var
;
1715 init_delayed_compile_var (void)
1718 = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
1722 make_dispatch_procedure (SCM gf
)
1724 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
1725 scm_i_pthread_once (&once
, init_delayed_compile_var
);
1727 return scm_call_1 (scm_variable_ref (delayed_compile_var
), gf
);
1731 clear_method_cache (SCM gf
)
1733 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1734 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1737 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1740 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1742 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1743 clear_method_cache (gf
);
1744 return SCM_UNSPECIFIED
;
1748 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1751 #define FUNC_NAME s_scm_generic_capability_p
1753 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1754 proc
, SCM_ARG1
, FUNC_NAME
);
1755 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1759 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1762 #define FUNC_NAME s_scm_enable_primitive_generic_x
1764 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1765 while (!scm_is_null (subrs
))
1767 SCM subr
= SCM_CAR (subrs
);
1768 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1769 SCM_SET_SUBR_GENERIC (subr
,
1770 scm_make (scm_list_3 (scm_class_generic
,
1772 SCM_SUBR_NAME (subr
))));
1773 subrs
= SCM_CDR (subrs
);
1775 return SCM_UNSPECIFIED
;
1779 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1780 (SCM subr
, SCM generic
),
1782 #define FUNC_NAME s_scm_set_primitive_generic_x
1784 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1785 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1786 SCM_SET_SUBR_GENERIC (subr
, generic
);
1787 return SCM_UNSPECIFIED
;
1791 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1794 #define FUNC_NAME s_scm_primitive_generic_generic
1796 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1798 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1799 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1800 return *SCM_SUBR_GENERIC (subr
);
1802 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1806 typedef struct t_extension
{
1807 struct t_extension
*next
;
1813 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1815 static const char extension_gc_hint
[] = "GOOPS extension";
1817 static t_extension
*extensions
= 0;
1820 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1825 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1826 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1827 gf
= *SCM_SUBR_GENERIC (extended
);
1828 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1830 SCM_SUBR_NAME (extension
));
1831 SCM_SET_SUBR_GENERIC (extension
, gext
);
1835 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1837 t_extension
**loc
= &extensions
;
1838 /* Make sure that extensions are placed before their own
1839 * extensions in the extensions list. O(N^2) algorithm, but
1840 * extensions of primitive generics are rare.
1842 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1843 loc
= &(*loc
)->next
;
1845 e
->extended
= extended
;
1846 e
->extension
= extension
;
1852 setup_extended_primitive_generics ()
1856 t_extension
*e
= extensions
;
1857 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1858 extensions
= e
->next
;
1862 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1863 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1864 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1868 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1870 if (!SCM_UNPACK (gf
))
1871 scm_error_num_args_subr (subr
);
1873 return scm_call_0 (gf
);
1877 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1879 if (!SCM_UNPACK (gf
))
1880 scm_wrong_type_arg (subr
, pos
, a1
);
1882 return scm_call_1 (gf
, a1
);
1886 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1888 if (!SCM_UNPACK (gf
))
1889 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1891 return scm_call_2 (gf
, a1
, a2
);
1895 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1897 if (!SCM_UNPACK (gf
))
1898 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1900 return scm_apply_0 (gf
, args
);
1903 /******************************************************************************
1905 * Protocol for calling a generic fumction
1906 * This protocol is roughly equivalent to (parameter are a little bit different
1907 * for efficiency reasons):
1909 * + apply-generic (gf args)
1910 * + compute-applicable-methods (gf args ...)
1911 * + sort-applicable-methods (methods args)
1912 * + apply-methods (gf methods args)
1914 * apply-methods calls make-next-method to build the "continuation" of a a
1915 * method. Applying a next-method will call apply-next-method which in
1916 * turn will call apply again to call effectively the following method.
1918 ******************************************************************************/
1921 applicablep (SCM actual
, SCM formal
)
1923 /* We already know that the cpl is well formed. */
1924 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1928 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1930 register SCM s1
, s2
;
1934 * m1 and m2 can have != length (i.e. one can be one element longer than the
1935 * other when we have a dotted parameter list). For instance, with the call
1938 * (define-method M (a . l) ....)
1939 * (define-method M (a) ....)
1941 * we consider that the second method is more specific.
1943 * BTW, targs is an array of types. We don't need it's size since
1944 * we already know that m1 and m2 are applicable (no risk to go past
1945 * the end of this array).
1948 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1949 if (scm_is_null(s1
)) return 1;
1950 if (scm_is_null(s2
)) return 0;
1951 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1952 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1954 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1955 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1957 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1960 return 0;/* should not occur! */
1963 return 0; /* should not occur! */
1966 #define BUFFSIZE 32 /* big enough for most uses */
1969 scm_i_vector2list (SCM l
, long len
)
1972 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1974 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1975 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1981 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1984 SCM
*v
, vector
= SCM_EOL
;
1985 SCM buffer
[BUFFSIZE
];
1986 SCM save
= method_list
;
1987 scm_t_array_handle handle
;
1989 /* For reasonably sized method_lists we can try to avoid all the
1990 * consing and reorder the list in place...
1991 * This idea is due to David McClain <Dave_McClain@msn.com>
1993 if (size
<= BUFFSIZE
)
1995 for (i
= 0; i
< size
; i
++)
1997 buffer
[i
] = SCM_CAR (method_list
);
1998 method_list
= SCM_CDR (method_list
);
2004 /* Too many elements in method_list to keep everything locally */
2005 vector
= scm_i_vector2list (save
, size
);
2006 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2009 /* Use a simple shell sort since it is generally faster than qsort on
2010 * small vectors (which is probably mostly the case when we have to
2011 * sort a list of applicable methods).
2013 for (incr
= size
/ 2; incr
; incr
/= 2)
2015 for (i
= incr
; i
< size
; i
++)
2017 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2019 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2023 SCM tmp
= v
[j
+ incr
];
2031 if (size
<= BUFFSIZE
)
2033 /* We did it in locally, so restore the original list (reordered) in-place */
2034 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2036 SCM_SETCAR (method_list
, *v
);
2037 method_list
= SCM_CDR (method_list
);
2042 /* If we are here, that's that we did it the hard way... */
2043 scm_array_handle_release (&handle
);
2044 return scm_vector_to_list (vector
);
2048 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2052 SCM l
, fl
, applicable
= SCM_EOL
;
2054 SCM buffer
[BUFFSIZE
];
2058 scm_t_array_handle handle
;
2060 /* Build the list of arguments types */
2061 if (len
>= BUFFSIZE
)
2063 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2064 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2067 note that we don't have to work to reset the generation
2068 count. TMP is a new vector anyway, and it is found
2075 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2076 *p
++ = scm_class_of (SCM_CAR (args
));
2078 /* Build a list of all applicable methods */
2079 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2081 fl
= SPEC_OF (SCM_CAR (l
));
2082 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2084 if (SCM_INSTANCEP (fl
)
2085 /* We have a dotted argument list */
2086 || (i
>= len
&& scm_is_null (fl
)))
2087 { /* both list exhausted */
2088 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2094 || !applicablep (types
[i
], SCM_CAR (fl
)))
2099 if (len
>= BUFFSIZE
)
2100 scm_array_handle_release (&handle
);
2106 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2107 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2113 : sort_applicable_methods (applicable
, count
, types
));
2117 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2120 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2123 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2124 #define FUNC_NAME s_sys_compute_applicable_methods
2127 SCM_VALIDATE_GENERIC (1, gf
);
2128 n
= scm_ilength (args
);
2129 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2130 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2134 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2135 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2136 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2137 scm_sys_compute_applicable_methods
));
2139 /******************************************************************************
2141 * A simple make (which will be redefined later in Scheme)
2142 * This version handles only creation of gf, methods and classes (no instances)
2144 * Since this code will disappear when Goops will be fully booted,
2145 * no precaution is taken to be efficient.
2147 ******************************************************************************/
2149 SCM_KEYWORD (k_setter
, "setter");
2150 SCM_KEYWORD (k_specializers
, "specializers");
2151 SCM_KEYWORD (k_procedure
, "procedure");
2152 SCM_KEYWORD (k_formals
, "formals");
2153 SCM_KEYWORD (k_body
, "body");
2154 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2155 SCM_KEYWORD (k_dsupers
, "dsupers");
2156 SCM_KEYWORD (k_slots
, "slots");
2157 SCM_KEYWORD (k_gf
, "generic-function");
2159 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2161 "Make a new object. @var{args} must contain the class and\n"
2162 "all necessary initialization information.")
2163 #define FUNC_NAME s_scm_make
2166 long len
= scm_ilength (args
);
2168 if (len
<= 0 || (len
& 1) == 0)
2169 SCM_WRONG_NUM_ARGS ();
2171 class = SCM_CAR(args
);
2172 args
= SCM_CDR(args
);
2174 if (scm_is_eq (class, scm_class_generic
)
2175 || scm_is_eq (class, scm_class_accessor
))
2177 z
= scm_make_struct (class, SCM_INUM0
,
2178 scm_list_4 (SCM_BOOL_F
,
2182 scm_set_procedure_property_x (z
, scm_sym_name
,
2183 scm_get_keyword (k_name
,
2186 clear_method_cache (z
);
2187 if (scm_is_eq (class, scm_class_accessor
))
2189 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2190 if (scm_is_true (setter
))
2191 scm_sys_set_object_setter_x (z
, setter
);
2196 z
= scm_sys_allocate_instance (class, args
);
2198 if (scm_is_eq (class, scm_class_method
)
2199 || scm_is_eq (class, scm_class_accessor_method
))
2201 SCM_SET_SLOT (z
, scm_si_generic_function
,
2202 scm_i_get_keyword (k_gf
,
2207 SCM_SET_SLOT (z
, scm_si_specializers
,
2208 scm_i_get_keyword (k_specializers
,
2213 SCM_SET_SLOT (z
, scm_si_procedure
,
2214 scm_i_get_keyword (k_procedure
,
2219 SCM_SET_SLOT (z
, scm_si_formals
,
2220 scm_i_get_keyword (k_formals
,
2225 SCM_SET_SLOT (z
, scm_si_body
,
2226 scm_i_get_keyword (k_body
,
2231 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2232 scm_i_get_keyword (k_make_procedure
,
2240 /* In all the others case, make a new class .... No instance here */
2241 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2242 scm_i_get_keyword (k_name
,
2245 scm_from_latin1_symbol ("???"),
2247 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2248 scm_i_get_keyword (k_dsupers
,
2253 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2254 scm_i_get_keyword (k_slots
,
2265 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2268 #define FUNC_NAME s_scm_find_method
2271 long len
= scm_ilength (l
);
2274 SCM_WRONG_NUM_ARGS ();
2276 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2277 SCM_VALIDATE_GENERIC (1, gf
);
2278 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2279 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2281 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2285 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2286 (SCM m1
, SCM m2
, SCM targs
),
2287 "Return true if method @var{m1} is more specific than @var{m2} "
2288 "given the argument types (classes) listed in @var{targs}.")
2289 #define FUNC_NAME s_scm_sys_method_more_specific_p
2293 long i
, len
, m1_specs
, m2_specs
;
2294 scm_t_array_handle handle
;
2296 SCM_VALIDATE_METHOD (1, m1
);
2297 SCM_VALIDATE_METHOD (2, m2
);
2299 len
= scm_ilength (targs
);
2300 m1_specs
= scm_ilength (SPEC_OF (m1
));
2301 m2_specs
= scm_ilength (SPEC_OF (m2
));
2302 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2303 targs
, SCM_ARG3
, FUNC_NAME
);
2305 /* Verify that all the arguments of TARGS are classes and place them
2308 v
= scm_c_make_vector (len
, SCM_EOL
);
2309 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2311 for (i
= 0, l
= targs
;
2312 i
< len
&& scm_is_pair (l
);
2313 i
++, l
= SCM_CDR (l
))
2315 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2316 v_elts
[i
] = SCM_CAR (l
);
2318 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2320 scm_array_handle_release (&handle
);
2328 /******************************************************************************
2332 ******************************************************************************/
2334 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2335 assuming that currently the reverse is true. Recalculate slots and
2336 associated getters-n-setters. */
2338 fix_cpl (SCM c
, SCM before
, SCM after
)
2340 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2341 SCM ls
= scm_c_memq (after
, cpl
);
2344 if (scm_is_false (ls
))
2345 /* if this condition occurs, fix_cpl should not be applied this way */
2348 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2349 SCM_SETCAR (ls
, before
);
2350 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2352 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2353 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2354 SCM g_n_s
= compute_getters_n_setters (slots
);
2355 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2356 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2362 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2364 SCM tmp
= scm_from_utf8_symbol (name
);
2366 *var
= scm_basic_make_class (meta
, tmp
,
2367 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2369 scm_module_define (scm_module_goops
, tmp
, *var
);
2373 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2376 create_standard_classes (void)
2379 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2380 scm_from_latin1_symbol ("specializers"),
2382 scm_from_latin1_symbol ("formals"),
2383 scm_from_latin1_symbol ("body"),
2384 scm_from_latin1_symbol ("make-procedure"),
2386 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2388 k_slot_definition
));
2389 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2390 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2393 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2396 scm_from_latin1_symbol ("effective-methods"));
2397 SCM setter_slots
= scm_list_1 (sym_setter
);
2398 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2401 /* Foreign class slot classes */
2402 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2403 scm_class_class
, scm_class_top
, SCM_EOL
);
2404 make_stdcls (&scm_class_protected
, "<protected-slot>",
2405 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2406 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2407 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2408 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2409 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2410 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2411 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2412 make_stdcls (&scm_class_self
, "<self-slot>",
2413 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2414 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2416 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2418 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2420 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2422 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2424 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2426 make_stdcls (&scm_class_scm
, "<scm-slot>",
2427 scm_class_class
, scm_class_protected
, SCM_EOL
);
2428 make_stdcls (&scm_class_int
, "<int-slot>",
2429 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2430 make_stdcls (&scm_class_float
, "<float-slot>",
2431 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2432 make_stdcls (&scm_class_double
, "<double-slot>",
2433 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2435 /* Continue initialization of class <class> */
2437 slots
= build_class_class_slots ();
2438 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2439 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2440 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2441 compute_getters_n_setters (slots
));
2443 /* scm_class_generic functions classes */
2444 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2445 scm_class_class
, scm_class_class
, SCM_EOL
);
2446 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2447 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2448 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2449 make_stdcls (&scm_class_method
, "<method>",
2450 scm_class_class
, scm_class_object
, method_slots
);
2451 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2452 scm_class_class
, scm_class_method
, amethod_slots
);
2453 make_stdcls (&scm_class_applicable
, "<applicable>",
2454 scm_class_class
, scm_class_top
, SCM_EOL
);
2455 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2456 scm_class_applicable_struct_class
,
2457 scm_list_2 (scm_class_object
, scm_class_applicable
),
2458 scm_list_1 (sym_procedure
));
2459 make_stdcls (&scm_class_generic
, "<generic>",
2460 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2461 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2462 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2463 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2464 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2465 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2466 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2467 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2468 make_stdcls (&scm_class_accessor
, "<accessor>",
2469 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2470 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2471 make_stdcls (&scm_class_extended_generic_with_setter
,
2472 "<extended-generic-with-setter>",
2473 scm_class_applicable_struct_class
,
2474 scm_list_2 (scm_class_extended_generic
,
2475 scm_class_generic_with_setter
),
2477 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2478 SCM_CLASSF_PURE_GENERIC
);
2479 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2480 scm_class_applicable_struct_class
,
2481 scm_list_2 (scm_class_accessor
,
2482 scm_class_extended_generic_with_setter
),
2484 /* <extended-generic> is misplaced. */
2485 fix_cpl (scm_class_extended_accessor
,
2486 scm_class_extended_generic
, scm_class_generic_with_setter
);
2487 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2489 /* Primitive types classes */
2490 make_stdcls (&scm_class_boolean
, "<boolean>",
2491 scm_class_class
, scm_class_top
, SCM_EOL
);
2492 make_stdcls (&scm_class_char
, "<char>",
2493 scm_class_class
, scm_class_top
, SCM_EOL
);
2494 make_stdcls (&scm_class_list
, "<list>",
2495 scm_class_class
, scm_class_top
, SCM_EOL
);
2496 make_stdcls (&scm_class_pair
, "<pair>",
2497 scm_class_class
, scm_class_list
, SCM_EOL
);
2498 make_stdcls (&scm_class_null
, "<null>",
2499 scm_class_class
, scm_class_list
, SCM_EOL
);
2500 make_stdcls (&scm_class_string
, "<string>",
2501 scm_class_class
, scm_class_top
, SCM_EOL
);
2502 make_stdcls (&scm_class_symbol
, "<symbol>",
2503 scm_class_class
, scm_class_top
, SCM_EOL
);
2504 make_stdcls (&scm_class_vector
, "<vector>",
2505 scm_class_class
, scm_class_top
, SCM_EOL
);
2506 make_stdcls (&class_foreign
, "<foreign>",
2507 scm_class_class
, scm_class_top
, SCM_EOL
);
2508 make_stdcls (&class_hashtable
, "<hashtable>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&class_fluid
, "<fluid>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_frame
, "<frame>",
2515 scm_class_class
, scm_class_top
, SCM_EOL
);
2516 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2517 scm_class_class
, scm_class_top
, SCM_EOL
);
2518 make_stdcls (&class_bytevector
, "<bytevector>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&class_uvec
, "<uvec>",
2521 scm_class_class
, class_bytevector
, SCM_EOL
);
2522 make_stdcls (&class_array
, "<array>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&class_bitvector
, "<bitvector>",
2525 scm_class_class
, scm_class_top
, SCM_EOL
);
2526 make_stdcls (&scm_class_number
, "<number>",
2527 scm_class_class
, scm_class_top
, SCM_EOL
);
2528 make_stdcls (&scm_class_complex
, "<complex>",
2529 scm_class_class
, scm_class_number
, SCM_EOL
);
2530 make_stdcls (&scm_class_real
, "<real>",
2531 scm_class_class
, scm_class_complex
, SCM_EOL
);
2532 make_stdcls (&scm_class_integer
, "<integer>",
2533 scm_class_class
, scm_class_real
, SCM_EOL
);
2534 make_stdcls (&scm_class_fraction
, "<fraction>",
2535 scm_class_class
, scm_class_real
, SCM_EOL
);
2536 make_stdcls (&scm_class_keyword
, "<keyword>",
2537 scm_class_class
, scm_class_top
, SCM_EOL
);
2538 make_stdcls (&scm_class_unknown
, "<unknown>",
2539 scm_class_class
, scm_class_top
, SCM_EOL
);
2540 make_stdcls (&scm_class_procedure
, "<procedure>",
2541 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2542 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2543 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2544 make_stdcls (&scm_class_port
, "<port>",
2545 scm_class_class
, scm_class_top
, SCM_EOL
);
2546 make_stdcls (&scm_class_input_port
, "<input-port>",
2547 scm_class_class
, scm_class_port
, SCM_EOL
);
2548 make_stdcls (&scm_class_output_port
, "<output-port>",
2549 scm_class_class
, scm_class_port
, SCM_EOL
);
2550 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2552 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2556 /**********************************************************************
2560 **********************************************************************/
2563 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2569 sprintf (buffer
, template, type_name
);
2570 name
= scm_from_utf8_symbol (buffer
);
2573 name
= SCM_GOOPS_UNBOUND
;
2575 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2576 name
, supers
, SCM_EOL
);
2580 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2584 if (scm_is_true (type_name_sym
))
2586 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2587 scm_symbol_to_string (type_name_sym
),
2588 scm_from_locale_string (">")));
2589 name
= scm_string_to_symbol (name
);
2592 name
= SCM_GOOPS_UNBOUND
;
2594 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2595 name
, supers
, SCM_EOL
);
2599 scm_make_extended_class (char const *type_name
, int applicablep
)
2601 return make_class_from_template ("<%s>",
2603 scm_list_1 (applicablep
2604 ? scm_class_applicable
2610 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2612 return make_class_from_symbol (type_name_sym
,
2613 scm_list_1 (applicablep
2614 ? scm_class_applicable
2620 scm_i_inherit_applicable (SCM c
)
2622 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2624 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2625 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2626 /* patch scm_class_applicable into direct-supers */
2627 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2628 if (scm_is_false (top
))
2629 dsupers
= scm_append (scm_list_2 (dsupers
,
2630 scm_list_1 (scm_class_applicable
)));
2633 SCM_SETCAR (top
, scm_class_applicable
);
2634 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2636 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2637 /* patch scm_class_applicable into cpl */
2638 top
= scm_c_memq (scm_class_top
, cpl
);
2639 if (scm_is_false (top
))
2643 SCM_SETCAR (top
, scm_class_applicable
);
2644 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2646 /* add class to direct-subclasses of scm_class_applicable */
2647 SCM_SET_SLOT (scm_class_applicable
,
2648 scm_si_direct_subclasses
,
2649 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2650 scm_si_direct_subclasses
)));
2655 create_smob_classes (void)
2659 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2660 scm_smob_class
[i
] = SCM_BOOL_F
;
2662 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2664 for (i
= 0; i
< scm_numsmob
; ++i
)
2665 if (scm_is_false (scm_smob_class
[i
]))
2666 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2667 scm_smobs
[i
].apply
!= 0);
2671 scm_make_port_classes (long ptobnum
, char *type_name
)
2673 SCM c
, class = make_class_from_template ("<%s-port>",
2675 scm_list_1 (scm_class_port
),
2677 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2678 = make_class_from_template ("<%s-input-port>",
2680 scm_list_2 (class, scm_class_input_port
),
2682 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2683 = make_class_from_template ("<%s-output-port>",
2685 scm_list_2 (class, scm_class_output_port
),
2687 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2689 = make_class_from_template ("<%s-input-output-port>",
2691 scm_list_2 (class, scm_class_input_output_port
),
2693 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2694 SCM_SET_SLOT (c
, scm_si_cpl
,
2695 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2699 create_port_classes (void)
2703 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2704 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2708 make_struct_class (void *closure SCM_UNUSED
,
2709 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2711 if (scm_is_false (data
))
2712 scm_i_define_class_for_vtable (vtable
);
2713 return SCM_UNSPECIFIED
;
2717 create_struct_classes (void)
2719 /* FIXME: take the vtable_class_map while initializing goops? */
2720 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2724 /**********************************************************************
2728 **********************************************************************/
2733 if (!goops_loaded_p
)
2734 scm_c_resolve_module ("oop goops");
2738 SCM_SYMBOL (sym_o
, "o");
2739 SCM_SYMBOL (sym_x
, "x");
2741 SCM_KEYWORD (k_accessor
, "accessor");
2742 SCM_KEYWORD (k_getter
, "getter");
2745 scm_ensure_accessor (SCM name
)
2749 var
= scm_module_variable (scm_current_module (), name
);
2750 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2751 gf
= SCM_VARIABLE_REF (var
);
2755 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2757 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2758 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2759 k_name
, name
, k_setter
, gf
));
2767 * Debugging utilities
2770 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2772 "Return @code{#t} if @var{obj} is a pure generic.")
2773 #define FUNC_NAME s_scm_pure_generic_p
2775 return scm_from_bool (SCM_PUREGENERICP (obj
));
2779 #endif /* GUILE_DEBUG */
2785 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2787 "Announce that GOOPS is loaded and perform initialization\n"
2788 "on the C level which depends on the loaded GOOPS modules.")
2789 #define FUNC_NAME s_scm_sys_goops_loaded
2792 var_compute_applicable_methods
=
2793 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2795 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2797 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2799 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2800 var_no_applicable_method
=
2801 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2803 scm_module_variable (scm_module_goops
, sym_change_class
);
2804 setup_extended_primitive_generics ();
2805 return SCM_UNSPECIFIED
;
2809 SCM scm_module_goops
;
2812 scm_init_goops_builtins (void)
2814 scm_module_goops
= scm_current_module ();
2816 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2818 #include "libguile/goops.x"
2820 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2821 hell_mutex
= scm_make_mutex ();
2823 create_basic_classes ();
2824 create_standard_classes ();
2825 create_smob_classes ();
2826 create_struct_classes ();
2827 create_port_classes ();
2830 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2831 scm_no_applicable_method
=
2832 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2833 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2836 return SCM_UNSPECIFIED
;
2842 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2843 scm_init_goops_builtins
);