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_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");
1714 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1716 static SCM delayed_compile_var
;
1719 init_delayed_compile_var (void)
1722 = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
1726 make_dispatch_procedure (SCM gf
)
1728 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
1729 scm_i_pthread_once (&once
, init_delayed_compile_var
);
1731 return scm_call_1 (scm_variable_ref (delayed_compile_var
), gf
);
1735 clear_method_cache (SCM gf
)
1737 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1738 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1741 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1744 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1746 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1747 clear_method_cache (gf
);
1748 return SCM_UNSPECIFIED
;
1752 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1755 #define FUNC_NAME s_scm_generic_capability_p
1757 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1758 proc
, SCM_ARG1
, FUNC_NAME
);
1759 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1763 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1766 #define FUNC_NAME s_scm_enable_primitive_generic_x
1768 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1769 while (!scm_is_null (subrs
))
1771 SCM subr
= SCM_CAR (subrs
);
1772 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1773 SCM_SET_SUBR_GENERIC (subr
,
1774 scm_make (scm_list_3 (scm_class_generic
,
1776 SCM_SUBR_NAME (subr
))));
1777 subrs
= SCM_CDR (subrs
);
1779 return SCM_UNSPECIFIED
;
1783 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1784 (SCM subr
, SCM generic
),
1786 #define FUNC_NAME s_scm_set_primitive_generic_x
1788 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1789 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1790 SCM_SET_SUBR_GENERIC (subr
, generic
);
1791 return SCM_UNSPECIFIED
;
1795 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1798 #define FUNC_NAME s_scm_primitive_generic_generic
1800 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1802 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1803 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1804 return *SCM_SUBR_GENERIC (subr
);
1806 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1810 typedef struct t_extension
{
1811 struct t_extension
*next
;
1817 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1819 static const char extension_gc_hint
[] = "GOOPS extension";
1821 static t_extension
*extensions
= 0;
1824 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1829 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1830 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1831 gf
= *SCM_SUBR_GENERIC (extended
);
1832 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1834 SCM_SUBR_NAME (extension
));
1835 SCM_SET_SUBR_GENERIC (extension
, gext
);
1839 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1841 t_extension
**loc
= &extensions
;
1842 /* Make sure that extensions are placed before their own
1843 * extensions in the extensions list. O(N^2) algorithm, but
1844 * extensions of primitive generics are rare.
1846 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1847 loc
= &(*loc
)->next
;
1849 e
->extended
= extended
;
1850 e
->extension
= extension
;
1856 setup_extended_primitive_generics ()
1860 t_extension
*e
= extensions
;
1861 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1862 extensions
= e
->next
;
1866 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1867 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1868 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1872 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1874 if (!SCM_UNPACK (gf
))
1875 scm_error_num_args_subr (subr
);
1877 return scm_call_0 (gf
);
1881 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1883 if (!SCM_UNPACK (gf
))
1884 scm_wrong_type_arg (subr
, pos
, a1
);
1886 return scm_call_1 (gf
, a1
);
1890 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1892 if (!SCM_UNPACK (gf
))
1893 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1895 return scm_call_2 (gf
, a1
, a2
);
1899 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1901 if (!SCM_UNPACK (gf
))
1902 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1904 return scm_apply_0 (gf
, args
);
1907 /******************************************************************************
1909 * Protocol for calling a generic fumction
1910 * This protocol is roughly equivalent to (parameter are a little bit different
1911 * for efficiency reasons):
1913 * + apply-generic (gf args)
1914 * + compute-applicable-methods (gf args ...)
1915 * + sort-applicable-methods (methods args)
1916 * + apply-methods (gf methods args)
1918 * apply-methods calls make-next-method to build the "continuation" of a a
1919 * method. Applying a next-method will call apply-next-method which in
1920 * turn will call apply again to call effectively the following method.
1922 ******************************************************************************/
1925 applicablep (SCM actual
, SCM formal
)
1927 /* We already know that the cpl is well formed. */
1928 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1932 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1934 register SCM s1
, s2
;
1938 * m1 and m2 can have != length (i.e. one can be one element longer than the
1939 * other when we have a dotted parameter list). For instance, with the call
1942 * (define-method M (a . l) ....)
1943 * (define-method M (a) ....)
1945 * we consider that the second method is more specific.
1947 * BTW, targs is an array of types. We don't need it's size since
1948 * we already know that m1 and m2 are applicable (no risk to go past
1949 * the end of this array).
1952 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1953 if (scm_is_null(s1
)) return 1;
1954 if (scm_is_null(s2
)) return 0;
1955 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1956 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1958 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1959 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1961 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1964 return 0;/* should not occur! */
1967 return 0; /* should not occur! */
1970 #define BUFFSIZE 32 /* big enough for most uses */
1973 scm_i_vector2list (SCM l
, long len
)
1976 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1978 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1979 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1985 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1988 SCM
*v
, vector
= SCM_EOL
;
1989 SCM buffer
[BUFFSIZE
];
1990 SCM save
= method_list
;
1991 scm_t_array_handle handle
;
1993 /* For reasonably sized method_lists we can try to avoid all the
1994 * consing and reorder the list in place...
1995 * This idea is due to David McClain <Dave_McClain@msn.com>
1997 if (size
<= BUFFSIZE
)
1999 for (i
= 0; i
< size
; i
++)
2001 buffer
[i
] = SCM_CAR (method_list
);
2002 method_list
= SCM_CDR (method_list
);
2008 /* Too many elements in method_list to keep everything locally */
2009 vector
= scm_i_vector2list (save
, size
);
2010 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2013 /* Use a simple shell sort since it is generally faster than qsort on
2014 * small vectors (which is probably mostly the case when we have to
2015 * sort a list of applicable methods).
2017 for (incr
= size
/ 2; incr
; incr
/= 2)
2019 for (i
= incr
; i
< size
; i
++)
2021 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2023 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2027 SCM tmp
= v
[j
+ incr
];
2035 if (size
<= BUFFSIZE
)
2037 /* We did it in locally, so restore the original list (reordered) in-place */
2038 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2040 SCM_SETCAR (method_list
, *v
);
2041 method_list
= SCM_CDR (method_list
);
2046 /* If we are here, that's that we did it the hard way... */
2047 scm_array_handle_release (&handle
);
2048 return scm_vector_to_list (vector
);
2052 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2056 SCM l
, fl
, applicable
= SCM_EOL
;
2058 SCM buffer
[BUFFSIZE
];
2062 scm_t_array_handle handle
;
2064 /* Build the list of arguments types */
2065 if (len
>= BUFFSIZE
)
2067 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2068 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2071 note that we don't have to work to reset the generation
2072 count. TMP is a new vector anyway, and it is found
2079 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2080 *p
++ = scm_class_of (SCM_CAR (args
));
2082 /* Build a list of all applicable methods */
2083 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2085 fl
= SPEC_OF (SCM_CAR (l
));
2086 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2088 if (SCM_INSTANCEP (fl
)
2089 /* We have a dotted argument list */
2090 || (i
>= len
&& scm_is_null (fl
)))
2091 { /* both list exhausted */
2092 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2098 || !applicablep (types
[i
], SCM_CAR (fl
)))
2103 if (len
>= BUFFSIZE
)
2104 scm_array_handle_release (&handle
);
2110 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2111 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2117 : sort_applicable_methods (applicable
, count
, types
));
2121 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2124 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2127 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2128 #define FUNC_NAME s_sys_compute_applicable_methods
2131 SCM_VALIDATE_GENERIC (1, gf
);
2132 n
= scm_ilength (args
);
2133 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2134 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2138 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2139 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2140 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2141 scm_sys_compute_applicable_methods
));
2143 /******************************************************************************
2145 * A simple make (which will be redefined later in Scheme)
2146 * This version handles only creation of gf, methods and classes (no instances)
2148 * Since this code will disappear when Goops will be fully booted,
2149 * no precaution is taken to be efficient.
2151 ******************************************************************************/
2153 SCM_KEYWORD (k_setter
, "setter");
2154 SCM_KEYWORD (k_specializers
, "specializers");
2155 SCM_KEYWORD (k_procedure
, "procedure");
2156 SCM_KEYWORD (k_formals
, "formals");
2157 SCM_KEYWORD (k_body
, "body");
2158 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2159 SCM_KEYWORD (k_dsupers
, "dsupers");
2160 SCM_KEYWORD (k_slots
, "slots");
2161 SCM_KEYWORD (k_gf
, "generic-function");
2163 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2165 "Make a new object. @var{args} must contain the class and\n"
2166 "all necessary initialization information.")
2167 #define FUNC_NAME s_scm_make
2170 long len
= scm_ilength (args
);
2172 if (len
<= 0 || (len
& 1) == 0)
2173 SCM_WRONG_NUM_ARGS ();
2175 class = SCM_CAR(args
);
2176 args
= SCM_CDR(args
);
2178 if (scm_is_eq (class, scm_class_generic
)
2179 || scm_is_eq (class, scm_class_accessor
))
2181 z
= scm_make_struct (class, SCM_INUM0
,
2182 scm_list_4 (SCM_BOOL_F
,
2186 scm_set_procedure_property_x (z
, scm_sym_name
,
2187 scm_get_keyword (k_name
,
2190 clear_method_cache (z
);
2191 if (scm_is_eq (class, scm_class_accessor
))
2193 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2194 if (scm_is_true (setter
))
2195 scm_sys_set_object_setter_x (z
, setter
);
2200 z
= scm_sys_allocate_instance (class, args
);
2202 if (scm_is_eq (class, scm_class_method
)
2203 || scm_is_eq (class, scm_class_accessor_method
))
2205 SCM_SET_SLOT (z
, scm_si_generic_function
,
2206 scm_i_get_keyword (k_gf
,
2211 SCM_SET_SLOT (z
, scm_si_specializers
,
2212 scm_i_get_keyword (k_specializers
,
2217 SCM_SET_SLOT (z
, scm_si_procedure
,
2218 scm_i_get_keyword (k_procedure
,
2223 SCM_SET_SLOT (z
, scm_si_formals
,
2224 scm_i_get_keyword (k_formals
,
2229 SCM_SET_SLOT (z
, scm_si_body
,
2230 scm_i_get_keyword (k_body
,
2235 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2236 scm_i_get_keyword (k_make_procedure
,
2244 /* In all the others case, make a new class .... No instance here */
2245 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2246 scm_i_get_keyword (k_name
,
2249 scm_from_latin1_symbol ("???"),
2251 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2252 scm_i_get_keyword (k_dsupers
,
2257 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2258 scm_i_get_keyword (k_slots
,
2269 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2272 #define FUNC_NAME s_scm_find_method
2275 long len
= scm_ilength (l
);
2278 SCM_WRONG_NUM_ARGS ();
2280 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2281 SCM_VALIDATE_GENERIC (1, gf
);
2282 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2283 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2285 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2289 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2290 (SCM m1
, SCM m2
, SCM targs
),
2291 "Return true if method @var{m1} is more specific than @var{m2} "
2292 "given the argument types (classes) listed in @var{targs}.")
2293 #define FUNC_NAME s_scm_sys_method_more_specific_p
2297 long i
, len
, m1_specs
, m2_specs
;
2298 scm_t_array_handle handle
;
2300 SCM_VALIDATE_METHOD (1, m1
);
2301 SCM_VALIDATE_METHOD (2, m2
);
2303 len
= scm_ilength (targs
);
2304 m1_specs
= scm_ilength (SPEC_OF (m1
));
2305 m2_specs
= scm_ilength (SPEC_OF (m2
));
2306 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2307 targs
, SCM_ARG3
, FUNC_NAME
);
2309 /* Verify that all the arguments of TARGS are classes and place them
2312 v
= scm_c_make_vector (len
, SCM_EOL
);
2313 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2315 for (i
= 0, l
= targs
;
2316 i
< len
&& scm_is_pair (l
);
2317 i
++, l
= SCM_CDR (l
))
2319 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2320 v_elts
[i
] = SCM_CAR (l
);
2322 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2324 scm_array_handle_release (&handle
);
2332 /******************************************************************************
2336 ******************************************************************************/
2338 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2339 assuming that currently the reverse is true. Recalculate slots and
2340 associated getters-n-setters. */
2342 fix_cpl (SCM c
, SCM before
, SCM after
)
2344 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2345 SCM ls
= scm_c_memq (after
, cpl
);
2348 if (scm_is_false (ls
))
2349 /* if this condition occurs, fix_cpl should not be applied this way */
2352 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2353 SCM_SETCAR (ls
, before
);
2354 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2356 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2357 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2358 SCM g_n_s
= compute_getters_n_setters (slots
);
2359 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2360 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2366 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2368 SCM tmp
= scm_from_utf8_symbol (name
);
2370 *var
= scm_basic_make_class (meta
, tmp
,
2371 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2373 scm_module_define (scm_module_goops
, tmp
, *var
);
2377 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2380 create_standard_classes (void)
2383 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2384 scm_from_latin1_symbol ("specializers"),
2386 scm_from_latin1_symbol ("formals"),
2387 scm_from_latin1_symbol ("body"),
2388 scm_from_latin1_symbol ("make-procedure"),
2390 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2392 k_slot_definition
));
2393 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2394 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2397 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2400 scm_from_latin1_symbol ("effective-methods"));
2401 SCM setter_slots
= scm_list_1 (sym_setter
);
2402 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2405 /* Foreign class slot classes */
2406 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2407 scm_class_class
, scm_class_top
, SCM_EOL
);
2408 make_stdcls (&scm_class_protected
, "<protected-slot>",
2409 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2410 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2411 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2412 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2413 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2414 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2415 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2416 make_stdcls (&scm_class_self
, "<self-slot>",
2417 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2418 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2420 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2422 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2424 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2426 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2428 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2430 make_stdcls (&scm_class_scm
, "<scm-slot>",
2431 scm_class_class
, scm_class_protected
, SCM_EOL
);
2432 make_stdcls (&scm_class_int
, "<int-slot>",
2433 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2434 make_stdcls (&scm_class_float
, "<float-slot>",
2435 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2436 make_stdcls (&scm_class_double
, "<double-slot>",
2437 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2439 /* Continue initialization of class <class> */
2441 slots
= build_class_class_slots ();
2442 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2443 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2444 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2445 compute_getters_n_setters (slots
));
2447 /* scm_class_generic functions classes */
2448 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2449 scm_class_class
, scm_class_class
, SCM_EOL
);
2450 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2451 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2452 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2453 make_stdcls (&scm_class_method
, "<method>",
2454 scm_class_class
, scm_class_object
, method_slots
);
2455 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2456 scm_class_class
, scm_class_method
, amethod_slots
);
2457 make_stdcls (&scm_class_applicable
, "<applicable>",
2458 scm_class_class
, scm_class_top
, SCM_EOL
);
2459 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2460 scm_class_applicable_struct_class
,
2461 scm_list_2 (scm_class_object
, scm_class_applicable
),
2462 scm_list_1 (sym_procedure
));
2463 make_stdcls (&scm_class_generic
, "<generic>",
2464 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2465 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2466 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2467 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2468 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2469 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2470 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2471 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2472 make_stdcls (&scm_class_accessor
, "<accessor>",
2473 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2474 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2475 make_stdcls (&scm_class_extended_generic_with_setter
,
2476 "<extended-generic-with-setter>",
2477 scm_class_applicable_struct_class
,
2478 scm_list_2 (scm_class_extended_generic
,
2479 scm_class_generic_with_setter
),
2481 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2482 SCM_CLASSF_PURE_GENERIC
);
2483 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2484 scm_class_applicable_struct_class
,
2485 scm_list_2 (scm_class_accessor
,
2486 scm_class_extended_generic_with_setter
),
2488 /* <extended-generic> is misplaced. */
2489 fix_cpl (scm_class_extended_accessor
,
2490 scm_class_extended_generic
, scm_class_generic_with_setter
);
2491 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2493 /* Primitive types classes */
2494 make_stdcls (&scm_class_boolean
, "<boolean>",
2495 scm_class_class
, scm_class_top
, SCM_EOL
);
2496 make_stdcls (&scm_class_char
, "<char>",
2497 scm_class_class
, scm_class_top
, SCM_EOL
);
2498 make_stdcls (&scm_class_list
, "<list>",
2499 scm_class_class
, scm_class_top
, SCM_EOL
);
2500 make_stdcls (&scm_class_pair
, "<pair>",
2501 scm_class_class
, scm_class_list
, SCM_EOL
);
2502 make_stdcls (&scm_class_null
, "<null>",
2503 scm_class_class
, scm_class_list
, SCM_EOL
);
2504 make_stdcls (&scm_class_string
, "<string>",
2505 scm_class_class
, scm_class_top
, SCM_EOL
);
2506 make_stdcls (&scm_class_symbol
, "<symbol>",
2507 scm_class_class
, scm_class_top
, SCM_EOL
);
2508 make_stdcls (&scm_class_vector
, "<vector>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&class_foreign
, "<foreign>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&class_hashtable
, "<hashtable>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_fluid
, "<fluid>",
2515 scm_class_class
, scm_class_top
, SCM_EOL
);
2516 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2517 scm_class_class
, scm_class_top
, SCM_EOL
);
2518 make_stdcls (&class_frame
, "<frame>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2521 scm_class_class
, scm_class_top
, SCM_EOL
);
2522 make_stdcls (&class_bytevector
, "<bytevector>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&class_uvec
, "<uvec>",
2525 scm_class_class
, class_bytevector
, SCM_EOL
);
2526 make_stdcls (&class_array
, "<array>",
2527 scm_class_class
, scm_class_top
, SCM_EOL
);
2528 make_stdcls (&class_bitvector
, "<bitvector>",
2529 scm_class_class
, scm_class_top
, SCM_EOL
);
2530 make_stdcls (&scm_class_number
, "<number>",
2531 scm_class_class
, scm_class_top
, SCM_EOL
);
2532 make_stdcls (&scm_class_complex
, "<complex>",
2533 scm_class_class
, scm_class_number
, SCM_EOL
);
2534 make_stdcls (&scm_class_real
, "<real>",
2535 scm_class_class
, scm_class_complex
, SCM_EOL
);
2536 make_stdcls (&scm_class_integer
, "<integer>",
2537 scm_class_class
, scm_class_real
, SCM_EOL
);
2538 make_stdcls (&scm_class_fraction
, "<fraction>",
2539 scm_class_class
, scm_class_real
, SCM_EOL
);
2540 make_stdcls (&scm_class_keyword
, "<keyword>",
2541 scm_class_class
, scm_class_top
, SCM_EOL
);
2542 make_stdcls (&scm_class_unknown
, "<unknown>",
2543 scm_class_class
, scm_class_top
, SCM_EOL
);
2544 make_stdcls (&scm_class_procedure
, "<procedure>",
2545 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2546 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2547 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2548 make_stdcls (&scm_class_port
, "<port>",
2549 scm_class_class
, scm_class_top
, SCM_EOL
);
2550 make_stdcls (&scm_class_input_port
, "<input-port>",
2551 scm_class_class
, scm_class_port
, SCM_EOL
);
2552 make_stdcls (&scm_class_output_port
, "<output-port>",
2553 scm_class_class
, scm_class_port
, SCM_EOL
);
2554 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2556 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2560 /**********************************************************************
2564 **********************************************************************/
2567 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2573 sprintf (buffer
, template, type_name
);
2574 name
= scm_from_utf8_symbol (buffer
);
2577 name
= SCM_GOOPS_UNBOUND
;
2579 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2580 name
, supers
, SCM_EOL
);
2584 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2588 if (scm_is_true (type_name_sym
))
2590 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2591 scm_symbol_to_string (type_name_sym
),
2592 scm_from_locale_string (">")));
2593 name
= scm_string_to_symbol (name
);
2596 name
= SCM_GOOPS_UNBOUND
;
2598 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2599 name
, supers
, SCM_EOL
);
2603 scm_make_extended_class (char const *type_name
, int applicablep
)
2605 return make_class_from_template ("<%s>",
2607 scm_list_1 (applicablep
2608 ? scm_class_applicable
2614 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2616 return make_class_from_symbol (type_name_sym
,
2617 scm_list_1 (applicablep
2618 ? scm_class_applicable
2624 scm_i_inherit_applicable (SCM c
)
2626 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2628 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2629 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2630 /* patch scm_class_applicable into direct-supers */
2631 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2632 if (scm_is_false (top
))
2633 dsupers
= scm_append (scm_list_2 (dsupers
,
2634 scm_list_1 (scm_class_applicable
)));
2637 SCM_SETCAR (top
, scm_class_applicable
);
2638 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2640 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2641 /* patch scm_class_applicable into cpl */
2642 top
= scm_c_memq (scm_class_top
, cpl
);
2643 if (scm_is_false (top
))
2647 SCM_SETCAR (top
, scm_class_applicable
);
2648 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2650 /* add class to direct-subclasses of scm_class_applicable */
2651 SCM_SET_SLOT (scm_class_applicable
,
2652 scm_si_direct_subclasses
,
2653 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2654 scm_si_direct_subclasses
)));
2659 create_smob_classes (void)
2663 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2664 scm_smob_class
[i
] = SCM_BOOL_F
;
2666 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2668 for (i
= 0; i
< scm_numsmob
; ++i
)
2669 if (scm_is_false (scm_smob_class
[i
]))
2670 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2671 scm_smobs
[i
].apply
!= 0);
2675 scm_make_port_classes (long ptobnum
, char *type_name
)
2677 SCM c
, class = make_class_from_template ("<%s-port>",
2679 scm_list_1 (scm_class_port
),
2681 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2682 = make_class_from_template ("<%s-input-port>",
2684 scm_list_2 (class, scm_class_input_port
),
2686 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2687 = make_class_from_template ("<%s-output-port>",
2689 scm_list_2 (class, scm_class_output_port
),
2691 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2693 = make_class_from_template ("<%s-input-output-port>",
2695 scm_list_2 (class, scm_class_input_output_port
),
2697 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2698 SCM_SET_SLOT (c
, scm_si_cpl
,
2699 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2703 create_port_classes (void)
2707 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2708 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2712 make_struct_class (void *closure SCM_UNUSED
,
2713 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2715 if (scm_is_false (data
))
2716 scm_i_define_class_for_vtable (vtable
);
2717 return SCM_UNSPECIFIED
;
2721 create_struct_classes (void)
2723 /* FIXME: take the vtable_class_map while initializing goops? */
2724 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2728 /**********************************************************************
2732 **********************************************************************/
2737 if (!goops_loaded_p
)
2738 scm_c_resolve_module ("oop goops");
2742 SCM_SYMBOL (sym_o
, "o");
2743 SCM_SYMBOL (sym_x
, "x");
2745 SCM_KEYWORD (k_accessor
, "accessor");
2746 SCM_KEYWORD (k_getter
, "getter");
2749 scm_ensure_accessor (SCM name
)
2753 var
= scm_module_variable (scm_current_module (), name
);
2754 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2755 gf
= SCM_VARIABLE_REF (var
);
2759 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2761 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2762 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2763 k_name
, name
, k_setter
, gf
));
2771 * Debugging utilities
2774 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2776 "Return @code{#t} if @var{obj} is a pure generic.")
2777 #define FUNC_NAME s_scm_pure_generic_p
2779 return scm_from_bool (SCM_PUREGENERICP (obj
));
2783 #endif /* GUILE_DEBUG */
2789 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2791 "Announce that GOOPS is loaded and perform initialization\n"
2792 "on the C level which depends on the loaded GOOPS modules.")
2793 #define FUNC_NAME s_scm_sys_goops_loaded
2796 var_compute_applicable_methods
=
2797 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2799 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2801 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2803 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2804 var_no_applicable_method
=
2805 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2807 scm_module_variable (scm_module_goops
, sym_change_class
);
2808 setup_extended_primitive_generics ();
2809 return SCM_UNSPECIFIED
;
2813 SCM scm_module_goops
;
2816 scm_init_goops_builtins (void)
2818 scm_module_goops
= scm_current_module ();
2820 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2822 #include "libguile/goops.x"
2824 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2825 hell_mutex
= scm_make_mutex ();
2827 create_basic_classes ();
2828 create_standard_classes ();
2829 create_smob_classes ();
2830 create_struct_classes ();
2831 create_port_classes ();
2834 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2835 scm_no_applicable_method
=
2836 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2837 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2840 return SCM_UNSPECIFIED
;
2846 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2847 scm_init_goops_builtins
);