1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
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_PACK (0);
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_UNPACK (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
))
700 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
701 if (SCM_GOOPS_UNBOUNDP (slot_value
))
702 set_slot_value (class,
714 /* NOTE: The following macros are interdependent with code
715 * in goops.scm:compute-getters-n-setters
717 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
718 (SCM_I_INUMP (SCM_CDDR (gns)) \
719 || (scm_is_pair (SCM_CDDR (gns)) \
720 && scm_is_pair (SCM_CDDDR (gns)) \
721 && scm_is_pair (SCM_CDDDDR (gns))))
722 #define SCM_GNS_INDEX(gns) \
723 (SCM_I_INUMP (SCM_CDDR (gns)) \
724 ? SCM_I_INUM (SCM_CDDR (gns)) \
725 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
726 #define SCM_GNS_SIZE(gns) \
727 (SCM_I_INUMP (SCM_CDDR (gns)) \
729 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
731 SCM_KEYWORD (k_class
, "class");
732 SCM_KEYWORD (k_allocation
, "allocation");
733 SCM_KEYWORD (k_instance
, "instance");
735 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
738 #define FUNC_NAME s_scm_sys_prep_layout_x
740 SCM slots
, getters_n_setters
, nfields
;
741 unsigned long int n
, i
;
745 SCM_VALIDATE_INSTANCE (1, class);
746 slots
= SCM_SLOT (class, scm_si_slots
);
747 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
748 nfields
= SCM_SLOT (class, scm_si_nfields
);
749 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
750 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
751 scm_list_1 (nfields
));
752 n
= 2 * SCM_I_INUM (nfields
);
753 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
754 && SCM_SUBCLASSP (class, scm_class_class
))
755 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
756 scm_list_1 (nfields
));
758 layout
= scm_i_make_string (n
, &s
, 0);
760 while (scm_is_pair (getters_n_setters
))
762 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
765 int len
, index
, size
;
768 if (i
>= n
|| !scm_is_pair (slots
))
771 /* extract slot type */
772 len
= scm_ilength (SCM_CDAR (slots
));
773 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
774 len
, SCM_BOOL_F
, FUNC_NAME
);
775 /* determine slot GC protection and access mode */
776 if (scm_is_false (type
))
783 if (!SCM_CLASSP (type
))
784 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
785 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
787 if (SCM_SUBCLASSP (type
, scm_class_self
))
789 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
794 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
796 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
798 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
810 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
811 if (index
!= (i
>> 1))
813 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
821 slots
= SCM_CDR (slots
);
822 getters_n_setters
= SCM_CDR (getters_n_setters
);
824 if (!scm_is_null (slots
))
827 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
829 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
830 return SCM_UNSPECIFIED
;
834 static void prep_hashsets (SCM
);
836 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
837 (SCM
class, SCM dsupers
),
839 #define FUNC_NAME s_scm_sys_inherit_magic_x
841 SCM_VALIDATE_INSTANCE (1, class);
842 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
843 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
845 prep_hashsets (class);
847 return SCM_UNSPECIFIED
;
852 prep_hashsets (SCM
class)
856 for (i
= 0; i
< 8; ++i
)
857 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
860 /******************************************************************************/
863 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
865 SCM z
, cpl
, slots
, nfields
, g_n_s
;
867 /* Allocate one instance */
868 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
870 /* Initialize its slots */
871 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
872 cpl
= compute_cpl (z
);
873 slots
= build_slots_list (maplist (dslots
), cpl
);
874 nfields
= scm_from_int (scm_ilength (slots
));
875 g_n_s
= compute_getters_n_setters (slots
);
877 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
878 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
879 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
880 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
881 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
882 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
883 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
884 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
885 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
887 /* Add this class in the direct-subclasses slot of dsupers */
890 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
891 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
892 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
893 scm_si_direct_subclasses
)));
900 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
902 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
903 scm_sys_prep_layout_x (z
);
904 scm_sys_inherit_magic_x (z
, dsupers
);
908 /******************************************************************************/
910 SCM_SYMBOL (sym_layout
, "layout");
911 SCM_SYMBOL (sym_flags
, "flags");
912 SCM_SYMBOL (sym_self
, "%self");
913 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
914 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
915 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
916 SCM_SYMBOL (sym_print
, "print");
917 SCM_SYMBOL (sym_procedure
, "procedure");
918 SCM_SYMBOL (sym_setter
, "setter");
919 SCM_SYMBOL (sym_redefined
, "redefined");
920 SCM_SYMBOL (sym_h0
, "h0");
921 SCM_SYMBOL (sym_h1
, "h1");
922 SCM_SYMBOL (sym_h2
, "h2");
923 SCM_SYMBOL (sym_h3
, "h3");
924 SCM_SYMBOL (sym_h4
, "h4");
925 SCM_SYMBOL (sym_h5
, "h5");
926 SCM_SYMBOL (sym_h6
, "h6");
927 SCM_SYMBOL (sym_h7
, "h7");
928 SCM_SYMBOL (sym_name
, "name");
929 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
930 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
931 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
932 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
933 SCM_SYMBOL (sym_cpl
, "cpl");
934 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
935 SCM_SYMBOL (sym_slots
, "slots");
936 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
937 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
938 SCM_SYMBOL (sym_nfields
, "nfields");
942 build_class_class_slots (void)
944 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
945 SCM_CLASS_CLASS_LAYOUT */
947 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
948 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
949 scm_list_3 (sym_self
, k_class
, scm_class_self
),
950 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
951 scm_list_1 (sym_print
),
952 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
953 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
954 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
955 scm_list_1 (sym_redefined
),
956 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
957 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
958 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
959 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
960 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
961 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
962 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
963 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
964 scm_list_1 (sym_direct_supers
),
965 scm_list_1 (sym_direct_slots
),
966 scm_list_1 (sym_direct_subclasses
),
967 scm_list_1 (sym_direct_methods
),
968 scm_list_1 (sym_cpl
),
969 scm_list_1 (sym_default_slot_definition_class
),
970 scm_list_1 (sym_slots
),
971 scm_list_1 (sym_getters_n_setters
),
972 scm_list_1 (sym_keyword_access
),
973 scm_list_1 (sym_nfields
),
978 create_basic_classes (void)
980 /* SCM slots_of_class = build_class_class_slots (); */
983 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
984 SCM name
= scm_from_latin1_symbol ("<class>");
985 scm_class_class
= scm_i_make_vtable_vtable (cs
);
986 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
987 | SCM_CLASSF_METACLASS
));
989 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
990 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
991 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
992 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
993 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
994 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
995 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
996 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
997 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
998 compute_getters_n_setters (slots_of_class)); */
999 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
1001 prep_hashsets (scm_class_class
);
1003 DEFVAR(name
, scm_class_class
);
1006 name
= scm_from_latin1_symbol ("<top>");
1007 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
1010 DEFVAR(name
, scm_class_top
);
1012 /**** <object> ****/
1013 name
= scm_from_latin1_symbol ("<object>");
1014 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
1015 scm_list_1 (scm_class_top
), SCM_EOL
);
1017 DEFVAR (name
, scm_class_object
);
1019 /* <top> <object> and <class> were partially initialized. Correct them here */
1020 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1022 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1023 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1026 /******************************************************************************/
1028 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1030 "Return @code{#t} if @var{obj} is an instance.")
1031 #define FUNC_NAME s_scm_instance_p
1033 return scm_from_bool (SCM_INSTANCEP (obj
));
1038 /******************************************************************************
1040 * Meta object accessors
1042 ******************************************************************************/
1043 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1045 "Return the class name of @var{obj}.")
1046 #define FUNC_NAME s_scm_class_name
1048 SCM_VALIDATE_CLASS (1, obj
);
1049 return scm_slot_ref (obj
, sym_name
);
1053 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1055 "Return the direct superclasses of the class @var{obj}.")
1056 #define FUNC_NAME s_scm_class_direct_supers
1058 SCM_VALIDATE_CLASS (1, obj
);
1059 return scm_slot_ref (obj
, sym_direct_supers
);
1063 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1065 "Return the direct slots of the class @var{obj}.")
1066 #define FUNC_NAME s_scm_class_direct_slots
1068 SCM_VALIDATE_CLASS (1, obj
);
1069 return scm_slot_ref (obj
, sym_direct_slots
);
1073 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1075 "Return the direct subclasses of the class @var{obj}.")
1076 #define FUNC_NAME s_scm_class_direct_subclasses
1078 SCM_VALIDATE_CLASS (1, obj
);
1079 return scm_slot_ref(obj
, sym_direct_subclasses
);
1083 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1085 "Return the direct methods of the class @var{obj}")
1086 #define FUNC_NAME s_scm_class_direct_methods
1088 SCM_VALIDATE_CLASS (1, obj
);
1089 return scm_slot_ref (obj
, sym_direct_methods
);
1093 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1095 "Return the class precedence list of the class @var{obj}.")
1096 #define FUNC_NAME s_scm_class_precedence_list
1098 SCM_VALIDATE_CLASS (1, obj
);
1099 return scm_slot_ref (obj
, sym_cpl
);
1103 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1105 "Return the slot list of the class @var{obj}.")
1106 #define FUNC_NAME s_scm_class_slots
1108 SCM_VALIDATE_CLASS (1, obj
);
1109 return scm_slot_ref (obj
, sym_slots
);
1113 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1115 "Return the name of the generic function @var{obj}.")
1116 #define FUNC_NAME s_scm_generic_function_name
1118 SCM_VALIDATE_GENERIC (1, obj
);
1119 return scm_procedure_property (obj
, scm_sym_name
);
1123 SCM_SYMBOL (sym_methods
, "methods");
1124 SCM_SYMBOL (sym_extended_by
, "extended-by");
1125 SCM_SYMBOL (sym_extends
, "extends");
1128 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1130 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1131 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1132 while (!scm_is_null (gfs
))
1134 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1135 gfs
= SCM_CDR (gfs
);
1137 return method_lists
;
1141 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1143 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1145 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1146 while (!scm_is_null (gfs
))
1148 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1149 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1152 gfs
= SCM_CDR (gfs
);
1155 return method_lists
;
1158 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1160 "Return the methods of the generic function @var{obj}.")
1161 #define FUNC_NAME s_scm_generic_function_methods
1164 SCM_VALIDATE_GENERIC (1, obj
);
1165 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1166 methods
= fold_downward_gf_methods (methods
, obj
);
1167 return scm_append (methods
);
1171 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1173 "Return the generic function for the method @var{obj}.")
1174 #define FUNC_NAME s_scm_method_generic_function
1176 SCM_VALIDATE_METHOD (1, obj
);
1177 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1181 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1183 "Return specializers of the method @var{obj}.")
1184 #define FUNC_NAME s_scm_method_specializers
1186 SCM_VALIDATE_METHOD (1, obj
);
1187 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1191 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1193 "Return the procedure of the method @var{obj}.")
1194 #define FUNC_NAME s_scm_method_procedure
1196 SCM_VALIDATE_METHOD (1, obj
);
1197 return scm_slot_ref (obj
, sym_procedure
);
1201 /******************************************************************************
1203 * S l o t a c c e s s
1205 ******************************************************************************/
1207 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1209 "Return the unbound value.")
1210 #define FUNC_NAME s_scm_make_unbound
1212 return SCM_GOOPS_UNBOUND
;
1216 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1218 "Return @code{#t} if @var{obj} is unbound.")
1219 #define FUNC_NAME s_scm_unbound_p
1221 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1225 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1226 (SCM value
, SCM obj
),
1227 "Return @var{value} if it is bound, and invoke the\n"
1228 "@var{slot-unbound} method of @var{obj} if it is not.")
1229 #define FUNC_NAME s_scm_assert_bound
1231 if (SCM_GOOPS_UNBOUNDP (value
))
1232 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1237 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1238 (SCM obj
, SCM index
),
1239 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1240 "the value from @var{obj}.")
1241 #define FUNC_NAME s_scm_at_assert_bound_ref
1243 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1244 if (SCM_GOOPS_UNBOUNDP (value
))
1245 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1250 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1251 (SCM obj
, SCM index
),
1252 "Return the slot value with index @var{index} from @var{obj}.")
1253 #define FUNC_NAME s_scm_sys_fast_slot_ref
1257 SCM_VALIDATE_INSTANCE (1, obj
);
1258 i
= scm_to_unsigned_integer (index
, 0,
1259 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1262 return SCM_SLOT (obj
, i
);
1266 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1267 (SCM obj
, SCM index
, SCM value
),
1268 "Set the slot with index @var{index} in @var{obj} to\n"
1270 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1274 SCM_VALIDATE_INSTANCE (1, obj
);
1275 i
= scm_to_unsigned_integer (index
, 0,
1276 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1280 SCM_SET_SLOT (obj
, i
, value
);
1282 return SCM_UNSPECIFIED
;
1290 /* In the future, this function will return the effective slot
1291 * definition associated with SLOT_NAME. Now it just returns some of
1292 * the information which will be stored in the effective slot
1297 slot_definition_using_name (SCM
class, SCM slot_name
)
1299 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1300 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1301 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1302 return SCM_CAR (slots
);
1307 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1308 #define FUNC_NAME "%get-slot-value"
1310 SCM access
= SCM_CDDR (slotdef
);
1312 * - access is an integer (the offset of this slot in the slots vector)
1313 * - otherwise (car access) is the getter function to apply
1315 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1316 * we can just assume fixnums here.
1318 if (SCM_I_INUMP (access
))
1319 /* Don't poke at the slots directly, because scm_struct_ref handles the
1320 access bits for us. */
1321 return scm_struct_ref (obj
, access
);
1323 return scm_call_1 (SCM_CAR (access
), obj
);
1328 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1330 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1331 if (scm_is_true (slotdef
))
1332 return get_slot_value (class, obj
, slotdef
);
1334 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1338 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1339 #define FUNC_NAME "%set-slot-value"
1341 SCM access
= SCM_CDDR (slotdef
);
1343 * - access is an integer (the offset of this slot in the slots vector)
1344 * - otherwise (cadr access) is the setter function to apply
1346 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1347 * we can just assume fixnums here.
1349 if (SCM_I_INUMP (access
))
1350 /* obey permissions bits via going through struct-set! */
1351 scm_struct_set_x (obj
, access
, value
);
1353 /* ((cadr l) obj value) */
1354 scm_call_2 (SCM_CADR (access
), obj
, value
);
1355 return SCM_UNSPECIFIED
;
1360 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1362 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1363 if (scm_is_true (slotdef
))
1364 return set_slot_value (class, obj
, slotdef
, value
);
1366 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1370 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1374 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1375 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1381 /* ======================================== */
1383 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1384 (SCM
class, SCM obj
, SCM slot_name
),
1386 #define FUNC_NAME s_scm_slot_ref_using_class
1390 SCM_VALIDATE_CLASS (1, class);
1391 SCM_VALIDATE_INSTANCE (2, obj
);
1392 SCM_VALIDATE_SYMBOL (3, slot_name
);
1394 res
= get_slot_value_using_name (class, obj
, slot_name
);
1395 if (SCM_GOOPS_UNBOUNDP (res
))
1396 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1402 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1403 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1405 #define FUNC_NAME s_scm_slot_set_using_class_x
1407 SCM_VALIDATE_CLASS (1, class);
1408 SCM_VALIDATE_INSTANCE (2, obj
);
1409 SCM_VALIDATE_SYMBOL (3, slot_name
);
1411 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1416 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1417 (SCM
class, SCM obj
, SCM slot_name
),
1419 #define FUNC_NAME s_scm_slot_bound_using_class_p
1421 SCM_VALIDATE_CLASS (1, class);
1422 SCM_VALIDATE_INSTANCE (2, obj
);
1423 SCM_VALIDATE_SYMBOL (3, slot_name
);
1425 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1431 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1432 (SCM
class, SCM obj
, SCM slot_name
),
1434 #define FUNC_NAME s_scm_slot_exists_using_class_p
1436 SCM_VALIDATE_CLASS (1, class);
1437 SCM_VALIDATE_INSTANCE (2, obj
);
1438 SCM_VALIDATE_SYMBOL (3, slot_name
);
1439 return test_slot_existence (class, obj
, slot_name
);
1444 /* ======================================== */
1446 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1447 (SCM obj
, SCM slot_name
),
1448 "Return the value from @var{obj}'s slot with the name\n"
1450 #define FUNC_NAME s_scm_slot_ref
1454 SCM_VALIDATE_INSTANCE (1, obj
);
1455 TEST_CHANGE_CLASS (obj
, class);
1457 res
= get_slot_value_using_name (class, obj
, slot_name
);
1458 if (SCM_GOOPS_UNBOUNDP (res
))
1459 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1464 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1465 (SCM obj
, SCM slot_name
, SCM value
),
1466 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1467 #define FUNC_NAME s_scm_slot_set_x
1471 SCM_VALIDATE_INSTANCE (1, obj
);
1472 TEST_CHANGE_CLASS(obj
, class);
1474 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1478 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1480 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1481 (SCM obj
, SCM slot_name
),
1482 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1484 #define FUNC_NAME s_scm_slot_bound_p
1488 SCM_VALIDATE_INSTANCE (1, obj
);
1489 TEST_CHANGE_CLASS(obj
, class);
1491 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1499 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1500 (SCM obj
, SCM slot_name
),
1501 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1502 #define FUNC_NAME s_scm_slot_exists_p
1506 SCM_VALIDATE_INSTANCE (1, obj
);
1507 SCM_VALIDATE_SYMBOL (2, slot_name
);
1508 TEST_CHANGE_CLASS (obj
, class);
1510 return test_slot_existence (class, obj
, slot_name
);
1515 /******************************************************************************
1517 * %allocate-instance (the low level instance allocation primitive)
1519 ******************************************************************************/
1521 static void clear_method_cache (SCM
);
1523 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1524 (SCM
class, SCM initargs
),
1525 "Create a new instance of class @var{class} and initialize it\n"
1526 "from the arguments @var{initargs}.")
1527 #define FUNC_NAME s_scm_sys_allocate_instance
1530 scm_t_signed_bits n
, i
;
1533 SCM_VALIDATE_CLASS (1, class);
1535 /* FIXME: duplicates some of scm_make_struct. */
1537 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1538 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1540 layout
= SCM_VTABLE_LAYOUT (class);
1542 /* Set all SCM-holding slots to unbound */
1543 for (i
= 0; i
< n
; i
++)
1545 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1547 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1549 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1551 SCM_STRUCT_DATA (obj
)[i
] = 0;
1554 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1555 clear_method_cache (obj
);
1561 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1562 (SCM obj
, SCM setter
),
1564 #define FUNC_NAME s_scm_sys_set_object_setter_x
1566 SCM_ASSERT (SCM_STRUCTP (obj
)
1567 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1571 SCM_SET_GENERIC_SETTER (obj
, setter
);
1572 return SCM_UNSPECIFIED
;
1576 /******************************************************************************
1578 * %modify-instance (used by change-class to modify in place)
1580 ******************************************************************************/
1582 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1585 #define FUNC_NAME s_scm_sys_modify_instance
1587 SCM_VALIDATE_INSTANCE (1, old
);
1588 SCM_VALIDATE_INSTANCE (2, new);
1590 /* Exchange the data contained in old and new. We exchange rather than
1591 * scratch the old value with new to be correct with GC.
1592 * See "Class redefinition protocol above".
1594 SCM_CRITICAL_SECTION_START
;
1596 scm_t_bits word0
, word1
;
1597 word0
= SCM_CELL_WORD_0 (old
);
1598 word1
= SCM_CELL_WORD_1 (old
);
1599 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1600 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1601 SCM_SET_CELL_WORD_0 (new, word0
);
1602 SCM_SET_CELL_WORD_1 (new, word1
);
1604 SCM_CRITICAL_SECTION_END
;
1605 return SCM_UNSPECIFIED
;
1609 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1612 #define FUNC_NAME s_scm_sys_modify_class
1614 SCM_VALIDATE_CLASS (1, old
);
1615 SCM_VALIDATE_CLASS (2, new);
1617 SCM_CRITICAL_SECTION_START
;
1619 scm_t_bits word0
, word1
;
1620 word0
= SCM_CELL_WORD_0 (old
);
1621 word1
= SCM_CELL_WORD_1 (old
);
1622 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1623 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1624 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1625 SCM_SET_CELL_WORD_0 (new, word0
);
1626 SCM_SET_CELL_WORD_1 (new, word1
);
1627 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1629 SCM_CRITICAL_SECTION_END
;
1630 return SCM_UNSPECIFIED
;
1634 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1637 #define FUNC_NAME s_scm_sys_invalidate_class
1639 SCM_VALIDATE_CLASS (1, class);
1640 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1641 return SCM_UNSPECIFIED
;
1645 /* When instances change class, they finally get a new body, but
1646 * before that, they go through purgatory in hell. Odd as it may
1647 * seem, this data structure saves us from eternal suffering in
1648 * infinite recursions.
1651 static scm_t_bits
**hell
;
1652 static long n_hell
= 1; /* one place for the evil one himself */
1653 static long hell_size
= 4;
1654 static SCM hell_mutex
;
1660 for (i
= 1; i
< n_hell
; ++i
)
1661 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1667 go_to_hell (void *o
)
1670 scm_lock_mutex (hell_mutex
);
1671 if (n_hell
>= hell_size
)
1674 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1676 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1677 scm_unlock_mutex (hell_mutex
);
1681 go_to_heaven (void *o
)
1684 scm_lock_mutex (hell_mutex
);
1685 hell
[burnin (obj
)] = hell
[--n_hell
];
1686 scm_unlock_mutex (hell_mutex
);
1690 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1693 purgatory (SCM obj
, SCM new_class
)
1695 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1698 /* This function calls the generic function change-class for all
1699 * instances which aren't currently undergoing class change.
1703 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1707 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1708 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1709 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1710 purgatory (obj
, new_class
);
1715 /******************************************************************************
1721 * GGG E N E R I C F U N C T I O N S
1723 * This implementation provides
1724 * - generic functions (with class specializers)
1727 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1729 ******************************************************************************/
1731 SCM_KEYWORD (k_name
, "name");
1733 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1737 scm_apply_generic (SCM gf
, SCM args
)
1739 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1743 scm_call_generic_0 (SCM gf
)
1745 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1749 scm_call_generic_1 (SCM gf
, SCM a1
)
1751 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1755 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1757 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1761 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1763 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1766 static SCM delayed_compile_var
;
1769 init_delayed_compile_var (void)
1772 = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
1776 make_dispatch_procedure (SCM gf
)
1778 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
1779 scm_i_pthread_once (&once
, init_delayed_compile_var
);
1781 return scm_call_1 (scm_variable_ref (delayed_compile_var
), gf
);
1785 clear_method_cache (SCM gf
)
1787 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1788 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1791 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1794 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1796 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1797 clear_method_cache (gf
);
1798 return SCM_UNSPECIFIED
;
1802 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1805 #define FUNC_NAME s_scm_generic_capability_p
1807 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1808 proc
, SCM_ARG1
, FUNC_NAME
);
1809 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1813 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1816 #define FUNC_NAME s_scm_enable_primitive_generic_x
1818 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1819 while (!scm_is_null (subrs
))
1821 SCM subr
= SCM_CAR (subrs
);
1822 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1823 SCM_SET_SUBR_GENERIC (subr
,
1824 scm_make (scm_list_3 (scm_class_generic
,
1826 SCM_SUBR_NAME (subr
))));
1827 subrs
= SCM_CDR (subrs
);
1829 return SCM_UNSPECIFIED
;
1833 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1834 (SCM subr
, SCM generic
),
1836 #define FUNC_NAME s_scm_set_primitive_generic_x
1838 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1839 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1840 SCM_SET_SUBR_GENERIC (subr
, generic
);
1841 return SCM_UNSPECIFIED
;
1845 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1848 #define FUNC_NAME s_scm_primitive_generic_generic
1850 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1852 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1853 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1854 return *SCM_SUBR_GENERIC (subr
);
1856 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1860 typedef struct t_extension
{
1861 struct t_extension
*next
;
1867 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1869 static const char extension_gc_hint
[] = "GOOPS extension";
1871 static t_extension
*extensions
= 0;
1874 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1879 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1880 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1881 gf
= *SCM_SUBR_GENERIC (extended
);
1882 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1884 SCM_SUBR_NAME (extension
));
1885 SCM_SET_SUBR_GENERIC (extension
, gext
);
1889 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1891 t_extension
**loc
= &extensions
;
1892 /* Make sure that extensions are placed before their own
1893 * extensions in the extensions list. O(N^2) algorithm, but
1894 * extensions of primitive generics are rare.
1896 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1897 loc
= &(*loc
)->next
;
1899 e
->extended
= extended
;
1900 e
->extension
= extension
;
1906 setup_extended_primitive_generics ()
1910 t_extension
*e
= extensions
;
1911 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1912 extensions
= e
->next
;
1916 /******************************************************************************
1918 * Protocol for calling a generic fumction
1919 * This protocol is roughly equivalent to (parameter are a little bit different
1920 * for efficiency reasons):
1922 * + apply-generic (gf args)
1923 * + compute-applicable-methods (gf args ...)
1924 * + sort-applicable-methods (methods args)
1925 * + apply-methods (gf methods args)
1927 * apply-methods calls make-next-method to build the "continuation" of a a
1928 * method. Applying a next-method will call apply-next-method which in
1929 * turn will call apply again to call effectively the following method.
1931 ******************************************************************************/
1934 applicablep (SCM actual
, SCM formal
)
1936 /* We already know that the cpl is well formed. */
1937 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1941 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1943 register SCM s1
, s2
;
1947 * m1 and m2 can have != length (i.e. one can be one element longer than the
1948 * other when we have a dotted parameter list). For instance, with the call
1951 * (define-method M (a . l) ....)
1952 * (define-method M (a) ....)
1954 * we consider that the second method is more specific.
1956 * BTW, targs is an array of types. We don't need it's size since
1957 * we already know that m1 and m2 are applicable (no risk to go past
1958 * the end of this array).
1961 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1962 if (scm_is_null(s1
)) return 1;
1963 if (scm_is_null(s2
)) return 0;
1964 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1965 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1967 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1968 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1970 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1973 return 0;/* should not occur! */
1976 return 0; /* should not occur! */
1979 #define BUFFSIZE 32 /* big enough for most uses */
1982 scm_i_vector2list (SCM l
, long len
)
1985 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1987 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1988 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1994 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1997 SCM
*v
, vector
= SCM_EOL
;
1998 SCM buffer
[BUFFSIZE
];
1999 SCM save
= method_list
;
2000 scm_t_array_handle handle
;
2002 /* For reasonably sized method_lists we can try to avoid all the
2003 * consing and reorder the list in place...
2004 * This idea is due to David McClain <Dave_McClain@msn.com>
2006 if (size
<= BUFFSIZE
)
2008 for (i
= 0; i
< size
; i
++)
2010 buffer
[i
] = SCM_CAR (method_list
);
2011 method_list
= SCM_CDR (method_list
);
2017 /* Too many elements in method_list to keep everything locally */
2018 vector
= scm_i_vector2list (save
, size
);
2019 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2022 /* Use a simple shell sort since it is generally faster than qsort on
2023 * small vectors (which is probably mostly the case when we have to
2024 * sort a list of applicable methods).
2026 for (incr
= size
/ 2; incr
; incr
/= 2)
2028 for (i
= incr
; i
< size
; i
++)
2030 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2032 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2036 SCM tmp
= v
[j
+ incr
];
2044 if (size
<= BUFFSIZE
)
2046 /* We did it in locally, so restore the original list (reordered) in-place */
2047 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2049 SCM_SETCAR (method_list
, *v
);
2050 method_list
= SCM_CDR (method_list
);
2055 /* If we are here, that's that we did it the hard way... */
2056 scm_array_handle_release (&handle
);
2057 return scm_vector_to_list (vector
);
2061 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2065 SCM l
, fl
, applicable
= SCM_EOL
;
2067 SCM buffer
[BUFFSIZE
];
2071 scm_t_array_handle handle
;
2073 /* Build the list of arguments types */
2074 if (len
>= BUFFSIZE
)
2076 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2077 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2080 note that we don't have to work to reset the generation
2081 count. TMP is a new vector anyway, and it is found
2088 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2089 *p
++ = scm_class_of (SCM_CAR (args
));
2091 /* Build a list of all applicable methods */
2092 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2094 fl
= SPEC_OF (SCM_CAR (l
));
2095 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2097 if (SCM_INSTANCEP (fl
)
2098 /* We have a dotted argument list */
2099 || (i
>= len
&& scm_is_null (fl
)))
2100 { /* both list exhausted */
2101 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2107 || !applicablep (types
[i
], SCM_CAR (fl
)))
2112 if (len
>= BUFFSIZE
)
2113 scm_array_handle_release (&handle
);
2119 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2120 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2126 : sort_applicable_methods (applicable
, count
, types
));
2130 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2133 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2136 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2137 #define FUNC_NAME s_sys_compute_applicable_methods
2140 SCM_VALIDATE_GENERIC (1, gf
);
2141 n
= scm_ilength (args
);
2142 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2143 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2147 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2148 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2149 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2150 scm_sys_compute_applicable_methods
));
2152 /******************************************************************************
2154 * A simple make (which will be redefined later in Scheme)
2155 * This version handles only creation of gf, methods and classes (no instances)
2157 * Since this code will disappear when Goops will be fully booted,
2158 * no precaution is taken to be efficient.
2160 ******************************************************************************/
2162 SCM_KEYWORD (k_setter
, "setter");
2163 SCM_KEYWORD (k_specializers
, "specializers");
2164 SCM_KEYWORD (k_procedure
, "procedure");
2165 SCM_KEYWORD (k_formals
, "formals");
2166 SCM_KEYWORD (k_body
, "body");
2167 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2168 SCM_KEYWORD (k_dsupers
, "dsupers");
2169 SCM_KEYWORD (k_slots
, "slots");
2170 SCM_KEYWORD (k_gf
, "generic-function");
2172 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2174 "Make a new object. @var{args} must contain the class and\n"
2175 "all necessary initialization information.")
2176 #define FUNC_NAME s_scm_make
2179 long len
= scm_ilength (args
);
2181 if (len
<= 0 || (len
& 1) == 0)
2182 SCM_WRONG_NUM_ARGS ();
2184 class = SCM_CAR(args
);
2185 args
= SCM_CDR(args
);
2187 if (scm_is_eq (class, scm_class_generic
)
2188 || scm_is_eq (class, scm_class_accessor
))
2190 z
= scm_make_struct (class, SCM_INUM0
,
2191 scm_list_4 (SCM_BOOL_F
,
2195 scm_set_procedure_property_x (z
, scm_sym_name
,
2196 scm_get_keyword (k_name
,
2199 clear_method_cache (z
);
2200 if (scm_is_eq (class, scm_class_accessor
))
2202 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2203 if (scm_is_true (setter
))
2204 scm_sys_set_object_setter_x (z
, setter
);
2209 z
= scm_sys_allocate_instance (class, args
);
2211 if (scm_is_eq (class, scm_class_method
)
2212 || scm_is_eq (class, scm_class_accessor_method
))
2214 SCM_SET_SLOT (z
, scm_si_generic_function
,
2215 scm_i_get_keyword (k_gf
,
2220 SCM_SET_SLOT (z
, scm_si_specializers
,
2221 scm_i_get_keyword (k_specializers
,
2226 SCM_SET_SLOT (z
, scm_si_procedure
,
2227 scm_i_get_keyword (k_procedure
,
2232 SCM_SET_SLOT (z
, scm_si_formals
,
2233 scm_i_get_keyword (k_formals
,
2238 SCM_SET_SLOT (z
, scm_si_body
,
2239 scm_i_get_keyword (k_body
,
2244 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2245 scm_i_get_keyword (k_make_procedure
,
2253 /* In all the others case, make a new class .... No instance here */
2254 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2255 scm_i_get_keyword (k_name
,
2258 scm_from_latin1_symbol ("???"),
2260 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2261 scm_i_get_keyword (k_dsupers
,
2266 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2267 scm_i_get_keyword (k_slots
,
2278 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2281 #define FUNC_NAME s_scm_find_method
2284 long len
= scm_ilength (l
);
2287 SCM_WRONG_NUM_ARGS ();
2289 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2290 SCM_VALIDATE_GENERIC (1, gf
);
2291 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2292 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2294 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2298 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2299 (SCM m1
, SCM m2
, SCM targs
),
2300 "Return true if method @var{m1} is more specific than @var{m2} "
2301 "given the argument types (classes) listed in @var{targs}.")
2302 #define FUNC_NAME s_scm_sys_method_more_specific_p
2306 long i
, len
, m1_specs
, m2_specs
;
2307 scm_t_array_handle handle
;
2309 SCM_VALIDATE_METHOD (1, m1
);
2310 SCM_VALIDATE_METHOD (2, m2
);
2312 len
= scm_ilength (targs
);
2313 m1_specs
= scm_ilength (SPEC_OF (m1
));
2314 m2_specs
= scm_ilength (SPEC_OF (m2
));
2315 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2316 targs
, SCM_ARG3
, FUNC_NAME
);
2318 /* Verify that all the arguments of TARGS are classes and place them
2321 v
= scm_c_make_vector (len
, SCM_EOL
);
2322 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2324 for (i
= 0, l
= targs
;
2325 i
< len
&& scm_is_pair (l
);
2326 i
++, l
= SCM_CDR (l
))
2328 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2329 v_elts
[i
] = SCM_CAR (l
);
2331 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2333 scm_array_handle_release (&handle
);
2341 /******************************************************************************
2345 ******************************************************************************/
2347 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2348 assuming that currently the reverse is true. Recalculate slots and
2349 associated getters-n-setters. */
2351 fix_cpl (SCM c
, SCM before
, SCM after
)
2353 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2354 SCM ls
= scm_c_memq (after
, cpl
);
2357 if (scm_is_false (ls
))
2358 /* if this condition occurs, fix_cpl should not be applied this way */
2361 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2362 SCM_SETCAR (ls
, before
);
2363 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2365 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2366 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2367 SCM g_n_s
= compute_getters_n_setters (slots
);
2368 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2369 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2375 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2377 SCM tmp
= scm_from_locale_symbol (name
);
2379 *var
= scm_basic_make_class (meta
, tmp
,
2380 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2386 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2389 create_standard_classes (void)
2392 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2393 scm_from_latin1_symbol ("specializers"),
2395 scm_from_latin1_symbol ("formals"),
2396 scm_from_latin1_symbol ("body"),
2397 scm_from_latin1_symbol ("make-procedure"),
2399 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2401 k_slot_definition
));
2402 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2403 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2406 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2409 scm_from_latin1_symbol ("effective-methods"));
2410 SCM setter_slots
= scm_list_1 (sym_setter
);
2411 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2414 /* Foreign class slot classes */
2415 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2416 scm_class_class
, scm_class_top
, SCM_EOL
);
2417 make_stdcls (&scm_class_protected
, "<protected-slot>",
2418 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2419 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2420 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2421 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2422 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2423 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2424 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2425 make_stdcls (&scm_class_self
, "<self-slot>",
2426 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2427 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2429 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2431 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2433 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2435 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2437 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2439 make_stdcls (&scm_class_scm
, "<scm-slot>",
2440 scm_class_class
, scm_class_protected
, SCM_EOL
);
2441 make_stdcls (&scm_class_int
, "<int-slot>",
2442 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2443 make_stdcls (&scm_class_float
, "<float-slot>",
2444 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2445 make_stdcls (&scm_class_double
, "<double-slot>",
2446 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2448 /* Continue initialization of class <class> */
2450 slots
= build_class_class_slots ();
2451 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2452 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2453 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2454 compute_getters_n_setters (slots
));
2456 /* scm_class_generic functions classes */
2457 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2458 scm_class_class
, scm_class_class
, SCM_EOL
);
2459 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2460 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2461 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2462 make_stdcls (&scm_class_method
, "<method>",
2463 scm_class_class
, scm_class_object
, method_slots
);
2464 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2465 scm_class_class
, scm_class_method
, amethod_slots
);
2466 make_stdcls (&scm_class_applicable
, "<applicable>",
2467 scm_class_class
, scm_class_top
, SCM_EOL
);
2468 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2469 scm_class_applicable_struct_class
,
2470 scm_list_2 (scm_class_object
, scm_class_applicable
),
2471 scm_list_1 (sym_procedure
));
2472 make_stdcls (&scm_class_generic
, "<generic>",
2473 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2474 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2475 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2476 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2477 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2478 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2479 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2480 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2481 make_stdcls (&scm_class_accessor
, "<accessor>",
2482 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2483 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2484 make_stdcls (&scm_class_extended_generic_with_setter
,
2485 "<extended-generic-with-setter>",
2486 scm_class_applicable_struct_class
,
2487 scm_list_2 (scm_class_extended_generic
,
2488 scm_class_generic_with_setter
),
2490 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2491 SCM_CLASSF_PURE_GENERIC
);
2492 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2493 scm_class_applicable_struct_class
,
2494 scm_list_2 (scm_class_accessor
,
2495 scm_class_extended_generic_with_setter
),
2497 /* <extended-generic> is misplaced. */
2498 fix_cpl (scm_class_extended_accessor
,
2499 scm_class_extended_generic
, scm_class_generic_with_setter
);
2500 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2502 /* Primitive types classes */
2503 make_stdcls (&scm_class_boolean
, "<boolean>",
2504 scm_class_class
, scm_class_top
, SCM_EOL
);
2505 make_stdcls (&scm_class_char
, "<char>",
2506 scm_class_class
, scm_class_top
, SCM_EOL
);
2507 make_stdcls (&scm_class_list
, "<list>",
2508 scm_class_class
, scm_class_top
, SCM_EOL
);
2509 make_stdcls (&scm_class_pair
, "<pair>",
2510 scm_class_class
, scm_class_list
, SCM_EOL
);
2511 make_stdcls (&scm_class_null
, "<null>",
2512 scm_class_class
, scm_class_list
, SCM_EOL
);
2513 make_stdcls (&scm_class_string
, "<string>",
2514 scm_class_class
, scm_class_top
, SCM_EOL
);
2515 make_stdcls (&scm_class_symbol
, "<symbol>",
2516 scm_class_class
, scm_class_top
, SCM_EOL
);
2517 make_stdcls (&scm_class_vector
, "<vector>",
2518 scm_class_class
, scm_class_top
, SCM_EOL
);
2519 make_stdcls (&class_foreign
, "<foreign>",
2520 scm_class_class
, scm_class_top
, SCM_EOL
);
2521 make_stdcls (&class_hashtable
, "<hashtable>",
2522 scm_class_class
, scm_class_top
, SCM_EOL
);
2523 make_stdcls (&class_fluid
, "<fluid>",
2524 scm_class_class
, scm_class_top
, SCM_EOL
);
2525 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2526 scm_class_class
, scm_class_top
, SCM_EOL
);
2527 make_stdcls (&class_frame
, "<frame>",
2528 scm_class_class
, scm_class_top
, SCM_EOL
);
2529 make_stdcls (&class_objcode
, "<objcode>",
2530 scm_class_class
, scm_class_top
, SCM_EOL
);
2531 make_stdcls (&class_vm
, "<vm>",
2532 scm_class_class
, scm_class_top
, SCM_EOL
);
2533 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2534 scm_class_class
, scm_class_top
, SCM_EOL
);
2535 make_stdcls (&class_bytevector
, "<bytevector>",
2536 scm_class_class
, scm_class_top
, SCM_EOL
);
2537 make_stdcls (&class_uvec
, "<uvec>",
2538 scm_class_class
, class_bytevector
, SCM_EOL
);
2539 make_stdcls (&class_array
, "<array>",
2540 scm_class_class
, scm_class_top
, SCM_EOL
);
2541 make_stdcls (&class_bitvector
, "<bitvector>",
2542 scm_class_class
, scm_class_top
, SCM_EOL
);
2543 make_stdcls (&scm_class_number
, "<number>",
2544 scm_class_class
, scm_class_top
, SCM_EOL
);
2545 make_stdcls (&scm_class_complex
, "<complex>",
2546 scm_class_class
, scm_class_number
, SCM_EOL
);
2547 make_stdcls (&scm_class_real
, "<real>",
2548 scm_class_class
, scm_class_complex
, SCM_EOL
);
2549 make_stdcls (&scm_class_integer
, "<integer>",
2550 scm_class_class
, scm_class_real
, SCM_EOL
);
2551 make_stdcls (&scm_class_fraction
, "<fraction>",
2552 scm_class_class
, scm_class_real
, SCM_EOL
);
2553 make_stdcls (&scm_class_keyword
, "<keyword>",
2554 scm_class_class
, scm_class_top
, SCM_EOL
);
2555 make_stdcls (&scm_class_unknown
, "<unknown>",
2556 scm_class_class
, scm_class_top
, SCM_EOL
);
2557 make_stdcls (&scm_class_procedure
, "<procedure>",
2558 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2559 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2560 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2561 make_stdcls (&scm_class_port
, "<port>",
2562 scm_class_class
, scm_class_top
, SCM_EOL
);
2563 make_stdcls (&scm_class_input_port
, "<input-port>",
2564 scm_class_class
, scm_class_port
, SCM_EOL
);
2565 make_stdcls (&scm_class_output_port
, "<output-port>",
2566 scm_class_class
, scm_class_port
, SCM_EOL
);
2567 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2569 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2573 /**********************************************************************
2577 **********************************************************************/
2580 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2586 sprintf (buffer
, template, type_name
);
2587 name
= scm_from_locale_symbol (buffer
);
2590 name
= SCM_GOOPS_UNBOUND
;
2592 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2593 name
, supers
, SCM_EOL
);
2595 /* Only define name if doesn't already exist. */
2596 if (!SCM_GOOPS_UNBOUNDP (name
)
2597 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2598 DEFVAR (name
, class);
2603 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2606 if (scm_is_true (type_name_sym
))
2608 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2609 scm_symbol_to_string (type_name_sym
),
2610 scm_from_locale_string (">")));
2611 name
= scm_string_to_symbol (name
);
2614 name
= SCM_GOOPS_UNBOUND
;
2616 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2617 name
, supers
, SCM_EOL
);
2619 /* Only define name if doesn't already exist. */
2620 if (!SCM_GOOPS_UNBOUNDP (name
)
2621 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2622 DEFVAR (name
, class);
2627 scm_make_extended_class (char const *type_name
, int applicablep
)
2629 return make_class_from_template ("<%s>",
2631 scm_list_1 (applicablep
2632 ? scm_class_applicable
2638 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2640 return make_class_from_symbol (type_name_sym
,
2641 scm_list_1 (applicablep
2642 ? scm_class_applicable
2648 scm_i_inherit_applicable (SCM c
)
2650 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2652 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2653 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2654 /* patch scm_class_applicable into direct-supers */
2655 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2656 if (scm_is_false (top
))
2657 dsupers
= scm_append (scm_list_2 (dsupers
,
2658 scm_list_1 (scm_class_applicable
)));
2661 SCM_SETCAR (top
, scm_class_applicable
);
2662 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2664 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2665 /* patch scm_class_applicable into cpl */
2666 top
= scm_c_memq (scm_class_top
, cpl
);
2667 if (scm_is_false (top
))
2671 SCM_SETCAR (top
, scm_class_applicable
);
2672 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2674 /* add class to direct-subclasses of scm_class_applicable */
2675 SCM_SET_SLOT (scm_class_applicable
,
2676 scm_si_direct_subclasses
,
2677 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2678 scm_si_direct_subclasses
)));
2683 create_smob_classes (void)
2687 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2688 scm_smob_class
[i
] = SCM_BOOL_F
;
2690 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2692 for (i
= 0; i
< scm_numsmob
; ++i
)
2693 if (scm_is_false (scm_smob_class
[i
]))
2694 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2695 scm_smobs
[i
].apply
!= 0);
2699 scm_make_port_classes (long ptobnum
, char *type_name
)
2701 SCM c
, class = make_class_from_template ("<%s-port>",
2703 scm_list_1 (scm_class_port
),
2705 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2706 = make_class_from_template ("<%s-input-port>",
2708 scm_list_2 (class, scm_class_input_port
),
2710 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2711 = make_class_from_template ("<%s-output-port>",
2713 scm_list_2 (class, scm_class_output_port
),
2715 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2717 = make_class_from_template ("<%s-input-output-port>",
2719 scm_list_2 (class, scm_class_input_output_port
),
2721 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2722 SCM_SET_SLOT (c
, scm_si_cpl
,
2723 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2727 create_port_classes (void)
2731 for (i
= 0; i
< scm_numptob
; ++i
)
2732 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2736 make_struct_class (void *closure SCM_UNUSED
,
2737 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2739 if (scm_is_false (data
))
2740 scm_i_define_class_for_vtable (vtable
);
2741 return SCM_UNSPECIFIED
;
2745 create_struct_classes (void)
2747 /* FIXME: take the vtable_class_map while initializing goops? */
2748 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2752 /**********************************************************************
2756 **********************************************************************/
2761 if (!goops_loaded_p
)
2762 scm_c_resolve_module ("oop goops");
2766 SCM_SYMBOL (sym_o
, "o");
2767 SCM_SYMBOL (sym_x
, "x");
2769 SCM_KEYWORD (k_accessor
, "accessor");
2770 SCM_KEYWORD (k_getter
, "getter");
2773 scm_ensure_accessor (SCM name
)
2777 var
= scm_module_variable (scm_current_module (), name
);
2778 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2779 gf
= SCM_VARIABLE_REF (var
);
2783 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2785 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2786 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2787 k_name
, name
, k_setter
, gf
));
2795 * Debugging utilities
2798 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2800 "Return @code{#t} if @var{obj} is a pure generic.")
2801 #define FUNC_NAME s_scm_pure_generic_p
2803 return scm_from_bool (SCM_PUREGENERICP (obj
));
2807 #endif /* GUILE_DEBUG */
2813 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2815 "Announce that GOOPS is loaded and perform initialization\n"
2816 "on the C level which depends on the loaded GOOPS modules.")
2817 #define FUNC_NAME s_scm_sys_goops_loaded
2820 var_compute_applicable_methods
=
2821 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2823 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2825 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2827 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2828 var_no_applicable_method
=
2829 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2831 scm_module_variable (scm_module_goops
, sym_change_class
);
2832 setup_extended_primitive_generics ();
2833 return SCM_UNSPECIFIED
;
2837 SCM scm_module_goops
;
2840 scm_init_goops_builtins (void)
2842 scm_module_goops
= scm_current_module ();
2844 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2846 #include "libguile/goops.x"
2848 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2849 hell_mutex
= scm_make_mutex ();
2851 create_basic_classes ();
2852 create_standard_classes ();
2853 create_smob_classes ();
2854 create_struct_classes ();
2855 create_port_classes ();
2858 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2859 scm_no_applicable_method
=
2860 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2861 DEFVAR (name
, scm_no_applicable_method
);
2864 return SCM_UNSPECIFIED
;
2870 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2871 scm_init_goops_builtins
);