1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/chars.h"
38 #include "libguile/debug.h"
39 #include "libguile/dynl.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eval.h"
42 #include "libguile/gsubr.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/vm.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
61 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
64 #define SCM_IN_PCLASS_INDEX 0
65 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
66 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
68 /* this file is a mess. in theory, though, we shouldn't have many SCM references
69 -- most of the references should be to vars. */
71 static SCM var_slot_unbound
= SCM_BOOL_F
;
72 static SCM var_slot_missing
= SCM_BOOL_F
;
73 static SCM var_compute_cpl
= SCM_BOOL_F
;
74 static SCM var_no_applicable_method
= SCM_BOOL_F
;
75 static SCM var_change_class
= SCM_BOOL_F
;
77 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
78 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
79 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
80 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
81 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
82 SCM_SYMBOL (sym_change_class
, "change-class");
84 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
87 /* Class redefinition protocol:
89 A class is represented by a heap header h1 which points to a
90 malloc:ed memory block m1.
92 When a new version of a class is created, a new header h2 and
93 memory block m2 are allocated. The headers h1 and h2 then switch
94 pointers so that h1 refers to m2 and h2 to m1. In this way, names
95 bound to h1 will point to the new class at the same time as h2 will
96 be a handle which the GC will use to free m1.
98 The `redefined' slot of m1 will be set to point to h1. An old
99 instance will have its class pointer (the CAR of the heap header)
100 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
101 the class modification and the new class pointer can be found via
105 #define TEST_CHANGE_CLASS(obj, class) \
107 class = SCM_CLASS_OF (obj); \
108 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
110 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
111 class = SCM_CLASS_OF (obj); \
115 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
116 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
118 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
119 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
121 static int goops_loaded_p
= 0;
122 static scm_t_rstate
*goops_rstate
;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
126 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
127 SCM scm_class_primitive_generic
;
128 SCM scm_class_vector
, scm_class_null
;
129 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
130 SCM scm_class_unknown
;
131 SCM scm_class_top
, scm_class_object
, scm_class_class
;
132 SCM scm_class_applicable
;
133 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
134 SCM scm_class_generic
, scm_class_generic_with_setter
;
135 SCM scm_class_accessor
;
136 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
137 SCM scm_class_extended_accessor
;
138 SCM scm_class_method
;
139 SCM scm_class_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_applicable_struct_class
;
142 SCM scm_class_number
, scm_class_list
;
143 SCM scm_class_keyword
;
144 SCM scm_class_port
, scm_class_input_output_port
;
145 SCM scm_class_input_port
, scm_class_output_port
;
146 SCM scm_class_foreign_slot
;
147 SCM scm_class_self
, scm_class_protected
;
148 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
149 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
151 SCM scm_class_int
, scm_class_float
, scm_class_double
;
153 static SCM class_foreign
;
154 static SCM class_hashtable
;
155 static SCM class_fluid
;
156 static SCM class_dynamic_state
;
157 static SCM class_frame
;
158 static SCM class_objcode
;
160 static SCM class_vm_cont
;
161 static SCM class_bytevector
;
162 static SCM class_uvec
;
163 static SCM class_array
;
164 static SCM class_bitvector
;
166 static SCM vtable_class_map
= SCM_BOOL_F
;
168 /* Port classes. Allocate 3 times the maximum number of port types so that
169 input ports, output ports, and in/out ports can be stored at different
170 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
171 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
174 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
176 SCM scm_no_applicable_method
;
178 SCM_SYMBOL (scm_sym_define_public
, "define-public");
180 static SCM
scm_make_unbound (void);
181 static SCM
scm_unbound_p (SCM obj
);
182 static SCM
scm_assert_bound (SCM value
, SCM obj
);
183 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
184 static SCM
scm_sys_goops_loaded (void);
185 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
190 scm_i_define_class_for_vtable (SCM vtable
)
194 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
195 if (scm_is_false (vtable_class_map
))
196 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
197 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
199 if (scm_is_false (scm_struct_vtable_p (vtable
)))
202 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
204 if (scm_is_false (class))
206 if (SCM_UNPACK (scm_class_class
))
208 SCM name
= SCM_VTABLE_NAME (vtable
);
209 if (!scm_is_symbol (name
))
210 name
= scm_string_to_symbol (scm_nullstr
);
212 class = scm_make_extended_class_from_symbol
213 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
216 /* `create_struct_classes' will fill this in later. */
219 /* Don't worry about races. This only happens when creating a
220 vtable, which happens by definition in one thread. */
221 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
227 /* This function is used for efficient type dispatch. */
228 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
230 "Return the class of @var{x}.")
231 #define FUNC_NAME s_scm_class_of
233 switch (SCM_ITAG3 (x
))
237 return scm_class_integer
;
241 return scm_class_char
;
242 else if (scm_is_bool (x
))
243 return scm_class_boolean
;
244 else if (scm_is_null (x
))
245 return scm_class_null
;
247 return scm_class_unknown
;
250 switch (SCM_TYP7 (x
))
252 case scm_tcs_cons_nimcar
:
253 return scm_class_pair
;
255 return scm_class_symbol
;
258 return scm_class_vector
;
259 case scm_tc7_pointer
:
260 return class_foreign
;
261 case scm_tc7_hashtable
:
262 return class_hashtable
;
265 case scm_tc7_dynamic_state
:
266 return class_dynamic_state
;
269 case scm_tc7_objcode
:
270 return class_objcode
;
273 case scm_tc7_vm_cont
:
274 return class_vm_cont
;
275 case scm_tc7_bytevector
:
276 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
277 return class_bytevector
;
282 case scm_tc7_bitvector
:
283 return class_bitvector
;
285 return scm_class_string
;
287 switch SCM_TYP16 (x
) {
289 return scm_class_integer
;
291 return scm_class_real
;
292 case scm_tc16_complex
:
293 return scm_class_complex
;
294 case scm_tc16_fraction
:
295 return scm_class_fraction
;
297 case scm_tc7_program
:
298 case scm_tc7_rtl_program
:
299 /* Although SCM_SUBR_GENERIC is specific to stack programs
300 currently, in practice only stack programs pass
301 SCM_PROGRAM_IS_PRIMITIVE_GENERIC. In the future this will
302 change to be the other way around, when subrs become RTL
304 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
305 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
306 return scm_class_primitive_generic
;
308 return scm_class_procedure
;
312 scm_t_bits type
= SCM_TYP16 (x
);
313 if (type
!= scm_tc16_port_with_ps
)
314 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
315 x
= SCM_PORT_WITH_PS_PORT (x
);
316 /* fall through to ports */
319 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
320 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
321 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
322 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
323 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
325 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
326 return SCM_CLASS_OF (x
);
327 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
330 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
331 scm_change_object_class (x
,
332 SCM_CLASS_OF (x
), /* old */
333 SCM_OBJ_CLASS_REDEF (x
)); /* new */
334 return SCM_CLASS_OF (x
);
337 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
340 return scm_class_pair
;
342 return scm_class_unknown
;
348 /* case scm_tc3_unused: */
352 return scm_class_unknown
;
356 /******************************************************************************
360 * This version doesn't fully handle multiple-inheritance. It serves
361 * only for booting classes and will be overloaded in Scheme
363 ******************************************************************************/
366 map (SCM (*proc
) (SCM
), SCM ls
)
368 if (scm_is_null (ls
))
372 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
375 while (scm_is_pair (ls
))
377 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
389 while (scm_is_pair (ls
))
391 SCM el
= SCM_CAR (ls
);
392 if (scm_is_false (scm_c_memq (el
, res
)))
393 res
= scm_cons (el
, res
);
400 compute_cpl (SCM
class)
403 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
406 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
407 SCM ls
= scm_append (scm_acons (class, supers
,
408 map (compute_cpl
, supers
)));
409 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
413 /******************************************************************************
417 ******************************************************************************/
420 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
424 if (!scm_is_pair (l
))
428 if (!scm_is_symbol (tmp
))
429 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
431 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
432 res
= scm_cons (SCM_CAR (l
), res
);
433 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
436 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
440 check_cpl (SCM slots
, SCM bslots
)
442 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
443 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
444 scm_misc_error ("init-object", "a predefined <class> inherited "
445 "field cannot be redefined", SCM_EOL
);
449 build_class_class_slots (void);
452 build_slots_list (SCM dslots
, SCM cpl
)
454 SCM bslots
, class_slots
;
458 class_slots
= SCM_EOL
;
459 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
463 bslots
= build_class_class_slots ();
464 check_cpl (res
, bslots
);
469 if (scm_is_pair (cpl
))
471 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
473 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
474 scm_si_direct_slots
);
477 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
478 check_cpl (new_slots
, bslots
);
481 /* Move class slots to the head of the list. */
482 class_slots
= new_slots
;
486 res
= scm_append (scm_list_2 (new_slots
, res
));
490 scm_misc_error ("%compute-slots", "malformed cpl argument in "
491 "build_slots_list", SCM_EOL
);
493 /* make sure to add the <class> slots to the head of the list */
495 res
= scm_append (scm_list_2 (class_slots
, res
));
497 /* res contains a list of slots. Remove slots which appears more than once */
498 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
505 while (!scm_is_null (ls
))
507 if (!scm_is_pair (ls
))
508 scm_misc_error ("%compute-slots", "malformed ls argument in "
510 if (!scm_is_pair (SCM_CAR (ls
)))
511 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
518 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
520 "Return a list consisting of the names of all slots belonging to\n"
521 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
523 #define FUNC_NAME s_scm_sys_compute_slots
525 SCM_VALIDATE_CLASS (1, class);
526 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
527 SCM_SLOT (class, scm_si_cpl
));
532 /******************************************************************************
534 * compute-getters-n-setters
536 * This version doesn't handle slot options. It serves only for booting
537 * classes and will be overloaded in Scheme.
539 ******************************************************************************/
541 SCM_KEYWORD (k_init_value
, "init-value");
542 SCM_KEYWORD (k_init_thunk
, "init-thunk");
545 compute_getters_n_setters (SCM slots
)
551 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
553 SCM init
= SCM_BOOL_F
;
554 SCM options
= SCM_CDAR (slots
);
555 if (!scm_is_null (options
))
557 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
558 if (SCM_UNPACK (init
))
560 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
562 scm_list_2 (scm_sym_quote
,
566 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
568 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
570 scm_from_int (i
++))),
572 cdrloc
= SCM_CDRLOC (*cdrloc
);
577 /******************************************************************************
581 ******************************************************************************/
583 /*fixme* Manufacture keywords in advance */
585 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
589 for (i
= 0; i
!= len
; i
+= 2)
591 SCM obj
= SCM_CAR (l
);
593 if (!scm_is_keyword (obj
))
594 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
595 else if (scm_is_eq (obj
, key
))
601 return default_value
;
605 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
606 (SCM key
, SCM l
, SCM default_value
),
607 "Determine an associated value for the keyword @var{key} from\n"
608 "the list @var{l}. The list @var{l} has to consist of an even\n"
609 "number of elements, where, starting with the first, every\n"
610 "second element is a keyword, followed by its associated value.\n"
611 "If @var{l} does not hold a value for @var{key}, the value\n"
612 "@var{default_value} is returned.")
613 #define FUNC_NAME s_scm_get_keyword
617 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
618 len
= scm_ilength (l
);
619 if (len
< 0 || len
% 2 == 1)
620 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
622 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
627 SCM_KEYWORD (k_init_keyword
, "init-keyword");
629 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
630 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
632 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
633 (SCM obj
, SCM initargs
),
634 "Initialize the object @var{obj} with the given arguments\n"
636 #define FUNC_NAME s_scm_sys_initialize_object
638 SCM tmp
, get_n_set
, slots
;
639 SCM
class = SCM_CLASS_OF (obj
);
642 SCM_VALIDATE_INSTANCE (1, obj
);
643 n_initargs
= scm_ilength (initargs
);
644 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
646 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
647 slots
= SCM_SLOT (class, scm_si_slots
);
649 /* See for each slot how it must be initialized */
651 !scm_is_null (slots
);
652 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
654 SCM slot_name
= SCM_CAR (slots
);
655 SCM slot_value
= SCM_PACK (0);
657 if (!scm_is_null (SCM_CDR (slot_name
)))
659 /* This slot admits (perhaps) to be initialized at creation time */
660 long n
= scm_ilength (SCM_CDR (slot_name
));
661 if (n
& 1) /* odd or -1 */
662 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
663 scm_list_1 (slot_name
));
664 tmp
= scm_i_get_keyword (k_init_keyword
,
669 slot_name
= SCM_CAR (slot_name
);
670 if (SCM_UNPACK (tmp
))
672 /* an initarg was provided for this slot */
673 if (!scm_is_keyword (tmp
))
674 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
676 slot_value
= scm_i_get_keyword (tmp
,
684 if (SCM_UNPACK (slot_value
))
685 /* set slot to provided value */
686 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
689 /* set slot to its :init-form if it exists */
690 tmp
= SCM_CADAR (get_n_set
);
691 if (scm_is_true (tmp
))
693 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
694 if (SCM_GOOPS_UNBOUNDP (slot_value
))
695 set_slot_value (class,
707 /* NOTE: The following macros are interdependent with code
708 * in goops.scm:compute-getters-n-setters
710 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
711 (SCM_I_INUMP (SCM_CDDR (gns)) \
712 || (scm_is_pair (SCM_CDDR (gns)) \
713 && scm_is_pair (SCM_CDDDR (gns)) \
714 && scm_is_pair (SCM_CDDDDR (gns))))
715 #define SCM_GNS_INDEX(gns) \
716 (SCM_I_INUMP (SCM_CDDR (gns)) \
717 ? SCM_I_INUM (SCM_CDDR (gns)) \
718 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
719 #define SCM_GNS_SIZE(gns) \
720 (SCM_I_INUMP (SCM_CDDR (gns)) \
722 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
724 SCM_KEYWORD (k_class
, "class");
725 SCM_KEYWORD (k_allocation
, "allocation");
726 SCM_KEYWORD (k_instance
, "instance");
728 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
731 #define FUNC_NAME s_scm_sys_prep_layout_x
733 SCM slots
, getters_n_setters
, nfields
;
734 unsigned long int n
, i
;
738 SCM_VALIDATE_INSTANCE (1, class);
739 slots
= SCM_SLOT (class, scm_si_slots
);
740 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
741 nfields
= SCM_SLOT (class, scm_si_nfields
);
742 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
743 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
744 scm_list_1 (nfields
));
745 n
= 2 * SCM_I_INUM (nfields
);
746 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
747 && SCM_SUBCLASSP (class, scm_class_class
))
748 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
749 scm_list_1 (nfields
));
751 layout
= scm_i_make_string (n
, &s
, 0);
753 while (scm_is_pair (getters_n_setters
))
755 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
758 int len
, index
, size
;
761 if (i
>= n
|| !scm_is_pair (slots
))
764 /* extract slot type */
765 len
= scm_ilength (SCM_CDAR (slots
));
766 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
767 len
, SCM_BOOL_F
, FUNC_NAME
);
768 /* determine slot GC protection and access mode */
769 if (scm_is_false (type
))
776 if (!SCM_CLASSP (type
))
777 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
778 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
780 if (SCM_SUBCLASSP (type
, scm_class_self
))
782 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
787 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
789 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
791 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
803 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
804 if (index
!= (i
>> 1))
806 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
814 slots
= SCM_CDR (slots
);
815 getters_n_setters
= SCM_CDR (getters_n_setters
);
817 if (!scm_is_null (slots
))
820 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
822 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
823 return SCM_UNSPECIFIED
;
827 static void prep_hashsets (SCM
);
829 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
830 (SCM
class, SCM dsupers
),
832 #define FUNC_NAME s_scm_sys_inherit_magic_x
834 SCM_VALIDATE_INSTANCE (1, class);
835 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
836 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
838 prep_hashsets (class);
840 return SCM_UNSPECIFIED
;
845 prep_hashsets (SCM
class)
849 for (i
= 0; i
< 8; ++i
)
850 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
853 /******************************************************************************/
856 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
858 SCM z
, cpl
, slots
, nfields
, g_n_s
;
860 /* Allocate one instance */
861 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
863 /* Initialize its slots */
864 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
865 cpl
= compute_cpl (z
);
866 slots
= build_slots_list (maplist (dslots
), cpl
);
867 nfields
= scm_from_int (scm_ilength (slots
));
868 g_n_s
= compute_getters_n_setters (slots
);
870 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
871 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
872 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
873 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
874 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
875 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
876 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
877 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
878 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
880 /* Add this class in the direct-subclasses slot of dsupers */
883 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
884 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
885 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
886 scm_si_direct_subclasses
)));
893 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
895 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
896 scm_sys_prep_layout_x (z
);
897 scm_sys_inherit_magic_x (z
, dsupers
);
901 /******************************************************************************/
903 SCM_SYMBOL (sym_layout
, "layout");
904 SCM_SYMBOL (sym_flags
, "flags");
905 SCM_SYMBOL (sym_self
, "%self");
906 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
907 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
908 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
909 SCM_SYMBOL (sym_print
, "print");
910 SCM_SYMBOL (sym_procedure
, "procedure");
911 SCM_SYMBOL (sym_setter
, "setter");
912 SCM_SYMBOL (sym_redefined
, "redefined");
913 SCM_SYMBOL (sym_h0
, "h0");
914 SCM_SYMBOL (sym_h1
, "h1");
915 SCM_SYMBOL (sym_h2
, "h2");
916 SCM_SYMBOL (sym_h3
, "h3");
917 SCM_SYMBOL (sym_h4
, "h4");
918 SCM_SYMBOL (sym_h5
, "h5");
919 SCM_SYMBOL (sym_h6
, "h6");
920 SCM_SYMBOL (sym_h7
, "h7");
921 SCM_SYMBOL (sym_name
, "name");
922 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
923 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
924 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
925 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
926 SCM_SYMBOL (sym_cpl
, "cpl");
927 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
928 SCM_SYMBOL (sym_slots
, "slots");
929 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
930 SCM_SYMBOL (sym_nfields
, "nfields");
934 build_class_class_slots (void)
936 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
937 SCM_CLASS_CLASS_LAYOUT */
939 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
940 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
941 scm_list_3 (sym_self
, k_class
, scm_class_self
),
942 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
943 scm_list_1 (sym_print
),
944 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
945 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
946 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
947 scm_list_1 (sym_redefined
),
948 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
949 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
950 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
951 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
952 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
953 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
954 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
955 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
956 scm_list_1 (sym_direct_supers
),
957 scm_list_1 (sym_direct_slots
),
958 scm_list_1 (sym_direct_subclasses
),
959 scm_list_1 (sym_direct_methods
),
960 scm_list_1 (sym_cpl
),
961 scm_list_1 (sym_default_slot_definition_class
),
962 scm_list_1 (sym_slots
),
963 scm_list_1 (sym_getters_n_setters
),
964 scm_list_1 (sym_nfields
),
969 create_basic_classes (void)
971 /* SCM slots_of_class = build_class_class_slots (); */
974 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
975 SCM name
= scm_from_latin1_symbol ("<class>");
976 scm_class_class
= scm_i_make_vtable_vtable (cs
);
977 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
978 | SCM_CLASSF_METACLASS
));
980 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
981 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
982 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
983 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
984 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
985 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
986 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
987 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
988 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
989 compute_getters_n_setters (slots_of_class)); */
990 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
992 prep_hashsets (scm_class_class
);
994 scm_module_define (scm_module_goops
, name
, scm_class_class
);
997 name
= scm_from_latin1_symbol ("<top>");
998 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
1001 scm_module_define (scm_module_goops
, name
, scm_class_top
);
1003 /**** <object> ****/
1004 name
= scm_from_latin1_symbol ("<object>");
1005 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
1006 scm_list_1 (scm_class_top
), SCM_EOL
);
1008 scm_module_define (scm_module_goops
, name
, scm_class_object
);
1010 /* <top> <object> and <class> were partially initialized. Correct them here */
1011 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1013 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1014 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1017 /******************************************************************************/
1019 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1021 "Return @code{#t} if @var{obj} is an instance.")
1022 #define FUNC_NAME s_scm_instance_p
1024 return scm_from_bool (SCM_INSTANCEP (obj
));
1029 /******************************************************************************
1031 * Meta object accessors
1033 ******************************************************************************/
1034 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1036 "Return the class name of @var{obj}.")
1037 #define FUNC_NAME s_scm_class_name
1039 SCM_VALIDATE_CLASS (1, obj
);
1040 return scm_slot_ref (obj
, sym_name
);
1044 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1046 "Return the direct superclasses of the class @var{obj}.")
1047 #define FUNC_NAME s_scm_class_direct_supers
1049 SCM_VALIDATE_CLASS (1, obj
);
1050 return scm_slot_ref (obj
, sym_direct_supers
);
1054 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1056 "Return the direct slots of the class @var{obj}.")
1057 #define FUNC_NAME s_scm_class_direct_slots
1059 SCM_VALIDATE_CLASS (1, obj
);
1060 return scm_slot_ref (obj
, sym_direct_slots
);
1064 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1066 "Return the direct subclasses of the class @var{obj}.")
1067 #define FUNC_NAME s_scm_class_direct_subclasses
1069 SCM_VALIDATE_CLASS (1, obj
);
1070 return scm_slot_ref(obj
, sym_direct_subclasses
);
1074 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1076 "Return the direct methods of the class @var{obj}")
1077 #define FUNC_NAME s_scm_class_direct_methods
1079 SCM_VALIDATE_CLASS (1, obj
);
1080 return scm_slot_ref (obj
, sym_direct_methods
);
1084 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1086 "Return the class precedence list of the class @var{obj}.")
1087 #define FUNC_NAME s_scm_class_precedence_list
1089 SCM_VALIDATE_CLASS (1, obj
);
1090 return scm_slot_ref (obj
, sym_cpl
);
1094 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1096 "Return the slot list of the class @var{obj}.")
1097 #define FUNC_NAME s_scm_class_slots
1099 SCM_VALIDATE_CLASS (1, obj
);
1100 return scm_slot_ref (obj
, sym_slots
);
1104 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1106 "Return the name of the generic function @var{obj}.")
1107 #define FUNC_NAME s_scm_generic_function_name
1109 SCM_VALIDATE_GENERIC (1, obj
);
1110 return scm_procedure_property (obj
, scm_sym_name
);
1114 SCM_SYMBOL (sym_methods
, "methods");
1115 SCM_SYMBOL (sym_extended_by
, "extended-by");
1116 SCM_SYMBOL (sym_extends
, "extends");
1119 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1121 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1122 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1123 while (!scm_is_null (gfs
))
1125 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1126 gfs
= SCM_CDR (gfs
);
1128 return method_lists
;
1132 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1134 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1136 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1137 while (!scm_is_null (gfs
))
1139 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1140 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1143 gfs
= SCM_CDR (gfs
);
1146 return method_lists
;
1149 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1151 "Return the methods of the generic function @var{obj}.")
1152 #define FUNC_NAME s_scm_generic_function_methods
1155 SCM_VALIDATE_GENERIC (1, obj
);
1156 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1157 methods
= fold_downward_gf_methods (methods
, obj
);
1158 return scm_append (methods
);
1162 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1164 "Return the generic function for the method @var{obj}.")
1165 #define FUNC_NAME s_scm_method_generic_function
1167 SCM_VALIDATE_METHOD (1, obj
);
1168 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1172 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1174 "Return specializers of the method @var{obj}.")
1175 #define FUNC_NAME s_scm_method_specializers
1177 SCM_VALIDATE_METHOD (1, obj
);
1178 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1182 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1184 "Return the procedure of the method @var{obj}.")
1185 #define FUNC_NAME s_scm_method_procedure
1187 SCM_VALIDATE_METHOD (1, obj
);
1188 return scm_slot_ref (obj
, sym_procedure
);
1192 /******************************************************************************
1194 * S l o t a c c e s s
1196 ******************************************************************************/
1198 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1200 "Return the unbound value.")
1201 #define FUNC_NAME s_scm_make_unbound
1203 return SCM_GOOPS_UNBOUND
;
1207 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1209 "Return @code{#t} if @var{obj} is unbound.")
1210 #define FUNC_NAME s_scm_unbound_p
1212 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1216 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1217 (SCM value
, SCM obj
),
1218 "Return @var{value} if it is bound, and invoke the\n"
1219 "@var{slot-unbound} method of @var{obj} if it is not.")
1220 #define FUNC_NAME s_scm_assert_bound
1222 if (SCM_GOOPS_UNBOUNDP (value
))
1223 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1228 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1229 (SCM obj
, SCM index
),
1230 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1231 "the value from @var{obj}.")
1232 #define FUNC_NAME s_scm_at_assert_bound_ref
1234 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1235 if (SCM_GOOPS_UNBOUNDP (value
))
1236 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1241 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1242 (SCM obj
, SCM index
),
1243 "Return the slot value with index @var{index} from @var{obj}.")
1244 #define FUNC_NAME s_scm_sys_fast_slot_ref
1248 SCM_VALIDATE_INSTANCE (1, obj
);
1249 i
= scm_to_unsigned_integer (index
, 0,
1250 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1253 return SCM_SLOT (obj
, i
);
1257 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1258 (SCM obj
, SCM index
, SCM value
),
1259 "Set the slot with index @var{index} in @var{obj} to\n"
1261 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1265 SCM_VALIDATE_INSTANCE (1, obj
);
1266 i
= scm_to_unsigned_integer (index
, 0,
1267 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1271 SCM_SET_SLOT (obj
, i
, value
);
1273 return SCM_UNSPECIFIED
;
1281 /* In the future, this function will return the effective slot
1282 * definition associated with SLOT_NAME. Now it just returns some of
1283 * the information which will be stored in the effective slot
1288 slot_definition_using_name (SCM
class, SCM slot_name
)
1290 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1291 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1292 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1293 return SCM_CAR (slots
);
1298 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1299 #define FUNC_NAME "%get-slot-value"
1301 SCM access
= SCM_CDDR (slotdef
);
1303 * - access is an integer (the offset of this slot in the slots vector)
1304 * - otherwise (car access) is the getter function to apply
1306 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1307 * we can just assume fixnums here.
1309 if (SCM_I_INUMP (access
))
1310 /* Don't poke at the slots directly, because scm_struct_ref handles the
1311 access bits for us. */
1312 return scm_struct_ref (obj
, access
);
1314 return scm_call_1 (SCM_CAR (access
), obj
);
1319 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1321 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1322 if (scm_is_true (slotdef
))
1323 return get_slot_value (class, obj
, slotdef
);
1325 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1329 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1330 #define FUNC_NAME "%set-slot-value"
1332 SCM access
= SCM_CDDR (slotdef
);
1334 * - access is an integer (the offset of this slot in the slots vector)
1335 * - otherwise (cadr access) is the setter function to apply
1337 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1338 * we can just assume fixnums here.
1340 if (SCM_I_INUMP (access
))
1341 /* obey permissions bits via going through struct-set! */
1342 scm_struct_set_x (obj
, access
, value
);
1344 /* ((cadr l) obj value) */
1345 scm_call_2 (SCM_CADR (access
), obj
, value
);
1346 return SCM_UNSPECIFIED
;
1351 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1353 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1354 if (scm_is_true (slotdef
))
1355 return set_slot_value (class, obj
, slotdef
, value
);
1357 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1361 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1365 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1366 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1372 /* ======================================== */
1374 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1375 (SCM
class, SCM obj
, SCM slot_name
),
1377 #define FUNC_NAME s_scm_slot_ref_using_class
1381 SCM_VALIDATE_CLASS (1, class);
1382 SCM_VALIDATE_INSTANCE (2, obj
);
1383 SCM_VALIDATE_SYMBOL (3, slot_name
);
1385 res
= get_slot_value_using_name (class, obj
, slot_name
);
1386 if (SCM_GOOPS_UNBOUNDP (res
))
1387 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1393 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1394 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1396 #define FUNC_NAME s_scm_slot_set_using_class_x
1398 SCM_VALIDATE_CLASS (1, class);
1399 SCM_VALIDATE_INSTANCE (2, obj
);
1400 SCM_VALIDATE_SYMBOL (3, slot_name
);
1402 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1407 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1408 (SCM
class, SCM obj
, SCM slot_name
),
1410 #define FUNC_NAME s_scm_slot_bound_using_class_p
1412 SCM_VALIDATE_CLASS (1, class);
1413 SCM_VALIDATE_INSTANCE (2, obj
);
1414 SCM_VALIDATE_SYMBOL (3, slot_name
);
1416 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1422 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1423 (SCM
class, SCM obj
, SCM slot_name
),
1425 #define FUNC_NAME s_scm_slot_exists_using_class_p
1427 SCM_VALIDATE_CLASS (1, class);
1428 SCM_VALIDATE_INSTANCE (2, obj
);
1429 SCM_VALIDATE_SYMBOL (3, slot_name
);
1430 return test_slot_existence (class, obj
, slot_name
);
1435 /* ======================================== */
1437 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1438 (SCM obj
, SCM slot_name
),
1439 "Return the value from @var{obj}'s slot with the name\n"
1441 #define FUNC_NAME s_scm_slot_ref
1445 SCM_VALIDATE_INSTANCE (1, obj
);
1446 TEST_CHANGE_CLASS (obj
, class);
1448 res
= get_slot_value_using_name (class, obj
, slot_name
);
1449 if (SCM_GOOPS_UNBOUNDP (res
))
1450 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1455 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1456 (SCM obj
, SCM slot_name
, SCM value
),
1457 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1458 #define FUNC_NAME s_scm_slot_set_x
1462 SCM_VALIDATE_INSTANCE (1, obj
);
1463 TEST_CHANGE_CLASS(obj
, class);
1465 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1469 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1471 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1472 (SCM obj
, SCM slot_name
),
1473 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1475 #define FUNC_NAME s_scm_slot_bound_p
1479 SCM_VALIDATE_INSTANCE (1, obj
);
1480 TEST_CHANGE_CLASS(obj
, class);
1482 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1490 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1491 (SCM obj
, SCM slot_name
),
1492 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1493 #define FUNC_NAME s_scm_slot_exists_p
1497 SCM_VALIDATE_INSTANCE (1, obj
);
1498 SCM_VALIDATE_SYMBOL (2, slot_name
);
1499 TEST_CHANGE_CLASS (obj
, class);
1501 return test_slot_existence (class, obj
, slot_name
);
1506 /******************************************************************************
1508 * %allocate-instance (the low level instance allocation primitive)
1510 ******************************************************************************/
1512 static void clear_method_cache (SCM
);
1514 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1515 (SCM
class, SCM initargs
),
1516 "Create a new instance of class @var{class} and initialize it\n"
1517 "from the arguments @var{initargs}.")
1518 #define FUNC_NAME s_scm_sys_allocate_instance
1521 scm_t_signed_bits n
, i
;
1524 SCM_VALIDATE_CLASS (1, class);
1526 /* FIXME: duplicates some of scm_make_struct. */
1528 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1529 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1531 layout
= SCM_VTABLE_LAYOUT (class);
1533 /* Set all SCM-holding slots to unbound */
1534 for (i
= 0; i
< n
; i
++)
1536 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1538 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1540 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1542 SCM_STRUCT_DATA (obj
)[i
] = 0;
1545 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1546 clear_method_cache (obj
);
1552 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1553 (SCM obj
, SCM setter
),
1555 #define FUNC_NAME s_scm_sys_set_object_setter_x
1557 SCM_ASSERT (SCM_STRUCTP (obj
)
1558 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1562 SCM_SET_GENERIC_SETTER (obj
, setter
);
1563 return SCM_UNSPECIFIED
;
1567 /******************************************************************************
1569 * %modify-instance (used by change-class to modify in place)
1571 ******************************************************************************/
1573 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1576 #define FUNC_NAME s_scm_sys_modify_instance
1578 SCM_VALIDATE_INSTANCE (1, old
);
1579 SCM_VALIDATE_INSTANCE (2, new);
1581 /* Exchange the data contained in old and new. We exchange rather than
1582 * scratch the old value with new to be correct with GC.
1583 * See "Class redefinition protocol above".
1585 SCM_CRITICAL_SECTION_START
;
1587 scm_t_bits word0
, word1
;
1588 word0
= SCM_CELL_WORD_0 (old
);
1589 word1
= SCM_CELL_WORD_1 (old
);
1590 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1591 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1592 SCM_SET_CELL_WORD_0 (new, word0
);
1593 SCM_SET_CELL_WORD_1 (new, word1
);
1595 SCM_CRITICAL_SECTION_END
;
1596 return SCM_UNSPECIFIED
;
1600 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1603 #define FUNC_NAME s_scm_sys_modify_class
1605 SCM_VALIDATE_CLASS (1, old
);
1606 SCM_VALIDATE_CLASS (2, new);
1608 SCM_CRITICAL_SECTION_START
;
1610 scm_t_bits word0
, word1
;
1611 word0
= SCM_CELL_WORD_0 (old
);
1612 word1
= SCM_CELL_WORD_1 (old
);
1613 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1614 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1615 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1616 SCM_SET_CELL_WORD_0 (new, word0
);
1617 SCM_SET_CELL_WORD_1 (new, word1
);
1618 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1620 SCM_CRITICAL_SECTION_END
;
1621 return SCM_UNSPECIFIED
;
1625 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1628 #define FUNC_NAME s_scm_sys_invalidate_class
1630 SCM_VALIDATE_CLASS (1, class);
1631 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1632 return SCM_UNSPECIFIED
;
1636 /* When instances change class, they finally get a new body, but
1637 * before that, they go through purgatory in hell. Odd as it may
1638 * seem, this data structure saves us from eternal suffering in
1639 * infinite recursions.
1642 static scm_t_bits
**hell
;
1643 static long n_hell
= 1; /* one place for the evil one himself */
1644 static long hell_size
= 4;
1645 static SCM hell_mutex
;
1651 for (i
= 1; i
< n_hell
; ++i
)
1652 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1658 go_to_hell (void *o
)
1661 scm_lock_mutex (hell_mutex
);
1662 if (n_hell
>= hell_size
)
1665 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1667 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1668 scm_unlock_mutex (hell_mutex
);
1672 go_to_heaven (void *o
)
1675 scm_lock_mutex (hell_mutex
);
1676 hell
[burnin (obj
)] = hell
[--n_hell
];
1677 scm_unlock_mutex (hell_mutex
);
1681 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1684 purgatory (SCM obj
, SCM new_class
)
1686 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1689 /* This function calls the generic function change-class for all
1690 * instances which aren't currently undergoing class change.
1694 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1698 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1699 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1700 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1701 purgatory (obj
, new_class
);
1706 /******************************************************************************
1712 * GGG E N E R I C F U N C T I O N S
1714 * This implementation provides
1715 * - generic functions (with class specializers)
1718 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1720 ******************************************************************************/
1722 SCM_KEYWORD (k_name
, "name");
1724 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1727 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1729 make_dispatch_procedure (SCM gf
)
1731 static SCM var
= SCM_BOOL_F
;
1732 if (scm_is_false (var
))
1733 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1734 sym_delayed_compile
);
1735 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1739 clear_method_cache (SCM gf
)
1741 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1742 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1745 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1748 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1750 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1751 clear_method_cache (gf
);
1752 return SCM_UNSPECIFIED
;
1756 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1759 #define FUNC_NAME s_scm_generic_capability_p
1761 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1762 proc
, SCM_ARG1
, FUNC_NAME
);
1763 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1767 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1770 #define FUNC_NAME s_scm_enable_primitive_generic_x
1772 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1773 while (!scm_is_null (subrs
))
1775 SCM subr
= SCM_CAR (subrs
);
1776 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1777 SCM_SET_SUBR_GENERIC (subr
,
1778 scm_make (scm_list_3 (scm_class_generic
,
1780 SCM_SUBR_NAME (subr
))));
1781 subrs
= SCM_CDR (subrs
);
1783 return SCM_UNSPECIFIED
;
1787 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1788 (SCM subr
, SCM generic
),
1790 #define FUNC_NAME s_scm_set_primitive_generic_x
1792 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1793 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1794 SCM_SET_SUBR_GENERIC (subr
, generic
);
1795 return SCM_UNSPECIFIED
;
1799 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1802 #define FUNC_NAME s_scm_primitive_generic_generic
1804 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1806 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1807 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1808 return *SCM_SUBR_GENERIC (subr
);
1810 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1814 typedef struct t_extension
{
1815 struct t_extension
*next
;
1821 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1823 static const char extension_gc_hint
[] = "GOOPS extension";
1825 static t_extension
*extensions
= 0;
1828 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1833 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1834 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1835 gf
= *SCM_SUBR_GENERIC (extended
);
1836 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1838 SCM_SUBR_NAME (extension
));
1839 SCM_SET_SUBR_GENERIC (extension
, gext
);
1843 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1845 t_extension
**loc
= &extensions
;
1846 /* Make sure that extensions are placed before their own
1847 * extensions in the extensions list. O(N^2) algorithm, but
1848 * extensions of primitive generics are rare.
1850 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1851 loc
= &(*loc
)->next
;
1853 e
->extended
= extended
;
1854 e
->extension
= extension
;
1860 setup_extended_primitive_generics ()
1864 t_extension
*e
= extensions
;
1865 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1866 extensions
= e
->next
;
1870 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1871 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1872 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1876 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1878 if (!SCM_UNPACK (gf
))
1879 scm_error_num_args_subr (subr
);
1881 return scm_call_0 (gf
);
1885 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1887 if (!SCM_UNPACK (gf
))
1888 scm_wrong_type_arg (subr
, pos
, a1
);
1890 return scm_call_1 (gf
, a1
);
1894 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1896 if (!SCM_UNPACK (gf
))
1897 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1899 return scm_call_2 (gf
, a1
, a2
);
1903 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1905 if (!SCM_UNPACK (gf
))
1906 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1908 return scm_apply_0 (gf
, args
);
1911 /******************************************************************************
1913 * Protocol for calling a generic fumction
1914 * This protocol is roughly equivalent to (parameter are a little bit different
1915 * for efficiency reasons):
1917 * + apply-generic (gf args)
1918 * + compute-applicable-methods (gf args ...)
1919 * + sort-applicable-methods (methods args)
1920 * + apply-methods (gf methods args)
1922 * apply-methods calls make-next-method to build the "continuation" of a a
1923 * method. Applying a next-method will call apply-next-method which in
1924 * turn will call apply again to call effectively the following method.
1926 ******************************************************************************/
1929 applicablep (SCM actual
, SCM formal
)
1931 /* We already know that the cpl is well formed. */
1932 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1936 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1938 register SCM s1
, s2
;
1942 * m1 and m2 can have != length (i.e. one can be one element longer than the
1943 * other when we have a dotted parameter list). For instance, with the call
1946 * (define-method M (a . l) ....)
1947 * (define-method M (a) ....)
1949 * we consider that the second method is more specific.
1951 * BTW, targs is an array of types. We don't need it's size since
1952 * we already know that m1 and m2 are applicable (no risk to go past
1953 * the end of this array).
1956 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1957 if (scm_is_null(s1
)) return 1;
1958 if (scm_is_null(s2
)) return 0;
1959 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1960 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1962 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1963 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1965 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1968 return 0;/* should not occur! */
1971 return 0; /* should not occur! */
1974 #define BUFFSIZE 32 /* big enough for most uses */
1977 scm_i_vector2list (SCM l
, long len
)
1980 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1982 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1983 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1989 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1992 SCM
*v
, vector
= SCM_EOL
;
1993 SCM buffer
[BUFFSIZE
];
1994 SCM save
= method_list
;
1995 scm_t_array_handle handle
;
1997 /* For reasonably sized method_lists we can try to avoid all the
1998 * consing and reorder the list in place...
1999 * This idea is due to David McClain <Dave_McClain@msn.com>
2001 if (size
<= BUFFSIZE
)
2003 for (i
= 0; i
< size
; i
++)
2005 buffer
[i
] = SCM_CAR (method_list
);
2006 method_list
= SCM_CDR (method_list
);
2012 /* Too many elements in method_list to keep everything locally */
2013 vector
= scm_i_vector2list (save
, size
);
2014 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2017 /* Use a simple shell sort since it is generally faster than qsort on
2018 * small vectors (which is probably mostly the case when we have to
2019 * sort a list of applicable methods).
2021 for (incr
= size
/ 2; incr
; incr
/= 2)
2023 for (i
= incr
; i
< size
; i
++)
2025 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2027 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2031 SCM tmp
= v
[j
+ incr
];
2039 if (size
<= BUFFSIZE
)
2041 /* We did it in locally, so restore the original list (reordered) in-place */
2042 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2044 SCM_SETCAR (method_list
, *v
);
2045 method_list
= SCM_CDR (method_list
);
2050 /* If we are here, that's that we did it the hard way... */
2051 scm_array_handle_release (&handle
);
2052 return scm_vector_to_list (vector
);
2056 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2060 SCM l
, fl
, applicable
= SCM_EOL
;
2062 SCM buffer
[BUFFSIZE
];
2066 scm_t_array_handle handle
;
2068 /* Build the list of arguments types */
2069 if (len
>= BUFFSIZE
)
2071 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2072 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2075 note that we don't have to work to reset the generation
2076 count. TMP is a new vector anyway, and it is found
2083 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2084 *p
++ = scm_class_of (SCM_CAR (args
));
2086 /* Build a list of all applicable methods */
2087 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2089 fl
= SPEC_OF (SCM_CAR (l
));
2090 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2092 if (SCM_INSTANCEP (fl
)
2093 /* We have a dotted argument list */
2094 || (i
>= len
&& scm_is_null (fl
)))
2095 { /* both list exhausted */
2096 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2102 || !applicablep (types
[i
], SCM_CAR (fl
)))
2107 if (len
>= BUFFSIZE
)
2108 scm_array_handle_release (&handle
);
2114 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2115 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2121 : sort_applicable_methods (applicable
, count
, types
));
2125 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2128 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2131 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2132 #define FUNC_NAME s_sys_compute_applicable_methods
2135 SCM_VALIDATE_GENERIC (1, gf
);
2136 n
= scm_ilength (args
);
2137 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2138 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2142 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2143 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2144 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2145 scm_sys_compute_applicable_methods
));
2147 /******************************************************************************
2149 * A simple make (which will be redefined later in Scheme)
2150 * This version handles only creation of gf, methods and classes (no instances)
2152 * Since this code will disappear when Goops will be fully booted,
2153 * no precaution is taken to be efficient.
2155 ******************************************************************************/
2157 SCM_KEYWORD (k_setter
, "setter");
2158 SCM_KEYWORD (k_specializers
, "specializers");
2159 SCM_KEYWORD (k_procedure
, "procedure");
2160 SCM_KEYWORD (k_formals
, "formals");
2161 SCM_KEYWORD (k_body
, "body");
2162 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2163 SCM_KEYWORD (k_dsupers
, "dsupers");
2164 SCM_KEYWORD (k_slots
, "slots");
2165 SCM_KEYWORD (k_gf
, "generic-function");
2167 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2169 "Make a new object. @var{args} must contain the class and\n"
2170 "all necessary initialization information.")
2171 #define FUNC_NAME s_scm_make
2174 long len
= scm_ilength (args
);
2176 if (len
<= 0 || (len
& 1) == 0)
2177 SCM_WRONG_NUM_ARGS ();
2179 class = SCM_CAR(args
);
2180 args
= SCM_CDR(args
);
2182 if (scm_is_eq (class, scm_class_generic
)
2183 || scm_is_eq (class, scm_class_accessor
))
2185 z
= scm_make_struct (class, SCM_INUM0
,
2186 scm_list_4 (SCM_BOOL_F
,
2190 scm_set_procedure_property_x (z
, scm_sym_name
,
2191 scm_get_keyword (k_name
,
2194 clear_method_cache (z
);
2195 if (scm_is_eq (class, scm_class_accessor
))
2197 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2198 if (scm_is_true (setter
))
2199 scm_sys_set_object_setter_x (z
, setter
);
2204 z
= scm_sys_allocate_instance (class, args
);
2206 if (scm_is_eq (class, scm_class_method
)
2207 || scm_is_eq (class, scm_class_accessor_method
))
2209 SCM_SET_SLOT (z
, scm_si_generic_function
,
2210 scm_i_get_keyword (k_gf
,
2215 SCM_SET_SLOT (z
, scm_si_specializers
,
2216 scm_i_get_keyword (k_specializers
,
2221 SCM_SET_SLOT (z
, scm_si_procedure
,
2222 scm_i_get_keyword (k_procedure
,
2227 SCM_SET_SLOT (z
, scm_si_formals
,
2228 scm_i_get_keyword (k_formals
,
2233 SCM_SET_SLOT (z
, scm_si_body
,
2234 scm_i_get_keyword (k_body
,
2239 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2240 scm_i_get_keyword (k_make_procedure
,
2248 /* In all the others case, make a new class .... No instance here */
2249 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2250 scm_i_get_keyword (k_name
,
2253 scm_from_latin1_symbol ("???"),
2255 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2256 scm_i_get_keyword (k_dsupers
,
2261 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2262 scm_i_get_keyword (k_slots
,
2273 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2276 #define FUNC_NAME s_scm_find_method
2279 long len
= scm_ilength (l
);
2282 SCM_WRONG_NUM_ARGS ();
2284 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2285 SCM_VALIDATE_GENERIC (1, gf
);
2286 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2287 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2289 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2293 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2294 (SCM m1
, SCM m2
, SCM targs
),
2295 "Return true if method @var{m1} is more specific than @var{m2} "
2296 "given the argument types (classes) listed in @var{targs}.")
2297 #define FUNC_NAME s_scm_sys_method_more_specific_p
2301 long i
, len
, m1_specs
, m2_specs
;
2302 scm_t_array_handle handle
;
2304 SCM_VALIDATE_METHOD (1, m1
);
2305 SCM_VALIDATE_METHOD (2, m2
);
2307 len
= scm_ilength (targs
);
2308 m1_specs
= scm_ilength (SPEC_OF (m1
));
2309 m2_specs
= scm_ilength (SPEC_OF (m2
));
2310 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2311 targs
, SCM_ARG3
, FUNC_NAME
);
2313 /* Verify that all the arguments of TARGS are classes and place them
2316 v
= scm_c_make_vector (len
, SCM_EOL
);
2317 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2319 for (i
= 0, l
= targs
;
2320 i
< len
&& scm_is_pair (l
);
2321 i
++, l
= SCM_CDR (l
))
2323 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2324 v_elts
[i
] = SCM_CAR (l
);
2326 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2328 scm_array_handle_release (&handle
);
2336 /******************************************************************************
2340 ******************************************************************************/
2342 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2343 assuming that currently the reverse is true. Recalculate slots and
2344 associated getters-n-setters. */
2346 fix_cpl (SCM c
, SCM before
, SCM after
)
2348 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2349 SCM ls
= scm_c_memq (after
, cpl
);
2352 if (scm_is_false (ls
))
2353 /* if this condition occurs, fix_cpl should not be applied this way */
2356 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2357 SCM_SETCAR (ls
, before
);
2358 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2360 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2361 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2362 SCM g_n_s
= compute_getters_n_setters (slots
);
2363 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2364 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2370 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2372 SCM tmp
= scm_from_utf8_symbol (name
);
2374 *var
= scm_basic_make_class (meta
, tmp
,
2375 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2377 scm_module_define (scm_module_goops
, tmp
, *var
);
2381 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2384 create_standard_classes (void)
2387 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2388 scm_from_latin1_symbol ("specializers"),
2390 scm_from_latin1_symbol ("formals"),
2391 scm_from_latin1_symbol ("body"),
2392 scm_from_latin1_symbol ("make-procedure"),
2394 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2396 k_slot_definition
));
2397 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2398 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2401 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2404 scm_from_latin1_symbol ("effective-methods"));
2405 SCM setter_slots
= scm_list_1 (sym_setter
);
2406 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2409 /* Foreign class slot classes */
2410 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2411 scm_class_class
, scm_class_top
, SCM_EOL
);
2412 make_stdcls (&scm_class_protected
, "<protected-slot>",
2413 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2414 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2415 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2416 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2417 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2418 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2419 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2420 make_stdcls (&scm_class_self
, "<self-slot>",
2421 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2422 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2424 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2426 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2428 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2430 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2432 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2434 make_stdcls (&scm_class_scm
, "<scm-slot>",
2435 scm_class_class
, scm_class_protected
, SCM_EOL
);
2436 make_stdcls (&scm_class_int
, "<int-slot>",
2437 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2438 make_stdcls (&scm_class_float
, "<float-slot>",
2439 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2440 make_stdcls (&scm_class_double
, "<double-slot>",
2441 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2443 /* Continue initialization of class <class> */
2445 slots
= build_class_class_slots ();
2446 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2447 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2448 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2449 compute_getters_n_setters (slots
));
2451 /* scm_class_generic functions classes */
2452 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2453 scm_class_class
, scm_class_class
, SCM_EOL
);
2454 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2455 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2456 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2457 make_stdcls (&scm_class_method
, "<method>",
2458 scm_class_class
, scm_class_object
, method_slots
);
2459 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2460 scm_class_class
, scm_class_method
, amethod_slots
);
2461 make_stdcls (&scm_class_applicable
, "<applicable>",
2462 scm_class_class
, scm_class_top
, SCM_EOL
);
2463 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2464 scm_class_applicable_struct_class
,
2465 scm_list_2 (scm_class_object
, scm_class_applicable
),
2466 scm_list_1 (sym_procedure
));
2467 make_stdcls (&scm_class_generic
, "<generic>",
2468 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2469 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2470 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2471 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2472 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2473 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2474 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2475 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2476 make_stdcls (&scm_class_accessor
, "<accessor>",
2477 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2478 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2479 make_stdcls (&scm_class_extended_generic_with_setter
,
2480 "<extended-generic-with-setter>",
2481 scm_class_applicable_struct_class
,
2482 scm_list_2 (scm_class_extended_generic
,
2483 scm_class_generic_with_setter
),
2485 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2486 SCM_CLASSF_PURE_GENERIC
);
2487 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2488 scm_class_applicable_struct_class
,
2489 scm_list_2 (scm_class_accessor
,
2490 scm_class_extended_generic_with_setter
),
2492 /* <extended-generic> is misplaced. */
2493 fix_cpl (scm_class_extended_accessor
,
2494 scm_class_extended_generic
, scm_class_generic_with_setter
);
2495 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2497 /* Primitive types classes */
2498 make_stdcls (&scm_class_boolean
, "<boolean>",
2499 scm_class_class
, scm_class_top
, SCM_EOL
);
2500 make_stdcls (&scm_class_char
, "<char>",
2501 scm_class_class
, scm_class_top
, SCM_EOL
);
2502 make_stdcls (&scm_class_list
, "<list>",
2503 scm_class_class
, scm_class_top
, SCM_EOL
);
2504 make_stdcls (&scm_class_pair
, "<pair>",
2505 scm_class_class
, scm_class_list
, SCM_EOL
);
2506 make_stdcls (&scm_class_null
, "<null>",
2507 scm_class_class
, scm_class_list
, SCM_EOL
);
2508 make_stdcls (&scm_class_string
, "<string>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&scm_class_symbol
, "<symbol>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&scm_class_vector
, "<vector>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_foreign
, "<foreign>",
2515 scm_class_class
, scm_class_top
, SCM_EOL
);
2516 make_stdcls (&class_hashtable
, "<hashtable>",
2517 scm_class_class
, scm_class_top
, SCM_EOL
);
2518 make_stdcls (&class_fluid
, "<fluid>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2521 scm_class_class
, scm_class_top
, SCM_EOL
);
2522 make_stdcls (&class_frame
, "<frame>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&class_objcode
, "<objcode>",
2525 scm_class_class
, scm_class_top
, SCM_EOL
);
2526 make_stdcls (&class_vm
, "<vm>",
2527 scm_class_class
, scm_class_top
, SCM_EOL
);
2528 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2529 scm_class_class
, scm_class_top
, SCM_EOL
);
2530 make_stdcls (&class_bytevector
, "<bytevector>",
2531 scm_class_class
, scm_class_top
, SCM_EOL
);
2532 make_stdcls (&class_uvec
, "<uvec>",
2533 scm_class_class
, class_bytevector
, SCM_EOL
);
2534 make_stdcls (&class_array
, "<array>",
2535 scm_class_class
, scm_class_top
, SCM_EOL
);
2536 make_stdcls (&class_bitvector
, "<bitvector>",
2537 scm_class_class
, scm_class_top
, SCM_EOL
);
2538 make_stdcls (&scm_class_number
, "<number>",
2539 scm_class_class
, scm_class_top
, SCM_EOL
);
2540 make_stdcls (&scm_class_complex
, "<complex>",
2541 scm_class_class
, scm_class_number
, SCM_EOL
);
2542 make_stdcls (&scm_class_real
, "<real>",
2543 scm_class_class
, scm_class_complex
, SCM_EOL
);
2544 make_stdcls (&scm_class_integer
, "<integer>",
2545 scm_class_class
, scm_class_real
, SCM_EOL
);
2546 make_stdcls (&scm_class_fraction
, "<fraction>",
2547 scm_class_class
, scm_class_real
, SCM_EOL
);
2548 make_stdcls (&scm_class_keyword
, "<keyword>",
2549 scm_class_class
, scm_class_top
, SCM_EOL
);
2550 make_stdcls (&scm_class_unknown
, "<unknown>",
2551 scm_class_class
, scm_class_top
, SCM_EOL
);
2552 make_stdcls (&scm_class_procedure
, "<procedure>",
2553 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2554 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2555 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2556 make_stdcls (&scm_class_port
, "<port>",
2557 scm_class_class
, scm_class_top
, SCM_EOL
);
2558 make_stdcls (&scm_class_input_port
, "<input-port>",
2559 scm_class_class
, scm_class_port
, SCM_EOL
);
2560 make_stdcls (&scm_class_output_port
, "<output-port>",
2561 scm_class_class
, scm_class_port
, SCM_EOL
);
2562 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2564 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2568 /**********************************************************************
2572 **********************************************************************/
2575 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2581 sprintf (buffer
, template, type_name
);
2582 name
= scm_from_utf8_symbol (buffer
);
2585 name
= SCM_GOOPS_UNBOUND
;
2587 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2588 name
, supers
, SCM_EOL
);
2592 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2596 if (scm_is_true (type_name_sym
))
2598 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2599 scm_symbol_to_string (type_name_sym
),
2600 scm_from_locale_string (">")));
2601 name
= scm_string_to_symbol (name
);
2604 name
= SCM_GOOPS_UNBOUND
;
2606 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2607 name
, supers
, SCM_EOL
);
2611 scm_make_extended_class (char const *type_name
, int applicablep
)
2613 return make_class_from_template ("<%s>",
2615 scm_list_1 (applicablep
2616 ? scm_class_applicable
2622 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2624 return make_class_from_symbol (type_name_sym
,
2625 scm_list_1 (applicablep
2626 ? scm_class_applicable
2632 scm_i_inherit_applicable (SCM c
)
2634 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2636 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2637 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2638 /* patch scm_class_applicable into direct-supers */
2639 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2640 if (scm_is_false (top
))
2641 dsupers
= scm_append (scm_list_2 (dsupers
,
2642 scm_list_1 (scm_class_applicable
)));
2645 SCM_SETCAR (top
, scm_class_applicable
);
2646 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2648 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2649 /* patch scm_class_applicable into cpl */
2650 top
= scm_c_memq (scm_class_top
, cpl
);
2651 if (scm_is_false (top
))
2655 SCM_SETCAR (top
, scm_class_applicable
);
2656 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2658 /* add class to direct-subclasses of scm_class_applicable */
2659 SCM_SET_SLOT (scm_class_applicable
,
2660 scm_si_direct_subclasses
,
2661 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2662 scm_si_direct_subclasses
)));
2667 create_smob_classes (void)
2671 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2672 scm_smob_class
[i
] = SCM_BOOL_F
;
2674 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2676 for (i
= 0; i
< scm_numsmob
; ++i
)
2677 if (scm_is_false (scm_smob_class
[i
]))
2678 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2679 scm_smobs
[i
].apply
!= 0);
2683 scm_make_port_classes (long ptobnum
, char *type_name
)
2685 SCM c
, class = make_class_from_template ("<%s-port>",
2687 scm_list_1 (scm_class_port
),
2689 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2690 = make_class_from_template ("<%s-input-port>",
2692 scm_list_2 (class, scm_class_input_port
),
2694 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2695 = make_class_from_template ("<%s-output-port>",
2697 scm_list_2 (class, scm_class_output_port
),
2699 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2701 = make_class_from_template ("<%s-input-output-port>",
2703 scm_list_2 (class, scm_class_input_output_port
),
2705 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2706 SCM_SET_SLOT (c
, scm_si_cpl
,
2707 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2711 create_port_classes (void)
2715 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2716 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2720 make_struct_class (void *closure SCM_UNUSED
,
2721 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2723 if (scm_is_false (data
))
2724 scm_i_define_class_for_vtable (vtable
);
2725 return SCM_UNSPECIFIED
;
2729 create_struct_classes (void)
2731 /* FIXME: take the vtable_class_map while initializing goops? */
2732 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2736 /**********************************************************************
2740 **********************************************************************/
2745 if (!goops_loaded_p
)
2746 scm_c_resolve_module ("oop goops");
2750 SCM_SYMBOL (sym_o
, "o");
2751 SCM_SYMBOL (sym_x
, "x");
2753 SCM_KEYWORD (k_accessor
, "accessor");
2754 SCM_KEYWORD (k_getter
, "getter");
2757 scm_ensure_accessor (SCM name
)
2761 var
= scm_module_variable (scm_current_module (), name
);
2762 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2763 gf
= SCM_VARIABLE_REF (var
);
2767 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2769 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2770 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2771 k_name
, name
, k_setter
, gf
));
2779 * Debugging utilities
2782 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2784 "Return @code{#t} if @var{obj} is a pure generic.")
2785 #define FUNC_NAME s_scm_pure_generic_p
2787 return scm_from_bool (SCM_PUREGENERICP (obj
));
2791 #endif /* GUILE_DEBUG */
2797 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2799 "Announce that GOOPS is loaded and perform initialization\n"
2800 "on the C level which depends on the loaded GOOPS modules.")
2801 #define FUNC_NAME s_scm_sys_goops_loaded
2804 var_compute_applicable_methods
=
2805 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2807 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2809 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2811 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2812 var_no_applicable_method
=
2813 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2815 scm_module_variable (scm_module_goops
, sym_change_class
);
2816 setup_extended_primitive_generics ();
2817 return SCM_UNSPECIFIED
;
2821 SCM scm_module_goops
;
2824 scm_init_goops_builtins (void)
2826 scm_module_goops
= scm_current_module ();
2828 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2830 #include "libguile/goops.x"
2832 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2833 hell_mutex
= scm_make_mutex ();
2835 create_basic_classes ();
2836 create_standard_classes ();
2837 create_smob_classes ();
2838 create_struct_classes ();
2839 create_port_classes ();
2842 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2843 scm_no_applicable_method
=
2844 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2845 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2848 return SCM_UNSPECIFIED
;
2854 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2855 scm_init_goops_builtins
);