1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014,2015
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/weaks.h"
57 #include "libguile/vm.h"
59 #include "libguile/validate.h"
60 #include "libguile/goops.h"
62 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
65 #define SCM_IN_PCLASS_INDEX 0
66 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
67 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
69 /* this file is a mess. in theory, though, we shouldn't have many SCM references
70 -- most of the references should be to vars. */
72 static SCM var_slot_unbound
= SCM_BOOL_F
;
73 static SCM var_slot_missing
= SCM_BOOL_F
;
74 static SCM var_compute_cpl
= SCM_BOOL_F
;
75 static SCM var_no_applicable_method
= SCM_BOOL_F
;
76 static SCM var_change_class
= SCM_BOOL_F
;
78 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
79 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
80 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
81 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
82 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
83 SCM_SYMBOL (sym_change_class
, "change-class");
85 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
88 /* FIXME, exports should come from the scm file only */
89 #define DEFVAR(v, val) \
90 { scm_module_define (scm_module_goops, (v), (val)); \
91 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
95 /* Class redefinition protocol:
97 A class is represented by a heap header h1 which points to a
98 malloc:ed memory block m1.
100 When a new version of a class is created, a new header h2 and
101 memory block m2 are allocated. The headers h1 and h2 then switch
102 pointers so that h1 refers to m2 and h2 to m1. In this way, names
103 bound to h1 will point to the new class at the same time as h2 will
104 be a handle which the GC will use to free m1.
106 The `redefined' slot of m1 will be set to point to h1. An old
107 instance will have its class pointer (the CAR of the heap header)
108 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
109 the class modification and the new class pointer can be found via
113 #define TEST_CHANGE_CLASS(obj, class) \
115 class = SCM_CLASS_OF (obj); \
116 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
118 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
119 class = SCM_CLASS_OF (obj); \
123 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
124 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
126 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
127 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
129 static int goops_loaded_p
= 0;
130 static scm_t_rstate
*goops_rstate
;
132 /* These variables are filled in by the object system when loaded. */
133 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
134 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
135 SCM scm_class_primitive_generic
;
136 SCM scm_class_vector
, scm_class_null
;
137 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
138 SCM scm_class_unknown
;
139 SCM scm_class_top
, scm_class_object
, scm_class_class
;
140 SCM scm_class_applicable
;
141 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
142 SCM scm_class_generic
, scm_class_generic_with_setter
;
143 SCM scm_class_accessor
;
144 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
145 SCM scm_class_extended_accessor
;
146 SCM scm_class_method
;
147 SCM scm_class_accessor_method
;
148 SCM scm_class_procedure_class
;
149 SCM scm_class_applicable_struct_class
;
150 SCM scm_class_number
, scm_class_list
;
151 SCM scm_class_keyword
;
152 SCM scm_class_port
, scm_class_input_output_port
;
153 SCM scm_class_input_port
, scm_class_output_port
;
154 SCM scm_class_foreign_slot
;
155 SCM scm_class_self
, scm_class_protected
;
156 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
157 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
159 SCM scm_class_int
, scm_class_float
, scm_class_double
;
161 static SCM class_foreign
;
162 static SCM class_hashtable
;
163 static SCM class_fluid
;
164 static SCM class_dynamic_state
;
165 static SCM class_frame
;
166 static SCM class_objcode
;
168 static SCM class_vm_cont
;
169 static SCM class_bytevector
;
170 static SCM class_uvec
;
171 static SCM class_array
;
172 static SCM class_bitvector
;
174 static SCM vtable_class_map
= SCM_BOOL_F
;
175 static scm_i_pthread_mutex_t vtable_class_map_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
177 /* Port classes. Allocate 3 times the maximum number of port types so that
178 input ports, output ports, and in/out ports can be stored at different
179 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
180 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
183 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
185 SCM scm_no_applicable_method
;
187 SCM_SYMBOL (scm_sym_define_public
, "define-public");
189 static SCM
scm_make_unbound (void);
190 static SCM
scm_unbound_p (SCM obj
);
191 static SCM
scm_assert_bound (SCM value
, SCM obj
);
192 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
193 static SCM
scm_sys_goops_loaded (void);
194 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
199 scm_i_define_class_for_vtable (SCM vtable
)
203 scm_i_pthread_mutex_lock (&vtable_class_map_lock
);
205 if (scm_is_false (vtable_class_map
))
206 vtable_class_map
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
208 if (scm_is_false (scm_struct_vtable_p (vtable
)))
211 class = scm_hashq_ref (vtable_class_map
, vtable
, SCM_BOOL_F
);
213 scm_i_pthread_mutex_unlock (&vtable_class_map_lock
);
215 if (scm_is_false (class))
217 if (SCM_UNPACK (scm_class_class
))
219 SCM name
= SCM_VTABLE_NAME (vtable
);
220 if (!scm_is_symbol (name
))
221 name
= scm_string_to_symbol (scm_nullstr
);
223 class = scm_make_extended_class_from_symbol
224 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
227 /* `create_struct_classes' will fill this in later. */
230 /* Don't worry about races. This only happens when creating a
231 vtable, which happens by definition in one thread. */
232 scm_i_pthread_mutex_lock (&vtable_class_map_lock
);
233 scm_hashq_set_x (vtable_class_map
, vtable
, class);
234 scm_i_pthread_mutex_unlock (&vtable_class_map_lock
);
240 /* This function is used for efficient type dispatch. */
241 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
243 "Return the class of @var{x}.")
244 #define FUNC_NAME s_scm_class_of
246 switch (SCM_ITAG3 (x
))
250 return scm_class_integer
;
254 return scm_class_char
;
255 else if (scm_is_bool (x
))
256 return scm_class_boolean
;
257 else if (scm_is_null (x
))
258 return scm_class_null
;
260 return scm_class_unknown
;
263 switch (SCM_TYP7 (x
))
265 case scm_tcs_cons_nimcar
:
266 return scm_class_pair
;
268 return scm_class_symbol
;
271 return scm_class_vector
;
272 case scm_tc7_pointer
:
273 return class_foreign
;
274 case scm_tc7_hashtable
:
275 return class_hashtable
;
278 case scm_tc7_dynamic_state
:
279 return class_dynamic_state
;
282 case scm_tc7_objcode
:
283 return class_objcode
;
286 case scm_tc7_vm_cont
:
287 return class_vm_cont
;
288 case scm_tc7_bytevector
:
289 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
290 return class_bytevector
;
295 case scm_tc7_bitvector
:
296 return class_bitvector
;
298 return scm_class_string
;
300 switch SCM_TYP16 (x
) {
302 return scm_class_integer
;
304 return scm_class_real
;
305 case scm_tc16_complex
:
306 return scm_class_complex
;
307 case scm_tc16_fraction
:
308 return scm_class_fraction
;
310 case scm_tc7_program
:
311 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
312 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
313 return scm_class_primitive_generic
;
315 return scm_class_procedure
;
319 scm_t_bits type
= SCM_TYP16 (x
);
320 if (type
!= scm_tc16_port_with_ps
)
321 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
322 x
= SCM_PORT_WITH_PS_PORT (x
);
323 /* fall through to ports */
326 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
327 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
328 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
329 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
330 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
332 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
333 return SCM_CLASS_OF (x
);
334 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
337 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
338 scm_change_object_class (x
,
339 SCM_CLASS_OF (x
), /* old */
340 SCM_OBJ_CLASS_REDEF (x
)); /* new */
341 return SCM_CLASS_OF (x
);
344 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
347 return scm_class_pair
;
349 return scm_class_unknown
;
355 /* case scm_tc3_unused: */
359 return scm_class_unknown
;
363 /******************************************************************************
367 * This version doesn't fully handle multiple-inheritance. It serves
368 * only for booting classes and will be overloaded in Scheme
370 ******************************************************************************/
373 map (SCM (*proc
) (SCM
), SCM ls
)
375 if (scm_is_null (ls
))
379 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
382 while (scm_is_pair (ls
))
384 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
396 while (scm_is_pair (ls
))
398 SCM el
= SCM_CAR (ls
);
399 if (scm_is_false (scm_c_memq (el
, res
)))
400 res
= scm_cons (el
, res
);
407 compute_cpl (SCM
class)
410 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
413 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
414 SCM ls
= scm_append (scm_acons (class, supers
,
415 map (compute_cpl
, supers
)));
416 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
420 /******************************************************************************
424 ******************************************************************************/
427 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
431 if (!scm_is_pair (l
))
435 if (!scm_is_symbol (tmp
))
436 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
438 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
439 res
= scm_cons (SCM_CAR (l
), res
);
440 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
443 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
447 check_cpl (SCM slots
, SCM bslots
)
449 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
450 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
451 scm_misc_error ("init-object", "a predefined <class> inherited "
452 "field cannot be redefined", SCM_EOL
);
456 build_class_class_slots (void);
459 build_slots_list (SCM dslots
, SCM cpl
)
461 SCM bslots
, class_slots
;
465 class_slots
= SCM_EOL
;
466 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
470 bslots
= build_class_class_slots ();
471 check_cpl (res
, bslots
);
476 if (scm_is_pair (cpl
))
478 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
480 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
481 scm_si_direct_slots
);
484 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
485 check_cpl (new_slots
, bslots
);
488 /* Move class slots to the head of the list. */
489 class_slots
= new_slots
;
493 res
= scm_append (scm_list_2 (new_slots
, res
));
497 scm_misc_error ("%compute-slots", "malformed cpl argument in "
498 "build_slots_list", SCM_EOL
);
500 /* make sure to add the <class> slots to the head of the list */
502 res
= scm_append (scm_list_2 (class_slots
, res
));
504 /* res contains a list of slots. Remove slots which appears more than once */
505 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
512 while (!scm_is_null (ls
))
514 if (!scm_is_pair (ls
))
515 scm_misc_error ("%compute-slots", "malformed ls argument in "
517 if (!scm_is_pair (SCM_CAR (ls
)))
518 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
525 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
527 "Return a list consisting of the names of all slots belonging to\n"
528 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
530 #define FUNC_NAME s_scm_sys_compute_slots
532 SCM_VALIDATE_CLASS (1, class);
533 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
534 SCM_SLOT (class, scm_si_cpl
));
539 /******************************************************************************
541 * compute-getters-n-setters
543 * This version doesn't handle slot options. It serves only for booting
544 * classes and will be overloaded in Scheme.
546 ******************************************************************************/
548 SCM_KEYWORD (k_init_value
, "init-value");
549 SCM_KEYWORD (k_init_thunk
, "init-thunk");
552 compute_getters_n_setters (SCM slots
)
558 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
560 SCM init
= SCM_BOOL_F
;
561 SCM options
= SCM_CDAR (slots
);
562 if (!scm_is_null (options
))
564 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
565 if (SCM_UNPACK (init
))
567 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
569 scm_list_2 (scm_sym_quote
,
573 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
575 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
577 scm_from_int (i
++))),
579 cdrloc
= SCM_CDRLOC (*cdrloc
);
584 /******************************************************************************
588 ******************************************************************************/
590 /*fixme* Manufacture keywords in advance */
592 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
596 for (i
= 0; i
!= len
; i
+= 2)
598 SCM obj
= SCM_CAR (l
);
600 if (!scm_is_keyword (obj
))
601 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
602 else if (scm_is_eq (obj
, key
))
608 return default_value
;
612 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
613 (SCM key
, SCM l
, SCM default_value
),
614 "Determine an associated value for the keyword @var{key} from\n"
615 "the list @var{l}. The list @var{l} has to consist of an even\n"
616 "number of elements, where, starting with the first, every\n"
617 "second element is a keyword, followed by its associated value.\n"
618 "If @var{l} does not hold a value for @var{key}, the value\n"
619 "@var{default_value} is returned.")
620 #define FUNC_NAME s_scm_get_keyword
624 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
625 len
= scm_ilength (l
);
626 if (len
< 0 || len
% 2 == 1)
627 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
629 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
634 SCM_KEYWORD (k_init_keyword
, "init-keyword");
636 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
637 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
639 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
640 (SCM obj
, SCM initargs
),
641 "Initialize the object @var{obj} with the given arguments\n"
643 #define FUNC_NAME s_scm_sys_initialize_object
645 SCM tmp
, get_n_set
, slots
;
646 SCM
class = SCM_CLASS_OF (obj
);
649 SCM_VALIDATE_INSTANCE (1, obj
);
650 n_initargs
= scm_ilength (initargs
);
651 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
653 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
654 slots
= SCM_SLOT (class, scm_si_slots
);
656 /* See for each slot how it must be initialized */
658 !scm_is_null (slots
);
659 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
661 SCM slot_name
= SCM_CAR (slots
);
662 SCM slot_value
= SCM_GOOPS_UNBOUND
;
664 if (!scm_is_null (SCM_CDR (slot_name
)))
666 /* This slot admits (perhaps) to be initialized at creation time */
667 long n
= scm_ilength (SCM_CDR (slot_name
));
668 if (n
& 1) /* odd or -1 */
669 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
670 scm_list_1 (slot_name
));
671 tmp
= scm_i_get_keyword (k_init_keyword
,
676 slot_name
= SCM_CAR (slot_name
);
677 if (SCM_UNPACK (tmp
))
679 /* an initarg was provided for this slot */
680 if (!scm_is_keyword (tmp
))
681 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
683 slot_value
= scm_i_get_keyword (tmp
,
691 if (!SCM_GOOPS_UNBOUNDP (slot_value
))
692 /* set slot to provided value */
693 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
696 /* set slot to its :init-form if it exists */
697 tmp
= SCM_CADAR (get_n_set
);
698 if (scm_is_true (tmp
))
699 set_slot_value (class,
710 /* NOTE: The following macros are interdependent with code
711 * in goops.scm:compute-getters-n-setters
713 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
714 (SCM_I_INUMP (SCM_CDDR (gns)) \
715 || (scm_is_pair (SCM_CDDR (gns)) \
716 && scm_is_pair (SCM_CDDDR (gns)) \
717 && scm_is_pair (SCM_CDDDDR (gns))))
718 #define SCM_GNS_INDEX(gns) \
719 (SCM_I_INUMP (SCM_CDDR (gns)) \
720 ? SCM_I_INUM (SCM_CDDR (gns)) \
721 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
722 #define SCM_GNS_SIZE(gns) \
723 (SCM_I_INUMP (SCM_CDDR (gns)) \
725 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
727 SCM_KEYWORD (k_class
, "class");
728 SCM_KEYWORD (k_allocation
, "allocation");
729 SCM_KEYWORD (k_instance
, "instance");
731 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
734 #define FUNC_NAME s_scm_sys_prep_layout_x
736 SCM slots
, getters_n_setters
, nfields
;
737 unsigned long int n
, i
;
741 SCM_VALIDATE_INSTANCE (1, class);
742 slots
= SCM_SLOT (class, scm_si_slots
);
743 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
744 nfields
= SCM_SLOT (class, scm_si_nfields
);
745 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
746 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
747 scm_list_1 (nfields
));
748 n
= 2 * SCM_I_INUM (nfields
);
749 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
750 && SCM_SUBCLASSP (class, scm_class_class
))
751 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
752 scm_list_1 (nfields
));
754 layout
= scm_i_make_string (n
, &s
, 0);
756 while (scm_is_pair (getters_n_setters
))
758 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
761 int len
, index
, size
;
764 if (i
>= n
|| !scm_is_pair (slots
))
767 /* extract slot type */
768 len
= scm_ilength (SCM_CDAR (slots
));
769 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
770 len
, SCM_BOOL_F
, FUNC_NAME
);
771 /* determine slot GC protection and access mode */
772 if (scm_is_false (type
))
779 if (!SCM_CLASSP (type
))
780 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
781 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
783 if (SCM_SUBCLASSP (type
, scm_class_self
))
785 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
790 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
792 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
794 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
806 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
807 if (index
!= (i
>> 1))
809 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
817 slots
= SCM_CDR (slots
);
818 getters_n_setters
= SCM_CDR (getters_n_setters
);
820 if (!scm_is_null (slots
))
823 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
825 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
826 return SCM_UNSPECIFIED
;
830 static void prep_hashsets (SCM
);
832 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
833 (SCM
class, SCM dsupers
),
835 #define FUNC_NAME s_scm_sys_inherit_magic_x
837 SCM_VALIDATE_INSTANCE (1, class);
838 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
839 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
841 prep_hashsets (class);
843 return SCM_UNSPECIFIED
;
848 prep_hashsets (SCM
class)
852 for (i
= 0; i
< 8; ++i
)
853 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
856 /******************************************************************************/
859 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
861 SCM z
, cpl
, slots
, nfields
, g_n_s
;
863 /* Allocate one instance */
864 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
866 /* Initialize its slots */
867 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
868 cpl
= compute_cpl (z
);
869 slots
= build_slots_list (maplist (dslots
), cpl
);
870 nfields
= scm_from_int (scm_ilength (slots
));
871 g_n_s
= compute_getters_n_setters (slots
);
873 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
874 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
875 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
876 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
877 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
878 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
879 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
880 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
881 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
883 /* Add this class in the direct-subclasses slot of dsupers */
886 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
887 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
888 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
889 scm_si_direct_subclasses
)));
896 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
898 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
899 scm_sys_prep_layout_x (z
);
900 scm_sys_inherit_magic_x (z
, dsupers
);
904 /******************************************************************************/
906 SCM_SYMBOL (sym_layout
, "layout");
907 SCM_SYMBOL (sym_flags
, "flags");
908 SCM_SYMBOL (sym_self
, "%self");
909 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
910 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
911 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
912 SCM_SYMBOL (sym_print
, "print");
913 SCM_SYMBOL (sym_procedure
, "procedure");
914 SCM_SYMBOL (sym_setter
, "setter");
915 SCM_SYMBOL (sym_redefined
, "redefined");
916 SCM_SYMBOL (sym_h0
, "h0");
917 SCM_SYMBOL (sym_h1
, "h1");
918 SCM_SYMBOL (sym_h2
, "h2");
919 SCM_SYMBOL (sym_h3
, "h3");
920 SCM_SYMBOL (sym_h4
, "h4");
921 SCM_SYMBOL (sym_h5
, "h5");
922 SCM_SYMBOL (sym_h6
, "h6");
923 SCM_SYMBOL (sym_h7
, "h7");
924 SCM_SYMBOL (sym_name
, "name");
925 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
926 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
927 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
928 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
929 SCM_SYMBOL (sym_cpl
, "cpl");
930 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
931 SCM_SYMBOL (sym_slots
, "slots");
932 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
933 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
934 SCM_SYMBOL (sym_nfields
, "nfields");
938 build_class_class_slots (void)
940 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
941 SCM_CLASS_CLASS_LAYOUT */
943 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
944 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
945 scm_list_3 (sym_self
, k_class
, scm_class_self
),
946 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
947 scm_list_1 (sym_print
),
948 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
949 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
950 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
951 scm_list_1 (sym_redefined
),
952 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
953 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
954 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
955 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
956 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
957 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
958 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
959 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
960 scm_list_1 (sym_direct_supers
),
961 scm_list_1 (sym_direct_slots
),
962 scm_list_1 (sym_direct_subclasses
),
963 scm_list_1 (sym_direct_methods
),
964 scm_list_1 (sym_cpl
),
965 scm_list_1 (sym_default_slot_definition_class
),
966 scm_list_1 (sym_slots
),
967 scm_list_1 (sym_getters_n_setters
),
968 scm_list_1 (sym_keyword_access
),
969 scm_list_1 (sym_nfields
),
974 create_basic_classes (void)
976 /* SCM slots_of_class = build_class_class_slots (); */
979 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
980 SCM name
= scm_from_latin1_symbol ("<class>");
981 scm_class_class
= scm_i_make_vtable_vtable (cs
);
982 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
983 | SCM_CLASSF_METACLASS
));
985 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
986 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
987 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
988 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
989 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
990 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
991 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
992 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
993 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
994 compute_getters_n_setters (slots_of_class)); */
995 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
997 prep_hashsets (scm_class_class
);
999 DEFVAR(name
, scm_class_class
);
1002 name
= scm_from_latin1_symbol ("<top>");
1003 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
1006 DEFVAR(name
, scm_class_top
);
1008 /**** <object> ****/
1009 name
= scm_from_latin1_symbol ("<object>");
1010 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
1011 scm_list_1 (scm_class_top
), SCM_EOL
);
1013 DEFVAR (name
, scm_class_object
);
1015 /* <top> <object> and <class> were partially initialized. Correct them here */
1016 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1018 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1019 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1022 /******************************************************************************/
1024 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1026 "Return @code{#t} if @var{obj} is an instance.")
1027 #define FUNC_NAME s_scm_instance_p
1029 return scm_from_bool (SCM_INSTANCEP (obj
));
1034 /******************************************************************************
1036 * Meta object accessors
1038 ******************************************************************************/
1039 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1041 "Return the class name of @var{obj}.")
1042 #define FUNC_NAME s_scm_class_name
1044 SCM_VALIDATE_CLASS (1, obj
);
1045 return scm_slot_ref (obj
, sym_name
);
1049 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1051 "Return the direct superclasses of the class @var{obj}.")
1052 #define FUNC_NAME s_scm_class_direct_supers
1054 SCM_VALIDATE_CLASS (1, obj
);
1055 return scm_slot_ref (obj
, sym_direct_supers
);
1059 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1061 "Return the direct slots of the class @var{obj}.")
1062 #define FUNC_NAME s_scm_class_direct_slots
1064 SCM_VALIDATE_CLASS (1, obj
);
1065 return scm_slot_ref (obj
, sym_direct_slots
);
1069 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1071 "Return the direct subclasses of the class @var{obj}.")
1072 #define FUNC_NAME s_scm_class_direct_subclasses
1074 SCM_VALIDATE_CLASS (1, obj
);
1075 return scm_slot_ref(obj
, sym_direct_subclasses
);
1079 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1081 "Return the direct methods of the class @var{obj}")
1082 #define FUNC_NAME s_scm_class_direct_methods
1084 SCM_VALIDATE_CLASS (1, obj
);
1085 return scm_slot_ref (obj
, sym_direct_methods
);
1089 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1091 "Return the class precedence list of the class @var{obj}.")
1092 #define FUNC_NAME s_scm_class_precedence_list
1094 SCM_VALIDATE_CLASS (1, obj
);
1095 return scm_slot_ref (obj
, sym_cpl
);
1099 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1101 "Return the slot list of the class @var{obj}.")
1102 #define FUNC_NAME s_scm_class_slots
1104 SCM_VALIDATE_CLASS (1, obj
);
1105 return scm_slot_ref (obj
, sym_slots
);
1109 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1111 "Return the name of the generic function @var{obj}.")
1112 #define FUNC_NAME s_scm_generic_function_name
1114 SCM_VALIDATE_GENERIC (1, obj
);
1115 return scm_procedure_property (obj
, scm_sym_name
);
1119 SCM_SYMBOL (sym_methods
, "methods");
1120 SCM_SYMBOL (sym_extended_by
, "extended-by");
1121 SCM_SYMBOL (sym_extends
, "extends");
1124 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1126 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1127 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1128 while (!scm_is_null (gfs
))
1130 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1131 gfs
= SCM_CDR (gfs
);
1133 return method_lists
;
1137 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1139 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1141 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1142 while (!scm_is_null (gfs
))
1144 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1145 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1148 gfs
= SCM_CDR (gfs
);
1151 return method_lists
;
1154 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1156 "Return the methods of the generic function @var{obj}.")
1157 #define FUNC_NAME s_scm_generic_function_methods
1160 SCM_VALIDATE_GENERIC (1, obj
);
1161 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1162 methods
= fold_downward_gf_methods (methods
, obj
);
1163 return scm_append (methods
);
1167 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1169 "Return the generic function for the method @var{obj}.")
1170 #define FUNC_NAME s_scm_method_generic_function
1172 SCM_VALIDATE_METHOD (1, obj
);
1173 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1177 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1179 "Return specializers of the method @var{obj}.")
1180 #define FUNC_NAME s_scm_method_specializers
1182 SCM_VALIDATE_METHOD (1, obj
);
1183 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1187 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1189 "Return the procedure of the method @var{obj}.")
1190 #define FUNC_NAME s_scm_method_procedure
1192 SCM_VALIDATE_METHOD (1, obj
);
1193 return scm_slot_ref (obj
, sym_procedure
);
1197 /******************************************************************************
1199 * S l o t a c c e s s
1201 ******************************************************************************/
1203 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1205 "Return the unbound value.")
1206 #define FUNC_NAME s_scm_make_unbound
1208 return SCM_GOOPS_UNBOUND
;
1212 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1214 "Return @code{#t} if @var{obj} is unbound.")
1215 #define FUNC_NAME s_scm_unbound_p
1217 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1221 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1222 (SCM value
, SCM obj
),
1223 "Return @var{value} if it is bound, and invoke the\n"
1224 "@var{slot-unbound} method of @var{obj} if it is not.")
1225 #define FUNC_NAME s_scm_assert_bound
1227 if (SCM_GOOPS_UNBOUNDP (value
))
1228 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1233 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1234 (SCM obj
, SCM index
),
1235 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1236 "the value from @var{obj}.")
1237 #define FUNC_NAME s_scm_at_assert_bound_ref
1239 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1240 if (SCM_GOOPS_UNBOUNDP (value
))
1241 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1246 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1247 (SCM obj
, SCM index
),
1248 "Return the slot value with index @var{index} from @var{obj}.")
1249 #define FUNC_NAME s_scm_sys_fast_slot_ref
1253 SCM_VALIDATE_INSTANCE (1, obj
);
1254 i
= scm_to_unsigned_integer (index
, 0,
1255 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1258 return SCM_SLOT (obj
, i
);
1262 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1263 (SCM obj
, SCM index
, SCM value
),
1264 "Set the slot with index @var{index} in @var{obj} to\n"
1266 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1270 SCM_VALIDATE_INSTANCE (1, obj
);
1271 i
= scm_to_unsigned_integer (index
, 0,
1272 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1276 SCM_SET_SLOT (obj
, i
, value
);
1278 return SCM_UNSPECIFIED
;
1286 /* In the future, this function will return the effective slot
1287 * definition associated with SLOT_NAME. Now it just returns some of
1288 * the information which will be stored in the effective slot
1293 slot_definition_using_name (SCM
class, SCM slot_name
)
1295 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1296 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1297 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1298 return SCM_CAR (slots
);
1303 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1304 #define FUNC_NAME "%get-slot-value"
1306 SCM access
= SCM_CDDR (slotdef
);
1308 * - access is an integer (the offset of this slot in the slots vector)
1309 * - otherwise (car access) is the getter function to apply
1311 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1312 * we can just assume fixnums here.
1314 if (SCM_I_INUMP (access
))
1315 /* Don't poke at the slots directly, because scm_struct_ref handles the
1316 access bits for us. */
1317 return scm_struct_ref (obj
, access
);
1319 return scm_call_1 (SCM_CAR (access
), obj
);
1324 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1326 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1327 if (scm_is_true (slotdef
))
1328 return get_slot_value (class, obj
, slotdef
);
1330 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1334 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1335 #define FUNC_NAME "%set-slot-value"
1337 SCM access
= SCM_CDDR (slotdef
);
1339 * - access is an integer (the offset of this slot in the slots vector)
1340 * - otherwise (cadr access) is the setter function to apply
1342 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1343 * we can just assume fixnums here.
1345 if (SCM_I_INUMP (access
))
1346 /* obey permissions bits via going through struct-set! */
1347 scm_struct_set_x (obj
, access
, value
);
1349 /* ((cadr l) obj value) */
1350 scm_call_2 (SCM_CADR (access
), obj
, value
);
1351 return SCM_UNSPECIFIED
;
1356 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1358 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1359 if (scm_is_true (slotdef
))
1360 return set_slot_value (class, obj
, slotdef
, value
);
1362 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1366 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1370 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1371 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1377 /* ======================================== */
1379 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1380 (SCM
class, SCM obj
, SCM slot_name
),
1382 #define FUNC_NAME s_scm_slot_ref_using_class
1386 SCM_VALIDATE_CLASS (1, class);
1387 SCM_VALIDATE_INSTANCE (2, obj
);
1388 SCM_VALIDATE_SYMBOL (3, slot_name
);
1390 res
= get_slot_value_using_name (class, obj
, slot_name
);
1391 if (SCM_GOOPS_UNBOUNDP (res
))
1392 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1398 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1399 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1401 #define FUNC_NAME s_scm_slot_set_using_class_x
1403 SCM_VALIDATE_CLASS (1, class);
1404 SCM_VALIDATE_INSTANCE (2, obj
);
1405 SCM_VALIDATE_SYMBOL (3, slot_name
);
1407 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1412 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1413 (SCM
class, SCM obj
, SCM slot_name
),
1415 #define FUNC_NAME s_scm_slot_bound_using_class_p
1417 SCM_VALIDATE_CLASS (1, class);
1418 SCM_VALIDATE_INSTANCE (2, obj
);
1419 SCM_VALIDATE_SYMBOL (3, slot_name
);
1421 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1427 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1428 (SCM
class, SCM obj
, SCM slot_name
),
1430 #define FUNC_NAME s_scm_slot_exists_using_class_p
1432 SCM_VALIDATE_CLASS (1, class);
1433 SCM_VALIDATE_INSTANCE (2, obj
);
1434 SCM_VALIDATE_SYMBOL (3, slot_name
);
1435 return test_slot_existence (class, obj
, slot_name
);
1440 /* ======================================== */
1442 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1443 (SCM obj
, SCM slot_name
),
1444 "Return the value from @var{obj}'s slot with the name\n"
1446 #define FUNC_NAME s_scm_slot_ref
1450 SCM_VALIDATE_INSTANCE (1, obj
);
1451 TEST_CHANGE_CLASS (obj
, class);
1453 res
= get_slot_value_using_name (class, obj
, slot_name
);
1454 if (SCM_GOOPS_UNBOUNDP (res
))
1455 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1460 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1461 (SCM obj
, SCM slot_name
, SCM value
),
1462 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1463 #define FUNC_NAME s_scm_slot_set_x
1467 SCM_VALIDATE_INSTANCE (1, obj
);
1468 TEST_CHANGE_CLASS(obj
, class);
1470 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1474 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1476 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1477 (SCM obj
, SCM slot_name
),
1478 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1480 #define FUNC_NAME s_scm_slot_bound_p
1484 SCM_VALIDATE_INSTANCE (1, obj
);
1485 TEST_CHANGE_CLASS(obj
, class);
1487 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1495 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1496 (SCM obj
, SCM slot_name
),
1497 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1498 #define FUNC_NAME s_scm_slot_exists_p
1502 SCM_VALIDATE_INSTANCE (1, obj
);
1503 SCM_VALIDATE_SYMBOL (2, slot_name
);
1504 TEST_CHANGE_CLASS (obj
, class);
1506 return test_slot_existence (class, obj
, slot_name
);
1511 /******************************************************************************
1513 * %allocate-instance (the low level instance allocation primitive)
1515 ******************************************************************************/
1517 static void clear_method_cache (SCM
);
1519 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1520 (SCM
class, SCM initargs
),
1521 "Create a new instance of class @var{class} and initialize it\n"
1522 "from the arguments @var{initargs}.")
1523 #define FUNC_NAME s_scm_sys_allocate_instance
1526 scm_t_signed_bits n
, i
;
1529 SCM_VALIDATE_CLASS (1, class);
1531 /* FIXME: duplicates some of scm_make_struct. */
1533 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1534 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1536 layout
= SCM_VTABLE_LAYOUT (class);
1538 /* Set all SCM-holding slots to unbound */
1539 for (i
= 0; i
< n
; i
++)
1541 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1543 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1545 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1547 SCM_STRUCT_DATA (obj
)[i
] = 0;
1550 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1551 clear_method_cache (obj
);
1557 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1558 (SCM obj
, SCM setter
),
1560 #define FUNC_NAME s_scm_sys_set_object_setter_x
1562 SCM_ASSERT (SCM_STRUCTP (obj
)
1563 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1567 SCM_SET_GENERIC_SETTER (obj
, setter
);
1568 return SCM_UNSPECIFIED
;
1572 /******************************************************************************
1574 * %modify-instance (used by change-class to modify in place)
1576 ******************************************************************************/
1578 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1581 #define FUNC_NAME s_scm_sys_modify_instance
1583 SCM_VALIDATE_INSTANCE (1, old
);
1584 SCM_VALIDATE_INSTANCE (2, new);
1586 /* Exchange the data contained in old and new. We exchange rather than
1587 * scratch the old value with new to be correct with GC.
1588 * See "Class redefinition protocol above".
1590 SCM_CRITICAL_SECTION_START
;
1592 scm_t_bits word0
, word1
;
1593 word0
= SCM_CELL_WORD_0 (old
);
1594 word1
= SCM_CELL_WORD_1 (old
);
1595 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1596 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1597 SCM_SET_CELL_WORD_0 (new, word0
);
1598 SCM_SET_CELL_WORD_1 (new, word1
);
1600 SCM_CRITICAL_SECTION_END
;
1601 return SCM_UNSPECIFIED
;
1605 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1608 #define FUNC_NAME s_scm_sys_modify_class
1610 SCM_VALIDATE_CLASS (1, old
);
1611 SCM_VALIDATE_CLASS (2, new);
1613 SCM_CRITICAL_SECTION_START
;
1615 scm_t_bits word0
, word1
;
1616 word0
= SCM_CELL_WORD_0 (old
);
1617 word1
= SCM_CELL_WORD_1 (old
);
1618 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1619 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1620 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1621 SCM_SET_CELL_WORD_0 (new, word0
);
1622 SCM_SET_CELL_WORD_1 (new, word1
);
1623 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1625 SCM_CRITICAL_SECTION_END
;
1626 return SCM_UNSPECIFIED
;
1630 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1633 #define FUNC_NAME s_scm_sys_invalidate_class
1635 SCM_VALIDATE_CLASS (1, class);
1636 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1637 return SCM_UNSPECIFIED
;
1641 /* When instances change class, they finally get a new body, but
1642 * before that, they go through purgatory in hell. Odd as it may
1643 * seem, this data structure saves us from eternal suffering in
1644 * infinite recursions.
1647 static scm_t_bits
**hell
;
1648 static long n_hell
= 1; /* one place for the evil one himself */
1649 static long hell_size
= 4;
1650 static SCM hell_mutex
;
1656 for (i
= 1; i
< n_hell
; ++i
)
1657 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1663 go_to_hell (void *o
)
1666 scm_lock_mutex (hell_mutex
);
1667 if (n_hell
>= hell_size
)
1670 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1672 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1673 scm_unlock_mutex (hell_mutex
);
1677 go_to_heaven (void *o
)
1680 scm_lock_mutex (hell_mutex
);
1681 hell
[burnin (obj
)] = hell
[--n_hell
];
1682 scm_unlock_mutex (hell_mutex
);
1686 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1689 purgatory (SCM obj
, SCM new_class
)
1691 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1694 /* This function calls the generic function change-class for all
1695 * instances which aren't currently undergoing class change.
1699 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1703 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1704 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1705 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1706 purgatory (obj
, new_class
);
1711 /******************************************************************************
1717 * GGG E N E R I C F U N C T I O N S
1719 * This implementation provides
1720 * - generic functions (with class specializers)
1723 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1725 ******************************************************************************/
1727 SCM_KEYWORD (k_name
, "name");
1729 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1733 scm_apply_generic (SCM gf
, SCM args
)
1735 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1739 scm_call_generic_0 (SCM gf
)
1741 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1745 scm_call_generic_1 (SCM gf
, SCM a1
)
1747 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1751 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1753 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1757 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1759 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1762 static SCM delayed_compile_var
;
1765 init_delayed_compile_var (void)
1768 = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
1772 make_dispatch_procedure (SCM gf
)
1774 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
1775 scm_i_pthread_once (&once
, init_delayed_compile_var
);
1777 return scm_call_1 (scm_variable_ref (delayed_compile_var
), gf
);
1781 clear_method_cache (SCM gf
)
1783 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1784 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1787 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1790 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1792 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1793 clear_method_cache (gf
);
1794 return SCM_UNSPECIFIED
;
1798 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1801 #define FUNC_NAME s_scm_generic_capability_p
1803 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1804 proc
, SCM_ARG1
, FUNC_NAME
);
1805 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1809 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1812 #define FUNC_NAME s_scm_enable_primitive_generic_x
1814 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1815 while (!scm_is_null (subrs
))
1817 SCM subr
= SCM_CAR (subrs
);
1818 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1819 SCM_SET_SUBR_GENERIC (subr
,
1820 scm_make (scm_list_3 (scm_class_generic
,
1822 SCM_SUBR_NAME (subr
))));
1823 subrs
= SCM_CDR (subrs
);
1825 return SCM_UNSPECIFIED
;
1829 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1830 (SCM subr
, SCM generic
),
1832 #define FUNC_NAME s_scm_set_primitive_generic_x
1834 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1835 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1836 SCM_SET_SUBR_GENERIC (subr
, generic
);
1837 return SCM_UNSPECIFIED
;
1841 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1844 #define FUNC_NAME s_scm_primitive_generic_generic
1846 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1848 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1849 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1850 return *SCM_SUBR_GENERIC (subr
);
1852 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1856 typedef struct t_extension
{
1857 struct t_extension
*next
;
1863 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1865 static const char extension_gc_hint
[] = "GOOPS extension";
1867 static t_extension
*extensions
= 0;
1870 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1875 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1876 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1877 gf
= *SCM_SUBR_GENERIC (extended
);
1878 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1880 SCM_SUBR_NAME (extension
));
1881 SCM_SET_SUBR_GENERIC (extension
, gext
);
1885 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1887 t_extension
**loc
= &extensions
;
1888 /* Make sure that extensions are placed before their own
1889 * extensions in the extensions list. O(N^2) algorithm, but
1890 * extensions of primitive generics are rare.
1892 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1893 loc
= &(*loc
)->next
;
1895 e
->extended
= extended
;
1896 e
->extension
= extension
;
1902 setup_extended_primitive_generics ()
1906 t_extension
*e
= extensions
;
1907 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1908 extensions
= e
->next
;
1912 /******************************************************************************
1914 * Protocol for calling a generic fumction
1915 * This protocol is roughly equivalent to (parameter are a little bit different
1916 * for efficiency reasons):
1918 * + apply-generic (gf args)
1919 * + compute-applicable-methods (gf args ...)
1920 * + sort-applicable-methods (methods args)
1921 * + apply-methods (gf methods args)
1923 * apply-methods calls make-next-method to build the "continuation" of a a
1924 * method. Applying a next-method will call apply-next-method which in
1925 * turn will call apply again to call effectively the following method.
1927 ******************************************************************************/
1930 applicablep (SCM actual
, SCM formal
)
1932 /* We already know that the cpl is well formed. */
1933 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1937 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1939 register SCM s1
, s2
;
1943 * m1 and m2 can have != length (i.e. one can be one element longer than the
1944 * other when we have a dotted parameter list). For instance, with the call
1947 * (define-method M (a . l) ....)
1948 * (define-method M (a) ....)
1950 * we consider that the second method is more specific.
1952 * BTW, targs is an array of types. We don't need it's size since
1953 * we already know that m1 and m2 are applicable (no risk to go past
1954 * the end of this array).
1957 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1958 if (scm_is_null(s1
)) return 1;
1959 if (scm_is_null(s2
)) return 0;
1960 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1961 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1963 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1964 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1966 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1969 return 0;/* should not occur! */
1972 return 0; /* should not occur! */
1975 #define BUFFSIZE 32 /* big enough for most uses */
1978 scm_i_vector2list (SCM l
, long len
)
1981 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1983 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1984 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1990 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1993 SCM
*v
, vector
= SCM_EOL
;
1994 SCM buffer
[BUFFSIZE
];
1995 SCM save
= method_list
;
1996 scm_t_array_handle handle
;
1998 /* For reasonably sized method_lists we can try to avoid all the
1999 * consing and reorder the list in place...
2000 * This idea is due to David McClain <Dave_McClain@msn.com>
2002 if (size
<= BUFFSIZE
)
2004 for (i
= 0; i
< size
; i
++)
2006 buffer
[i
] = SCM_CAR (method_list
);
2007 method_list
= SCM_CDR (method_list
);
2013 /* Too many elements in method_list to keep everything locally */
2014 vector
= scm_i_vector2list (save
, size
);
2015 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2018 /* Use a simple shell sort since it is generally faster than qsort on
2019 * small vectors (which is probably mostly the case when we have to
2020 * sort a list of applicable methods).
2022 for (incr
= size
/ 2; incr
; incr
/= 2)
2024 for (i
= incr
; i
< size
; i
++)
2026 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2028 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2032 SCM tmp
= v
[j
+ incr
];
2040 if (size
<= BUFFSIZE
)
2042 /* We did it in locally, so restore the original list (reordered) in-place */
2043 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2045 SCM_SETCAR (method_list
, *v
);
2046 method_list
= SCM_CDR (method_list
);
2051 /* If we are here, that's that we did it the hard way... */
2052 scm_array_handle_release (&handle
);
2053 return scm_vector_to_list (vector
);
2057 is_accessor_method (SCM method
) {
2058 return SCM_IS_A_P (method
, scm_class_accessor_method
);
2062 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2066 SCM l
, fl
, applicable
= SCM_EOL
;
2068 SCM buffer
[BUFFSIZE
];
2072 scm_t_array_handle handle
;
2074 /* Build the list of arguments types */
2075 if (len
>= BUFFSIZE
)
2077 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2078 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2081 note that we don't have to work to reset the generation
2082 count. TMP is a new vector anyway, and it is found
2089 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2090 *p
++ = scm_class_of (SCM_CAR (args
));
2092 /* Build a list of all applicable methods */
2093 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2095 fl
= SPEC_OF (SCM_CAR (l
));
2096 /* Only accept accessors which match exactly in first arg. */
2097 if ((scm_is_null (fl
) || types
[0] != SCM_CAR (fl
))
2098 && is_accessor_method (SCM_CAR (l
)))
2100 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2102 if (SCM_INSTANCEP (fl
)
2103 /* We have a dotted argument list */
2104 || (i
>= len
&& scm_is_null (fl
)))
2105 { /* both list exhausted */
2106 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2112 || !applicablep (types
[i
], SCM_CAR (fl
)))
2117 if (len
>= BUFFSIZE
)
2118 scm_array_handle_release (&handle
);
2124 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2125 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2131 : sort_applicable_methods (applicable
, count
, types
));
2135 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2138 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2141 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2142 #define FUNC_NAME s_sys_compute_applicable_methods
2145 SCM_VALIDATE_GENERIC (1, gf
);
2146 n
= scm_ilength (args
);
2147 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2148 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2152 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2153 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2154 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2155 scm_sys_compute_applicable_methods
));
2157 /******************************************************************************
2159 * A simple make (which will be redefined later in Scheme)
2160 * This version handles only creation of gf, methods and classes (no instances)
2162 * Since this code will disappear when Goops will be fully booted,
2163 * no precaution is taken to be efficient.
2165 ******************************************************************************/
2167 SCM_KEYWORD (k_setter
, "setter");
2168 SCM_KEYWORD (k_specializers
, "specializers");
2169 SCM_KEYWORD (k_procedure
, "procedure");
2170 SCM_KEYWORD (k_formals
, "formals");
2171 SCM_KEYWORD (k_body
, "body");
2172 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2173 SCM_KEYWORD (k_dsupers
, "dsupers");
2174 SCM_KEYWORD (k_slots
, "slots");
2175 SCM_KEYWORD (k_gf
, "generic-function");
2177 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2179 "Make a new object. @var{args} must contain the class and\n"
2180 "all necessary initialization information.")
2181 #define FUNC_NAME s_scm_make
2184 long len
= scm_ilength (args
);
2186 if (len
<= 0 || (len
& 1) == 0)
2187 SCM_WRONG_NUM_ARGS ();
2189 class = SCM_CAR(args
);
2190 args
= SCM_CDR(args
);
2192 if (scm_is_eq (class, scm_class_generic
)
2193 || scm_is_eq (class, scm_class_accessor
))
2195 z
= scm_make_struct (class, SCM_INUM0
,
2196 scm_list_4 (SCM_BOOL_F
,
2200 scm_set_procedure_property_x (z
, scm_sym_name
,
2201 scm_get_keyword (k_name
,
2204 clear_method_cache (z
);
2205 if (scm_is_eq (class, scm_class_accessor
))
2207 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2208 if (scm_is_true (setter
))
2209 scm_sys_set_object_setter_x (z
, setter
);
2214 z
= scm_sys_allocate_instance (class, args
);
2216 if (scm_is_eq (class, scm_class_method
)
2217 || scm_is_eq (class, scm_class_accessor_method
))
2219 SCM_SET_SLOT (z
, scm_si_generic_function
,
2220 scm_i_get_keyword (k_gf
,
2225 SCM_SET_SLOT (z
, scm_si_specializers
,
2226 scm_i_get_keyword (k_specializers
,
2231 SCM_SET_SLOT (z
, scm_si_procedure
,
2232 scm_i_get_keyword (k_procedure
,
2237 SCM_SET_SLOT (z
, scm_si_formals
,
2238 scm_i_get_keyword (k_formals
,
2243 SCM_SET_SLOT (z
, scm_si_body
,
2244 scm_i_get_keyword (k_body
,
2249 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2250 scm_i_get_keyword (k_make_procedure
,
2258 /* In all the others case, make a new class .... No instance here */
2259 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2260 scm_i_get_keyword (k_name
,
2263 scm_from_latin1_symbol ("???"),
2265 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2266 scm_i_get_keyword (k_dsupers
,
2271 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2272 scm_i_get_keyword (k_slots
,
2283 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2286 #define FUNC_NAME s_scm_find_method
2289 long len
= scm_ilength (l
);
2292 SCM_WRONG_NUM_ARGS ();
2294 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2295 SCM_VALIDATE_GENERIC (1, gf
);
2296 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2297 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2299 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2303 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2304 (SCM m1
, SCM m2
, SCM targs
),
2305 "Return true if method @var{m1} is more specific than @var{m2} "
2306 "given the argument types (classes) listed in @var{targs}.")
2307 #define FUNC_NAME s_scm_sys_method_more_specific_p
2311 long i
, len
, m1_specs
, m2_specs
;
2312 scm_t_array_handle handle
;
2314 SCM_VALIDATE_METHOD (1, m1
);
2315 SCM_VALIDATE_METHOD (2, m2
);
2317 len
= scm_ilength (targs
);
2318 m1_specs
= scm_ilength (SPEC_OF (m1
));
2319 m2_specs
= scm_ilength (SPEC_OF (m2
));
2320 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2321 targs
, SCM_ARG3
, FUNC_NAME
);
2323 /* Verify that all the arguments of TARGS are classes and place them
2326 v
= scm_c_make_vector (len
, SCM_EOL
);
2327 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2329 for (i
= 0, l
= targs
;
2330 i
< len
&& scm_is_pair (l
);
2331 i
++, l
= SCM_CDR (l
))
2333 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2334 v_elts
[i
] = SCM_CAR (l
);
2336 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2338 scm_array_handle_release (&handle
);
2346 /******************************************************************************
2350 ******************************************************************************/
2352 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2353 assuming that currently the reverse is true. Recalculate slots and
2354 associated getters-n-setters. */
2356 fix_cpl (SCM c
, SCM before
, SCM after
)
2358 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2359 SCM ls
= scm_c_memq (after
, cpl
);
2362 if (scm_is_false (ls
))
2363 /* if this condition occurs, fix_cpl should not be applied this way */
2366 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2367 SCM_SETCAR (ls
, before
);
2368 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2370 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2371 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2372 SCM g_n_s
= compute_getters_n_setters (slots
);
2373 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2374 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2380 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2382 SCM tmp
= scm_from_locale_symbol (name
);
2384 *var
= scm_basic_make_class (meta
, tmp
,
2385 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2391 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2394 create_standard_classes (void)
2397 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2398 scm_from_latin1_symbol ("specializers"),
2400 scm_from_latin1_symbol ("formals"),
2401 scm_from_latin1_symbol ("body"),
2402 scm_from_latin1_symbol ("make-procedure"),
2404 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2406 k_slot_definition
));
2407 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2408 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2411 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2414 scm_from_latin1_symbol ("effective-methods"));
2415 SCM setter_slots
= scm_list_1 (sym_setter
);
2416 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2419 /* Foreign class slot classes */
2420 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2421 scm_class_class
, scm_class_top
, SCM_EOL
);
2422 make_stdcls (&scm_class_protected
, "<protected-slot>",
2423 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2424 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2425 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2426 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2427 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2428 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2429 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2430 make_stdcls (&scm_class_self
, "<self-slot>",
2431 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2432 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2434 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2436 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2438 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2440 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2442 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2444 make_stdcls (&scm_class_scm
, "<scm-slot>",
2445 scm_class_class
, scm_class_protected
, SCM_EOL
);
2446 make_stdcls (&scm_class_int
, "<int-slot>",
2447 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2448 make_stdcls (&scm_class_float
, "<float-slot>",
2449 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2450 make_stdcls (&scm_class_double
, "<double-slot>",
2451 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2453 /* Continue initialization of class <class> */
2455 slots
= build_class_class_slots ();
2456 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2457 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2458 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2459 compute_getters_n_setters (slots
));
2461 /* scm_class_generic functions classes */
2462 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2463 scm_class_class
, scm_class_class
, SCM_EOL
);
2464 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2465 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2466 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2467 make_stdcls (&scm_class_method
, "<method>",
2468 scm_class_class
, scm_class_object
, method_slots
);
2469 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2470 scm_class_class
, scm_class_method
, amethod_slots
);
2471 make_stdcls (&scm_class_applicable
, "<applicable>",
2472 scm_class_class
, scm_class_top
, SCM_EOL
);
2473 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2474 scm_class_applicable_struct_class
,
2475 scm_list_2 (scm_class_object
, scm_class_applicable
),
2476 scm_list_1 (sym_procedure
));
2477 make_stdcls (&scm_class_generic
, "<generic>",
2478 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2479 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2480 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2481 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2482 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2483 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2484 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2485 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2486 make_stdcls (&scm_class_accessor
, "<accessor>",
2487 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2488 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2489 make_stdcls (&scm_class_extended_generic_with_setter
,
2490 "<extended-generic-with-setter>",
2491 scm_class_applicable_struct_class
,
2492 scm_list_2 (scm_class_extended_generic
,
2493 scm_class_generic_with_setter
),
2495 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2496 SCM_CLASSF_PURE_GENERIC
);
2497 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2498 scm_class_applicable_struct_class
,
2499 scm_list_2 (scm_class_accessor
,
2500 scm_class_extended_generic_with_setter
),
2502 /* <extended-generic> is misplaced. */
2503 fix_cpl (scm_class_extended_accessor
,
2504 scm_class_extended_generic
, scm_class_generic_with_setter
);
2505 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2507 /* Primitive types classes */
2508 make_stdcls (&scm_class_boolean
, "<boolean>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&scm_class_char
, "<char>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&scm_class_list
, "<list>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&scm_class_pair
, "<pair>",
2515 scm_class_class
, scm_class_list
, SCM_EOL
);
2516 make_stdcls (&scm_class_null
, "<null>",
2517 scm_class_class
, scm_class_list
, SCM_EOL
);
2518 make_stdcls (&scm_class_string
, "<string>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&scm_class_symbol
, "<symbol>",
2521 scm_class_class
, scm_class_top
, SCM_EOL
);
2522 make_stdcls (&scm_class_vector
, "<vector>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&class_foreign
, "<foreign>",
2525 scm_class_class
, scm_class_top
, SCM_EOL
);
2526 make_stdcls (&class_hashtable
, "<hashtable>",
2527 scm_class_class
, scm_class_top
, SCM_EOL
);
2528 make_stdcls (&class_fluid
, "<fluid>",
2529 scm_class_class
, scm_class_top
, SCM_EOL
);
2530 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2531 scm_class_class
, scm_class_top
, SCM_EOL
);
2532 make_stdcls (&class_frame
, "<frame>",
2533 scm_class_class
, scm_class_top
, SCM_EOL
);
2534 make_stdcls (&class_objcode
, "<objcode>",
2535 scm_class_class
, scm_class_top
, SCM_EOL
);
2536 make_stdcls (&class_vm
, "<vm>",
2537 scm_class_class
, scm_class_top
, SCM_EOL
);
2538 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2539 scm_class_class
, scm_class_top
, SCM_EOL
);
2540 make_stdcls (&class_bytevector
, "<bytevector>",
2541 scm_class_class
, scm_class_top
, SCM_EOL
);
2542 make_stdcls (&class_uvec
, "<uvec>",
2543 scm_class_class
, class_bytevector
, SCM_EOL
);
2544 make_stdcls (&class_array
, "<array>",
2545 scm_class_class
, scm_class_top
, SCM_EOL
);
2546 make_stdcls (&class_bitvector
, "<bitvector>",
2547 scm_class_class
, scm_class_top
, SCM_EOL
);
2548 make_stdcls (&scm_class_number
, "<number>",
2549 scm_class_class
, scm_class_top
, SCM_EOL
);
2550 make_stdcls (&scm_class_complex
, "<complex>",
2551 scm_class_class
, scm_class_number
, SCM_EOL
);
2552 make_stdcls (&scm_class_real
, "<real>",
2553 scm_class_class
, scm_class_complex
, SCM_EOL
);
2554 make_stdcls (&scm_class_integer
, "<integer>",
2555 scm_class_class
, scm_class_real
, SCM_EOL
);
2556 make_stdcls (&scm_class_fraction
, "<fraction>",
2557 scm_class_class
, scm_class_real
, SCM_EOL
);
2558 make_stdcls (&scm_class_keyword
, "<keyword>",
2559 scm_class_class
, scm_class_top
, SCM_EOL
);
2560 make_stdcls (&scm_class_unknown
, "<unknown>",
2561 scm_class_class
, scm_class_top
, SCM_EOL
);
2562 make_stdcls (&scm_class_procedure
, "<procedure>",
2563 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2564 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2565 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2566 make_stdcls (&scm_class_port
, "<port>",
2567 scm_class_class
, scm_class_top
, SCM_EOL
);
2568 make_stdcls (&scm_class_input_port
, "<input-port>",
2569 scm_class_class
, scm_class_port
, SCM_EOL
);
2570 make_stdcls (&scm_class_output_port
, "<output-port>",
2571 scm_class_class
, scm_class_port
, SCM_EOL
);
2572 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2574 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2578 /**********************************************************************
2582 **********************************************************************/
2585 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2591 sprintf (buffer
, template, type_name
);
2592 name
= scm_from_locale_symbol (buffer
);
2595 name
= SCM_GOOPS_UNBOUND
;
2597 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2598 name
, supers
, SCM_EOL
);
2600 /* Only define name if doesn't already exist. */
2601 if (!SCM_GOOPS_UNBOUNDP (name
)
2602 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2603 DEFVAR (name
, class);
2608 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2611 if (scm_is_true (type_name_sym
))
2613 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2614 scm_symbol_to_string (type_name_sym
),
2615 scm_from_locale_string (">")));
2616 name
= scm_string_to_symbol (name
);
2619 name
= SCM_GOOPS_UNBOUND
;
2621 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2622 name
, supers
, SCM_EOL
);
2624 /* Only define name if doesn't already exist. */
2625 if (!SCM_GOOPS_UNBOUNDP (name
)
2626 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2627 DEFVAR (name
, class);
2632 scm_make_extended_class (char const *type_name
, int applicablep
)
2634 return make_class_from_template ("<%s>",
2636 scm_list_1 (applicablep
2637 ? scm_class_applicable
2643 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2645 return make_class_from_symbol (type_name_sym
,
2646 scm_list_1 (applicablep
2647 ? scm_class_applicable
2653 scm_i_inherit_applicable (SCM c
)
2655 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2657 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2658 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2659 /* patch scm_class_applicable into direct-supers */
2660 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2661 if (scm_is_false (top
))
2662 dsupers
= scm_append (scm_list_2 (dsupers
,
2663 scm_list_1 (scm_class_applicable
)));
2666 SCM_SETCAR (top
, scm_class_applicable
);
2667 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2669 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2670 /* patch scm_class_applicable into cpl */
2671 top
= scm_c_memq (scm_class_top
, cpl
);
2672 if (scm_is_false (top
))
2676 SCM_SETCAR (top
, scm_class_applicable
);
2677 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2679 /* add class to direct-subclasses of scm_class_applicable */
2680 SCM_SET_SLOT (scm_class_applicable
,
2681 scm_si_direct_subclasses
,
2682 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2683 scm_si_direct_subclasses
)));
2688 create_smob_classes (void)
2692 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2693 scm_smob_class
[i
] = SCM_BOOL_F
;
2695 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2697 for (i
= 0; i
< scm_numsmob
; ++i
)
2698 if (scm_is_false (scm_smob_class
[i
]))
2699 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2700 scm_smobs
[i
].apply
!= 0);
2704 scm_make_port_classes (long ptobnum
, char *type_name
)
2706 SCM c
, class = make_class_from_template ("<%s-port>",
2708 scm_list_1 (scm_class_port
),
2710 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2711 = make_class_from_template ("<%s-input-port>",
2713 scm_list_2 (class, scm_class_input_port
),
2715 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2716 = make_class_from_template ("<%s-output-port>",
2718 scm_list_2 (class, scm_class_output_port
),
2720 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2722 = make_class_from_template ("<%s-input-output-port>",
2724 scm_list_2 (class, scm_class_input_output_port
),
2726 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2727 SCM_SET_SLOT (c
, scm_si_cpl
,
2728 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2732 create_port_classes (void)
2736 for (i
= 0; i
< scm_numptob
; ++i
)
2737 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2741 make_struct_class (void *closure SCM_UNUSED
,
2742 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2744 if (scm_is_false (data
))
2745 scm_i_define_class_for_vtable (vtable
);
2746 return SCM_UNSPECIFIED
;
2750 create_struct_classes (void)
2752 /* FIXME: take the vtable_class_map while initializing goops? */
2753 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2757 /**********************************************************************
2761 **********************************************************************/
2766 if (!goops_loaded_p
)
2767 scm_c_resolve_module ("oop goops");
2771 SCM_SYMBOL (sym_o
, "o");
2772 SCM_SYMBOL (sym_x
, "x");
2774 SCM_KEYWORD (k_accessor
, "accessor");
2775 SCM_KEYWORD (k_getter
, "getter");
2778 scm_ensure_accessor (SCM name
)
2782 var
= scm_module_variable (scm_current_module (), name
);
2783 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2784 gf
= SCM_VARIABLE_REF (var
);
2788 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2790 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2791 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2792 k_name
, name
, k_setter
, gf
));
2800 * Debugging utilities
2803 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2805 "Return @code{#t} if @var{obj} is a pure generic.")
2806 #define FUNC_NAME s_scm_pure_generic_p
2808 return scm_from_bool (SCM_PUREGENERICP (obj
));
2812 #endif /* GUILE_DEBUG */
2818 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2820 "Announce that GOOPS is loaded and perform initialization\n"
2821 "on the C level which depends on the loaded GOOPS modules.")
2822 #define FUNC_NAME s_scm_sys_goops_loaded
2825 var_compute_applicable_methods
=
2826 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2828 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2830 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2832 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2833 var_no_applicable_method
=
2834 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2836 scm_module_variable (scm_module_goops
, sym_change_class
);
2837 setup_extended_primitive_generics ();
2838 return SCM_UNSPECIFIED
;
2842 SCM scm_module_goops
;
2845 scm_init_goops_builtins (void)
2847 scm_module_goops
= scm_current_module ();
2849 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2851 #include "libguile/goops.x"
2853 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2854 hell_mutex
= scm_make_mutex ();
2856 create_basic_classes ();
2857 create_standard_classes ();
2858 create_smob_classes ();
2859 create_struct_classes ();
2860 create_port_classes ();
2863 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2864 scm_no_applicable_method
=
2865 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2866 DEFVAR (name
, scm_no_applicable_method
);
2869 return SCM_UNSPECIFIED
;
2875 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2876 scm_init_goops_builtins
);