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_nfields
, "nfields");
922 build_class_class_slots (void)
924 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
925 SCM_CLASS_CLASS_LAYOUT */
927 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
928 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
929 scm_list_3 (sym_self
, k_class
, scm_class_self
),
930 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
931 scm_list_1 (sym_print
),
932 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
933 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
934 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
935 scm_list_1 (sym_redefined
),
936 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
937 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
938 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
939 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
940 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
941 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
942 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
943 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
944 scm_list_1 (sym_direct_supers
),
945 scm_list_1 (sym_direct_slots
),
946 scm_list_1 (sym_direct_subclasses
),
947 scm_list_1 (sym_direct_methods
),
948 scm_list_1 (sym_cpl
),
949 scm_list_1 (sym_default_slot_definition_class
),
950 scm_list_1 (sym_slots
),
951 scm_list_1 (sym_getters_n_setters
),
952 scm_list_1 (sym_nfields
),
957 create_basic_classes (void)
959 /* SCM slots_of_class = build_class_class_slots (); */
962 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
963 SCM name
= scm_from_latin1_symbol ("<class>");
964 scm_class_class
= scm_i_make_vtable_vtable (cs
);
965 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
966 | SCM_CLASSF_METACLASS
));
968 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
969 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
970 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
971 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
972 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
973 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
974 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
975 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
976 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
977 compute_getters_n_setters (slots_of_class)); */
978 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
980 prep_hashsets (scm_class_class
);
982 scm_module_define (scm_module_goops
, name
, scm_class_class
);
985 name
= scm_from_latin1_symbol ("<top>");
986 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
989 scm_module_define (scm_module_goops
, name
, scm_class_top
);
992 name
= scm_from_latin1_symbol ("<object>");
993 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
994 scm_list_1 (scm_class_top
), SCM_EOL
);
996 scm_module_define (scm_module_goops
, name
, scm_class_object
);
998 /* <top> <object> and <class> were partially initialized. Correct them here */
999 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1001 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1002 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1005 /******************************************************************************/
1007 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1009 "Return @code{#t} if @var{obj} is an instance.")
1010 #define FUNC_NAME s_scm_instance_p
1012 return scm_from_bool (SCM_INSTANCEP (obj
));
1017 /******************************************************************************
1019 * Meta object accessors
1021 ******************************************************************************/
1022 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1024 "Return the class name of @var{obj}.")
1025 #define FUNC_NAME s_scm_class_name
1027 SCM_VALIDATE_CLASS (1, obj
);
1028 return scm_slot_ref (obj
, sym_name
);
1032 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1034 "Return the direct superclasses of the class @var{obj}.")
1035 #define FUNC_NAME s_scm_class_direct_supers
1037 SCM_VALIDATE_CLASS (1, obj
);
1038 return scm_slot_ref (obj
, sym_direct_supers
);
1042 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1044 "Return the direct slots of the class @var{obj}.")
1045 #define FUNC_NAME s_scm_class_direct_slots
1047 SCM_VALIDATE_CLASS (1, obj
);
1048 return scm_slot_ref (obj
, sym_direct_slots
);
1052 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1054 "Return the direct subclasses of the class @var{obj}.")
1055 #define FUNC_NAME s_scm_class_direct_subclasses
1057 SCM_VALIDATE_CLASS (1, obj
);
1058 return scm_slot_ref(obj
, sym_direct_subclasses
);
1062 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1064 "Return the direct methods of the class @var{obj}")
1065 #define FUNC_NAME s_scm_class_direct_methods
1067 SCM_VALIDATE_CLASS (1, obj
);
1068 return scm_slot_ref (obj
, sym_direct_methods
);
1072 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1074 "Return the class precedence list of the class @var{obj}.")
1075 #define FUNC_NAME s_scm_class_precedence_list
1077 SCM_VALIDATE_CLASS (1, obj
);
1078 return scm_slot_ref (obj
, sym_cpl
);
1082 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1084 "Return the slot list of the class @var{obj}.")
1085 #define FUNC_NAME s_scm_class_slots
1087 SCM_VALIDATE_CLASS (1, obj
);
1088 return scm_slot_ref (obj
, sym_slots
);
1092 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1094 "Return the name of the generic function @var{obj}.")
1095 #define FUNC_NAME s_scm_generic_function_name
1097 SCM_VALIDATE_GENERIC (1, obj
);
1098 return scm_procedure_property (obj
, scm_sym_name
);
1102 SCM_SYMBOL (sym_methods
, "methods");
1103 SCM_SYMBOL (sym_extended_by
, "extended-by");
1104 SCM_SYMBOL (sym_extends
, "extends");
1107 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1109 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1110 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1111 while (!scm_is_null (gfs
))
1113 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1114 gfs
= SCM_CDR (gfs
);
1116 return method_lists
;
1120 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1122 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1124 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1125 while (!scm_is_null (gfs
))
1127 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1128 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1131 gfs
= SCM_CDR (gfs
);
1134 return method_lists
;
1137 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1139 "Return the methods of the generic function @var{obj}.")
1140 #define FUNC_NAME s_scm_generic_function_methods
1143 SCM_VALIDATE_GENERIC (1, obj
);
1144 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1145 methods
= fold_downward_gf_methods (methods
, obj
);
1146 return scm_append (methods
);
1150 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1152 "Return the generic function for the method @var{obj}.")
1153 #define FUNC_NAME s_scm_method_generic_function
1155 SCM_VALIDATE_METHOD (1, obj
);
1156 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1160 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1162 "Return specializers of the method @var{obj}.")
1163 #define FUNC_NAME s_scm_method_specializers
1165 SCM_VALIDATE_METHOD (1, obj
);
1166 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1170 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1172 "Return the procedure of the method @var{obj}.")
1173 #define FUNC_NAME s_scm_method_procedure
1175 SCM_VALIDATE_METHOD (1, obj
);
1176 return scm_slot_ref (obj
, sym_procedure
);
1180 /******************************************************************************
1182 * S l o t a c c e s s
1184 ******************************************************************************/
1186 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1188 "Return the unbound value.")
1189 #define FUNC_NAME s_scm_make_unbound
1191 return SCM_GOOPS_UNBOUND
;
1195 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1197 "Return @code{#t} if @var{obj} is unbound.")
1198 #define FUNC_NAME s_scm_unbound_p
1200 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1204 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1205 (SCM value
, SCM obj
),
1206 "Return @var{value} if it is bound, and invoke the\n"
1207 "@var{slot-unbound} method of @var{obj} if it is not.")
1208 #define FUNC_NAME s_scm_assert_bound
1210 if (SCM_GOOPS_UNBOUNDP (value
))
1211 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1216 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1217 (SCM obj
, SCM index
),
1218 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1219 "the value from @var{obj}.")
1220 #define FUNC_NAME s_scm_at_assert_bound_ref
1222 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1223 if (SCM_GOOPS_UNBOUNDP (value
))
1224 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1229 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1230 (SCM obj
, SCM index
),
1231 "Return the slot value with index @var{index} from @var{obj}.")
1232 #define FUNC_NAME s_scm_sys_fast_slot_ref
1236 SCM_VALIDATE_INSTANCE (1, obj
);
1237 i
= scm_to_unsigned_integer (index
, 0,
1238 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1241 return SCM_SLOT (obj
, i
);
1245 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1246 (SCM obj
, SCM index
, SCM value
),
1247 "Set the slot with index @var{index} in @var{obj} to\n"
1249 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1253 SCM_VALIDATE_INSTANCE (1, obj
);
1254 i
= scm_to_unsigned_integer (index
, 0,
1255 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1259 SCM_SET_SLOT (obj
, i
, value
);
1261 return SCM_UNSPECIFIED
;
1269 /* In the future, this function will return the effective slot
1270 * definition associated with SLOT_NAME. Now it just returns some of
1271 * the information which will be stored in the effective slot
1276 slot_definition_using_name (SCM
class, SCM slot_name
)
1278 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1279 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1280 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1281 return SCM_CAR (slots
);
1286 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1287 #define FUNC_NAME "%get-slot-value"
1289 SCM access
= SCM_CDDR (slotdef
);
1291 * - access is an integer (the offset of this slot in the slots vector)
1292 * - otherwise (car access) is the getter function to apply
1294 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1295 * we can just assume fixnums here.
1297 if (SCM_I_INUMP (access
))
1298 /* Don't poke at the slots directly, because scm_struct_ref handles the
1299 access bits for us. */
1300 return scm_struct_ref (obj
, access
);
1302 return scm_call_1 (SCM_CAR (access
), obj
);
1307 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1309 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1310 if (scm_is_true (slotdef
))
1311 return get_slot_value (class, obj
, slotdef
);
1313 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1317 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1318 #define FUNC_NAME "%set-slot-value"
1320 SCM access
= SCM_CDDR (slotdef
);
1322 * - access is an integer (the offset of this slot in the slots vector)
1323 * - otherwise (cadr access) is the setter function to apply
1325 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1326 * we can just assume fixnums here.
1328 if (SCM_I_INUMP (access
))
1329 /* obey permissions bits via going through struct-set! */
1330 scm_struct_set_x (obj
, access
, value
);
1332 /* ((cadr l) obj value) */
1333 scm_call_2 (SCM_CADR (access
), obj
, value
);
1334 return SCM_UNSPECIFIED
;
1339 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1341 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1342 if (scm_is_true (slotdef
))
1343 return set_slot_value (class, obj
, slotdef
, value
);
1345 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1349 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1353 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1354 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1360 /* ======================================== */
1362 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1363 (SCM
class, SCM obj
, SCM slot_name
),
1365 #define FUNC_NAME s_scm_slot_ref_using_class
1369 SCM_VALIDATE_CLASS (1, class);
1370 SCM_VALIDATE_INSTANCE (2, obj
);
1371 SCM_VALIDATE_SYMBOL (3, slot_name
);
1373 res
= get_slot_value_using_name (class, obj
, slot_name
);
1374 if (SCM_GOOPS_UNBOUNDP (res
))
1375 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1381 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1382 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1384 #define FUNC_NAME s_scm_slot_set_using_class_x
1386 SCM_VALIDATE_CLASS (1, class);
1387 SCM_VALIDATE_INSTANCE (2, obj
);
1388 SCM_VALIDATE_SYMBOL (3, slot_name
);
1390 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1395 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1396 (SCM
class, SCM obj
, SCM slot_name
),
1398 #define FUNC_NAME s_scm_slot_bound_using_class_p
1400 SCM_VALIDATE_CLASS (1, class);
1401 SCM_VALIDATE_INSTANCE (2, obj
);
1402 SCM_VALIDATE_SYMBOL (3, slot_name
);
1404 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1410 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1411 (SCM
class, SCM obj
, SCM slot_name
),
1413 #define FUNC_NAME s_scm_slot_exists_using_class_p
1415 SCM_VALIDATE_CLASS (1, class);
1416 SCM_VALIDATE_INSTANCE (2, obj
);
1417 SCM_VALIDATE_SYMBOL (3, slot_name
);
1418 return test_slot_existence (class, obj
, slot_name
);
1423 /* ======================================== */
1425 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1426 (SCM obj
, SCM slot_name
),
1427 "Return the value from @var{obj}'s slot with the name\n"
1429 #define FUNC_NAME s_scm_slot_ref
1433 SCM_VALIDATE_INSTANCE (1, obj
);
1434 TEST_CHANGE_CLASS (obj
, class);
1436 res
= get_slot_value_using_name (class, obj
, slot_name
);
1437 if (SCM_GOOPS_UNBOUNDP (res
))
1438 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1443 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1444 (SCM obj
, SCM slot_name
, SCM value
),
1445 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1446 #define FUNC_NAME s_scm_slot_set_x
1450 SCM_VALIDATE_INSTANCE (1, obj
);
1451 TEST_CHANGE_CLASS(obj
, class);
1453 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1457 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1459 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1460 (SCM obj
, SCM slot_name
),
1461 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1463 #define FUNC_NAME s_scm_slot_bound_p
1467 SCM_VALIDATE_INSTANCE (1, obj
);
1468 TEST_CHANGE_CLASS(obj
, class);
1470 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1478 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1479 (SCM obj
, SCM slot_name
),
1480 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1481 #define FUNC_NAME s_scm_slot_exists_p
1485 SCM_VALIDATE_INSTANCE (1, obj
);
1486 SCM_VALIDATE_SYMBOL (2, slot_name
);
1487 TEST_CHANGE_CLASS (obj
, class);
1489 return test_slot_existence (class, obj
, slot_name
);
1494 /******************************************************************************
1496 * %allocate-instance (the low level instance allocation primitive)
1498 ******************************************************************************/
1500 static void clear_method_cache (SCM
);
1502 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1503 (SCM
class, SCM initargs
),
1504 "Create a new instance of class @var{class} and initialize it\n"
1505 "from the arguments @var{initargs}.")
1506 #define FUNC_NAME s_scm_sys_allocate_instance
1509 scm_t_signed_bits n
, i
;
1512 SCM_VALIDATE_CLASS (1, class);
1514 /* FIXME: duplicates some of scm_make_struct. */
1516 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1517 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1519 layout
= SCM_VTABLE_LAYOUT (class);
1521 /* Set all SCM-holding slots to unbound */
1522 for (i
= 0; i
< n
; i
++)
1524 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1526 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1528 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1530 SCM_STRUCT_DATA (obj
)[i
] = 0;
1533 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1534 clear_method_cache (obj
);
1540 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1541 (SCM obj
, SCM setter
),
1543 #define FUNC_NAME s_scm_sys_set_object_setter_x
1545 SCM_ASSERT (SCM_STRUCTP (obj
)
1546 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1550 SCM_SET_GENERIC_SETTER (obj
, setter
);
1551 return SCM_UNSPECIFIED
;
1555 /******************************************************************************
1557 * %modify-instance (used by change-class to modify in place)
1559 ******************************************************************************/
1561 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1564 #define FUNC_NAME s_scm_sys_modify_instance
1566 SCM_VALIDATE_INSTANCE (1, old
);
1567 SCM_VALIDATE_INSTANCE (2, new);
1569 /* Exchange the data contained in old and new. We exchange rather than
1570 * scratch the old value with new to be correct with GC.
1571 * See "Class redefinition protocol above".
1573 SCM_CRITICAL_SECTION_START
;
1575 scm_t_bits word0
, word1
;
1576 word0
= SCM_CELL_WORD_0 (old
);
1577 word1
= SCM_CELL_WORD_1 (old
);
1578 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1579 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1580 SCM_SET_CELL_WORD_0 (new, word0
);
1581 SCM_SET_CELL_WORD_1 (new, word1
);
1583 SCM_CRITICAL_SECTION_END
;
1584 return SCM_UNSPECIFIED
;
1588 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1591 #define FUNC_NAME s_scm_sys_modify_class
1593 SCM_VALIDATE_CLASS (1, old
);
1594 SCM_VALIDATE_CLASS (2, new);
1596 SCM_CRITICAL_SECTION_START
;
1598 scm_t_bits word0
, word1
;
1599 word0
= SCM_CELL_WORD_0 (old
);
1600 word1
= SCM_CELL_WORD_1 (old
);
1601 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1602 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1603 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1604 SCM_SET_CELL_WORD_0 (new, word0
);
1605 SCM_SET_CELL_WORD_1 (new, word1
);
1606 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1608 SCM_CRITICAL_SECTION_END
;
1609 return SCM_UNSPECIFIED
;
1613 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1616 #define FUNC_NAME s_scm_sys_invalidate_class
1618 SCM_VALIDATE_CLASS (1, class);
1619 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1620 return SCM_UNSPECIFIED
;
1624 /* When instances change class, they finally get a new body, but
1625 * before that, they go through purgatory in hell. Odd as it may
1626 * seem, this data structure saves us from eternal suffering in
1627 * infinite recursions.
1630 static scm_t_bits
**hell
;
1631 static long n_hell
= 1; /* one place for the evil one himself */
1632 static long hell_size
= 4;
1633 static SCM hell_mutex
;
1639 for (i
= 1; i
< n_hell
; ++i
)
1640 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1646 go_to_hell (void *o
)
1649 scm_lock_mutex (hell_mutex
);
1650 if (n_hell
>= hell_size
)
1653 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1655 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1656 scm_unlock_mutex (hell_mutex
);
1660 go_to_heaven (void *o
)
1663 scm_lock_mutex (hell_mutex
);
1664 hell
[burnin (obj
)] = hell
[--n_hell
];
1665 scm_unlock_mutex (hell_mutex
);
1669 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1672 purgatory (SCM obj
, SCM new_class
)
1674 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1677 /* This function calls the generic function change-class for all
1678 * instances which aren't currently undergoing class change.
1682 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1686 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1687 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1688 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1689 purgatory (obj
, new_class
);
1694 /******************************************************************************
1700 * GGG E N E R I C F U N C T I O N S
1702 * This implementation provides
1703 * - generic functions (with class specializers)
1706 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1708 ******************************************************************************/
1710 SCM_KEYWORD (k_name
, "name");
1712 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1715 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1717 make_dispatch_procedure (SCM gf
)
1719 static SCM var
= SCM_BOOL_F
;
1720 if (scm_is_false (var
))
1721 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1722 sym_delayed_compile
);
1723 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1727 clear_method_cache (SCM gf
)
1729 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1730 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1733 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1736 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1738 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1739 clear_method_cache (gf
);
1740 return SCM_UNSPECIFIED
;
1744 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1747 #define FUNC_NAME s_scm_generic_capability_p
1749 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1750 proc
, SCM_ARG1
, FUNC_NAME
);
1751 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1755 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1758 #define FUNC_NAME s_scm_enable_primitive_generic_x
1760 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1761 while (!scm_is_null (subrs
))
1763 SCM subr
= SCM_CAR (subrs
);
1764 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1765 SCM_SET_SUBR_GENERIC (subr
,
1766 scm_make (scm_list_3 (scm_class_generic
,
1768 SCM_SUBR_NAME (subr
))));
1769 subrs
= SCM_CDR (subrs
);
1771 return SCM_UNSPECIFIED
;
1775 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1776 (SCM subr
, SCM generic
),
1778 #define FUNC_NAME s_scm_set_primitive_generic_x
1780 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1781 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1782 SCM_SET_SUBR_GENERIC (subr
, generic
);
1783 return SCM_UNSPECIFIED
;
1787 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1790 #define FUNC_NAME s_scm_primitive_generic_generic
1792 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1794 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1795 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1796 return *SCM_SUBR_GENERIC (subr
);
1798 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1802 typedef struct t_extension
{
1803 struct t_extension
*next
;
1809 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1811 static const char extension_gc_hint
[] = "GOOPS extension";
1813 static t_extension
*extensions
= 0;
1816 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1821 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1822 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1823 gf
= *SCM_SUBR_GENERIC (extended
);
1824 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1826 SCM_SUBR_NAME (extension
));
1827 SCM_SET_SUBR_GENERIC (extension
, gext
);
1831 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1833 t_extension
**loc
= &extensions
;
1834 /* Make sure that extensions are placed before their own
1835 * extensions in the extensions list. O(N^2) algorithm, but
1836 * extensions of primitive generics are rare.
1838 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1839 loc
= &(*loc
)->next
;
1841 e
->extended
= extended
;
1842 e
->extension
= extension
;
1848 setup_extended_primitive_generics ()
1852 t_extension
*e
= extensions
;
1853 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1854 extensions
= e
->next
;
1858 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1859 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1860 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1864 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1866 if (!SCM_UNPACK (gf
))
1867 scm_error_num_args_subr (subr
);
1869 return scm_call_0 (gf
);
1873 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1875 if (!SCM_UNPACK (gf
))
1876 scm_wrong_type_arg (subr
, pos
, a1
);
1878 return scm_call_1 (gf
, a1
);
1882 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1884 if (!SCM_UNPACK (gf
))
1885 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1887 return scm_call_2 (gf
, a1
, a2
);
1891 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1893 if (!SCM_UNPACK (gf
))
1894 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1896 return scm_apply_0 (gf
, args
);
1899 /******************************************************************************
1901 * Protocol for calling a generic fumction
1902 * This protocol is roughly equivalent to (parameter are a little bit different
1903 * for efficiency reasons):
1905 * + apply-generic (gf args)
1906 * + compute-applicable-methods (gf args ...)
1907 * + sort-applicable-methods (methods args)
1908 * + apply-methods (gf methods args)
1910 * apply-methods calls make-next-method to build the "continuation" of a a
1911 * method. Applying a next-method will call apply-next-method which in
1912 * turn will call apply again to call effectively the following method.
1914 ******************************************************************************/
1917 applicablep (SCM actual
, SCM formal
)
1919 /* We already know that the cpl is well formed. */
1920 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1924 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1926 register SCM s1
, s2
;
1930 * m1 and m2 can have != length (i.e. one can be one element longer than the
1931 * other when we have a dotted parameter list). For instance, with the call
1934 * (define-method M (a . l) ....)
1935 * (define-method M (a) ....)
1937 * we consider that the second method is more specific.
1939 * BTW, targs is an array of types. We don't need it's size since
1940 * we already know that m1 and m2 are applicable (no risk to go past
1941 * the end of this array).
1944 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1945 if (scm_is_null(s1
)) return 1;
1946 if (scm_is_null(s2
)) return 0;
1947 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1948 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1950 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1951 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1953 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1956 return 0;/* should not occur! */
1959 return 0; /* should not occur! */
1962 #define BUFFSIZE 32 /* big enough for most uses */
1965 scm_i_vector2list (SCM l
, long len
)
1968 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1970 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1971 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1977 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1980 SCM
*v
, vector
= SCM_EOL
;
1981 SCM buffer
[BUFFSIZE
];
1982 SCM save
= method_list
;
1983 scm_t_array_handle handle
;
1985 /* For reasonably sized method_lists we can try to avoid all the
1986 * consing and reorder the list in place...
1987 * This idea is due to David McClain <Dave_McClain@msn.com>
1989 if (size
<= BUFFSIZE
)
1991 for (i
= 0; i
< size
; i
++)
1993 buffer
[i
] = SCM_CAR (method_list
);
1994 method_list
= SCM_CDR (method_list
);
2000 /* Too many elements in method_list to keep everything locally */
2001 vector
= scm_i_vector2list (save
, size
);
2002 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2005 /* Use a simple shell sort since it is generally faster than qsort on
2006 * small vectors (which is probably mostly the case when we have to
2007 * sort a list of applicable methods).
2009 for (incr
= size
/ 2; incr
; incr
/= 2)
2011 for (i
= incr
; i
< size
; i
++)
2013 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2015 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2019 SCM tmp
= v
[j
+ incr
];
2027 if (size
<= BUFFSIZE
)
2029 /* We did it in locally, so restore the original list (reordered) in-place */
2030 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2032 SCM_SETCAR (method_list
, *v
);
2033 method_list
= SCM_CDR (method_list
);
2038 /* If we are here, that's that we did it the hard way... */
2039 scm_array_handle_release (&handle
);
2040 return scm_vector_to_list (vector
);
2044 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2048 SCM l
, fl
, applicable
= SCM_EOL
;
2050 SCM buffer
[BUFFSIZE
];
2054 scm_t_array_handle handle
;
2056 /* Build the list of arguments types */
2057 if (len
>= BUFFSIZE
)
2059 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2060 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2063 note that we don't have to work to reset the generation
2064 count. TMP is a new vector anyway, and it is found
2071 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2072 *p
++ = scm_class_of (SCM_CAR (args
));
2074 /* Build a list of all applicable methods */
2075 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2077 fl
= SPEC_OF (SCM_CAR (l
));
2078 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2080 if (SCM_INSTANCEP (fl
)
2081 /* We have a dotted argument list */
2082 || (i
>= len
&& scm_is_null (fl
)))
2083 { /* both list exhausted */
2084 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2090 || !applicablep (types
[i
], SCM_CAR (fl
)))
2095 if (len
>= BUFFSIZE
)
2096 scm_array_handle_release (&handle
);
2102 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2103 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2109 : sort_applicable_methods (applicable
, count
, types
));
2113 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2116 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2119 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2120 #define FUNC_NAME s_sys_compute_applicable_methods
2123 SCM_VALIDATE_GENERIC (1, gf
);
2124 n
= scm_ilength (args
);
2125 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2126 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2130 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2131 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2132 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2133 scm_sys_compute_applicable_methods
));
2135 /******************************************************************************
2137 * A simple make (which will be redefined later in Scheme)
2138 * This version handles only creation of gf, methods and classes (no instances)
2140 * Since this code will disappear when Goops will be fully booted,
2141 * no precaution is taken to be efficient.
2143 ******************************************************************************/
2145 SCM_KEYWORD (k_setter
, "setter");
2146 SCM_KEYWORD (k_specializers
, "specializers");
2147 SCM_KEYWORD (k_procedure
, "procedure");
2148 SCM_KEYWORD (k_formals
, "formals");
2149 SCM_KEYWORD (k_body
, "body");
2150 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2151 SCM_KEYWORD (k_dsupers
, "dsupers");
2152 SCM_KEYWORD (k_slots
, "slots");
2153 SCM_KEYWORD (k_gf
, "generic-function");
2155 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2157 "Make a new object. @var{args} must contain the class and\n"
2158 "all necessary initialization information.")
2159 #define FUNC_NAME s_scm_make
2162 long len
= scm_ilength (args
);
2164 if (len
<= 0 || (len
& 1) == 0)
2165 SCM_WRONG_NUM_ARGS ();
2167 class = SCM_CAR(args
);
2168 args
= SCM_CDR(args
);
2170 if (scm_is_eq (class, scm_class_generic
)
2171 || scm_is_eq (class, scm_class_accessor
))
2173 z
= scm_make_struct (class, SCM_INUM0
,
2174 scm_list_4 (SCM_BOOL_F
,
2178 scm_set_procedure_property_x (z
, scm_sym_name
,
2179 scm_get_keyword (k_name
,
2182 clear_method_cache (z
);
2183 if (scm_is_eq (class, scm_class_accessor
))
2185 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2186 if (scm_is_true (setter
))
2187 scm_sys_set_object_setter_x (z
, setter
);
2192 z
= scm_sys_allocate_instance (class, args
);
2194 if (scm_is_eq (class, scm_class_method
)
2195 || scm_is_eq (class, scm_class_accessor_method
))
2197 SCM_SET_SLOT (z
, scm_si_generic_function
,
2198 scm_i_get_keyword (k_gf
,
2203 SCM_SET_SLOT (z
, scm_si_specializers
,
2204 scm_i_get_keyword (k_specializers
,
2209 SCM_SET_SLOT (z
, scm_si_procedure
,
2210 scm_i_get_keyword (k_procedure
,
2215 SCM_SET_SLOT (z
, scm_si_formals
,
2216 scm_i_get_keyword (k_formals
,
2221 SCM_SET_SLOT (z
, scm_si_body
,
2222 scm_i_get_keyword (k_body
,
2227 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2228 scm_i_get_keyword (k_make_procedure
,
2236 /* In all the others case, make a new class .... No instance here */
2237 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2238 scm_i_get_keyword (k_name
,
2241 scm_from_latin1_symbol ("???"),
2243 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2244 scm_i_get_keyword (k_dsupers
,
2249 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2250 scm_i_get_keyword (k_slots
,
2261 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2264 #define FUNC_NAME s_scm_find_method
2267 long len
= scm_ilength (l
);
2270 SCM_WRONG_NUM_ARGS ();
2272 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2273 SCM_VALIDATE_GENERIC (1, gf
);
2274 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2275 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2277 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2281 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2282 (SCM m1
, SCM m2
, SCM targs
),
2283 "Return true if method @var{m1} is more specific than @var{m2} "
2284 "given the argument types (classes) listed in @var{targs}.")
2285 #define FUNC_NAME s_scm_sys_method_more_specific_p
2289 long i
, len
, m1_specs
, m2_specs
;
2290 scm_t_array_handle handle
;
2292 SCM_VALIDATE_METHOD (1, m1
);
2293 SCM_VALIDATE_METHOD (2, m2
);
2295 len
= scm_ilength (targs
);
2296 m1_specs
= scm_ilength (SPEC_OF (m1
));
2297 m2_specs
= scm_ilength (SPEC_OF (m2
));
2298 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2299 targs
, SCM_ARG3
, FUNC_NAME
);
2301 /* Verify that all the arguments of TARGS are classes and place them
2304 v
= scm_c_make_vector (len
, SCM_EOL
);
2305 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2307 for (i
= 0, l
= targs
;
2308 i
< len
&& scm_is_pair (l
);
2309 i
++, l
= SCM_CDR (l
))
2311 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2312 v_elts
[i
] = SCM_CAR (l
);
2314 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2316 scm_array_handle_release (&handle
);
2324 /******************************************************************************
2328 ******************************************************************************/
2330 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2331 assuming that currently the reverse is true. Recalculate slots and
2332 associated getters-n-setters. */
2334 fix_cpl (SCM c
, SCM before
, SCM after
)
2336 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2337 SCM ls
= scm_c_memq (after
, cpl
);
2340 if (scm_is_false (ls
))
2341 /* if this condition occurs, fix_cpl should not be applied this way */
2344 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2345 SCM_SETCAR (ls
, before
);
2346 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2348 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2349 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2350 SCM g_n_s
= compute_getters_n_setters (slots
);
2351 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2352 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2358 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2360 SCM tmp
= scm_from_utf8_symbol (name
);
2362 *var
= scm_basic_make_class (meta
, tmp
,
2363 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2365 scm_module_define (scm_module_goops
, tmp
, *var
);
2369 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2372 create_standard_classes (void)
2375 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2376 scm_from_latin1_symbol ("specializers"),
2378 scm_from_latin1_symbol ("formals"),
2379 scm_from_latin1_symbol ("body"),
2380 scm_from_latin1_symbol ("make-procedure"),
2382 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2384 k_slot_definition
));
2385 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2386 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2389 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2392 scm_from_latin1_symbol ("effective-methods"));
2393 SCM setter_slots
= scm_list_1 (sym_setter
);
2394 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2397 /* Foreign class slot classes */
2398 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2399 scm_class_class
, scm_class_top
, SCM_EOL
);
2400 make_stdcls (&scm_class_protected
, "<protected-slot>",
2401 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2402 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2403 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2404 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2405 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2406 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2407 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2408 make_stdcls (&scm_class_self
, "<self-slot>",
2409 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2410 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2412 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2414 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2416 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2418 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2420 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2422 make_stdcls (&scm_class_scm
, "<scm-slot>",
2423 scm_class_class
, scm_class_protected
, SCM_EOL
);
2424 make_stdcls (&scm_class_int
, "<int-slot>",
2425 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2426 make_stdcls (&scm_class_float
, "<float-slot>",
2427 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2428 make_stdcls (&scm_class_double
, "<double-slot>",
2429 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2431 /* Continue initialization of class <class> */
2433 slots
= build_class_class_slots ();
2434 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2435 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2436 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2437 compute_getters_n_setters (slots
));
2439 /* scm_class_generic functions classes */
2440 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2441 scm_class_class
, scm_class_class
, SCM_EOL
);
2442 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2443 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2444 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2445 make_stdcls (&scm_class_method
, "<method>",
2446 scm_class_class
, scm_class_object
, method_slots
);
2447 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2448 scm_class_class
, scm_class_method
, amethod_slots
);
2449 make_stdcls (&scm_class_applicable
, "<applicable>",
2450 scm_class_class
, scm_class_top
, SCM_EOL
);
2451 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2452 scm_class_applicable_struct_class
,
2453 scm_list_2 (scm_class_object
, scm_class_applicable
),
2454 scm_list_1 (sym_procedure
));
2455 make_stdcls (&scm_class_generic
, "<generic>",
2456 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2457 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2458 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2459 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2460 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2461 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2462 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2463 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2464 make_stdcls (&scm_class_accessor
, "<accessor>",
2465 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2466 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2467 make_stdcls (&scm_class_extended_generic_with_setter
,
2468 "<extended-generic-with-setter>",
2469 scm_class_applicable_struct_class
,
2470 scm_list_2 (scm_class_extended_generic
,
2471 scm_class_generic_with_setter
),
2473 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2474 SCM_CLASSF_PURE_GENERIC
);
2475 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2476 scm_class_applicable_struct_class
,
2477 scm_list_2 (scm_class_accessor
,
2478 scm_class_extended_generic_with_setter
),
2480 /* <extended-generic> is misplaced. */
2481 fix_cpl (scm_class_extended_accessor
,
2482 scm_class_extended_generic
, scm_class_generic_with_setter
);
2483 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2485 /* Primitive types classes */
2486 make_stdcls (&scm_class_boolean
, "<boolean>",
2487 scm_class_class
, scm_class_top
, SCM_EOL
);
2488 make_stdcls (&scm_class_char
, "<char>",
2489 scm_class_class
, scm_class_top
, SCM_EOL
);
2490 make_stdcls (&scm_class_list
, "<list>",
2491 scm_class_class
, scm_class_top
, SCM_EOL
);
2492 make_stdcls (&scm_class_pair
, "<pair>",
2493 scm_class_class
, scm_class_list
, SCM_EOL
);
2494 make_stdcls (&scm_class_null
, "<null>",
2495 scm_class_class
, scm_class_list
, SCM_EOL
);
2496 make_stdcls (&scm_class_string
, "<string>",
2497 scm_class_class
, scm_class_top
, SCM_EOL
);
2498 make_stdcls (&scm_class_symbol
, "<symbol>",
2499 scm_class_class
, scm_class_top
, SCM_EOL
);
2500 make_stdcls (&scm_class_vector
, "<vector>",
2501 scm_class_class
, scm_class_top
, SCM_EOL
);
2502 make_stdcls (&class_foreign
, "<foreign>",
2503 scm_class_class
, scm_class_top
, SCM_EOL
);
2504 make_stdcls (&class_hashtable
, "<hashtable>",
2505 scm_class_class
, scm_class_top
, SCM_EOL
);
2506 make_stdcls (&class_fluid
, "<fluid>",
2507 scm_class_class
, scm_class_top
, SCM_EOL
);
2508 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&class_frame
, "<frame>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&class_objcode
, "<objcode>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_vm
, "<vm>",
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 (&scm_class_number
, "<number>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&scm_class_complex
, "<complex>",
2525 scm_class_class
, scm_class_number
, SCM_EOL
);
2526 make_stdcls (&scm_class_real
, "<real>",
2527 scm_class_class
, scm_class_complex
, SCM_EOL
);
2528 make_stdcls (&scm_class_integer
, "<integer>",
2529 scm_class_class
, scm_class_real
, SCM_EOL
);
2530 make_stdcls (&scm_class_fraction
, "<fraction>",
2531 scm_class_class
, scm_class_real
, SCM_EOL
);
2532 make_stdcls (&scm_class_keyword
, "<keyword>",
2533 scm_class_class
, scm_class_top
, SCM_EOL
);
2534 make_stdcls (&scm_class_unknown
, "<unknown>",
2535 scm_class_class
, scm_class_top
, SCM_EOL
);
2536 make_stdcls (&scm_class_procedure
, "<procedure>",
2537 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2538 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2539 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2540 make_stdcls (&scm_class_port
, "<port>",
2541 scm_class_class
, scm_class_top
, SCM_EOL
);
2542 make_stdcls (&scm_class_input_port
, "<input-port>",
2543 scm_class_class
, scm_class_port
, SCM_EOL
);
2544 make_stdcls (&scm_class_output_port
, "<output-port>",
2545 scm_class_class
, scm_class_port
, SCM_EOL
);
2546 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2548 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2552 /**********************************************************************
2556 **********************************************************************/
2559 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2565 sprintf (buffer
, template, type_name
);
2566 name
= scm_from_utf8_symbol (buffer
);
2569 name
= SCM_GOOPS_UNBOUND
;
2571 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2572 name
, supers
, SCM_EOL
);
2576 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2580 if (scm_is_true (type_name_sym
))
2582 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2583 scm_symbol_to_string (type_name_sym
),
2584 scm_from_locale_string (">")));
2585 name
= scm_string_to_symbol (name
);
2588 name
= SCM_GOOPS_UNBOUND
;
2590 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2591 name
, supers
, SCM_EOL
);
2595 scm_make_extended_class (char const *type_name
, int applicablep
)
2597 return make_class_from_template ("<%s>",
2599 scm_list_1 (applicablep
2600 ? scm_class_applicable
2606 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2608 return make_class_from_symbol (type_name_sym
,
2609 scm_list_1 (applicablep
2610 ? scm_class_applicable
2616 scm_i_inherit_applicable (SCM c
)
2618 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2620 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2621 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2622 /* patch scm_class_applicable into direct-supers */
2623 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2624 if (scm_is_false (top
))
2625 dsupers
= scm_append (scm_list_2 (dsupers
,
2626 scm_list_1 (scm_class_applicable
)));
2629 SCM_SETCAR (top
, scm_class_applicable
);
2630 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2632 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2633 /* patch scm_class_applicable into cpl */
2634 top
= scm_c_memq (scm_class_top
, cpl
);
2635 if (scm_is_false (top
))
2639 SCM_SETCAR (top
, scm_class_applicable
);
2640 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2642 /* add class to direct-subclasses of scm_class_applicable */
2643 SCM_SET_SLOT (scm_class_applicable
,
2644 scm_si_direct_subclasses
,
2645 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2646 scm_si_direct_subclasses
)));
2651 create_smob_classes (void)
2655 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2656 scm_smob_class
[i
] = SCM_BOOL_F
;
2658 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2660 for (i
= 0; i
< scm_numsmob
; ++i
)
2661 if (scm_is_false (scm_smob_class
[i
]))
2662 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2663 scm_smobs
[i
].apply
!= 0);
2667 scm_make_port_classes (long ptobnum
, char *type_name
)
2669 SCM c
, class = make_class_from_template ("<%s-port>",
2671 scm_list_1 (scm_class_port
),
2673 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2674 = make_class_from_template ("<%s-input-port>",
2676 scm_list_2 (class, scm_class_input_port
),
2678 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2679 = make_class_from_template ("<%s-output-port>",
2681 scm_list_2 (class, scm_class_output_port
),
2683 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2685 = make_class_from_template ("<%s-input-output-port>",
2687 scm_list_2 (class, scm_class_input_output_port
),
2689 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2690 SCM_SET_SLOT (c
, scm_si_cpl
,
2691 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2695 create_port_classes (void)
2699 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2700 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2704 make_struct_class (void *closure SCM_UNUSED
,
2705 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2707 if (scm_is_false (data
))
2708 scm_i_define_class_for_vtable (vtable
);
2709 return SCM_UNSPECIFIED
;
2713 create_struct_classes (void)
2715 /* FIXME: take the vtable_class_map while initializing goops? */
2716 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2720 /**********************************************************************
2724 **********************************************************************/
2729 if (!goops_loaded_p
)
2730 scm_c_resolve_module ("oop goops");
2734 SCM_SYMBOL (sym_o
, "o");
2735 SCM_SYMBOL (sym_x
, "x");
2737 SCM_KEYWORD (k_accessor
, "accessor");
2738 SCM_KEYWORD (k_getter
, "getter");
2741 scm_ensure_accessor (SCM name
)
2743 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2744 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2746 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2747 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2748 k_name
, name
, k_setter
, gf
));
2755 * Debugging utilities
2758 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2760 "Return @code{#t} if @var{obj} is a pure generic.")
2761 #define FUNC_NAME s_scm_pure_generic_p
2763 return scm_from_bool (SCM_PUREGENERICP (obj
));
2767 #endif /* GUILE_DEBUG */
2773 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2775 "Announce that GOOPS is loaded and perform initialization\n"
2776 "on the C level which depends on the loaded GOOPS modules.")
2777 #define FUNC_NAME s_scm_sys_goops_loaded
2780 var_compute_applicable_methods
=
2781 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2783 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2785 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2787 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2788 var_no_applicable_method
=
2789 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2791 scm_module_variable (scm_module_goops
, sym_change_class
);
2792 setup_extended_primitive_generics ();
2793 return SCM_UNSPECIFIED
;
2797 SCM scm_module_goops
;
2800 scm_init_goops_builtins (void)
2802 scm_module_goops
= scm_current_module ();
2804 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2806 #include "libguile/goops.x"
2808 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2809 hell_mutex
= scm_make_mutex ();
2811 create_basic_classes ();
2812 create_standard_classes ();
2813 create_smob_classes ();
2814 create_struct_classes ();
2815 create_port_classes ();
2818 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2819 scm_no_applicable_method
=
2820 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2821 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2824 return SCM_UNSPECIFIED
;
2830 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2831 scm_init_goops_builtins
);