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/vm.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
61 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
64 #define SCM_IN_PCLASS_INDEX 0
65 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
66 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
68 /* this file is a mess. in theory, though, we shouldn't have many SCM references
69 -- most of the references should be to vars. */
71 static SCM var_slot_unbound
= SCM_BOOL_F
;
72 static SCM var_slot_missing
= SCM_BOOL_F
;
73 static SCM var_compute_cpl
= SCM_BOOL_F
;
74 static SCM var_no_applicable_method
= SCM_BOOL_F
;
75 static SCM var_change_class
= SCM_BOOL_F
;
77 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
78 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
79 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
80 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
81 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
82 SCM_SYMBOL (sym_change_class
, "change-class");
84 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
87 /* Class redefinition protocol:
89 A class is represented by a heap header h1 which points to a
90 malloc:ed memory block m1.
92 When a new version of a class is created, a new header h2 and
93 memory block m2 are allocated. The headers h1 and h2 then switch
94 pointers so that h1 refers to m2 and h2 to m1. In this way, names
95 bound to h1 will point to the new class at the same time as h2 will
96 be a handle which the GC will use to free m1.
98 The `redefined' slot of m1 will be set to point to h1. An old
99 instance will have its class pointer (the CAR of the heap header)
100 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
101 the class modification and the new class pointer can be found via
105 #define TEST_CHANGE_CLASS(obj, class) \
107 class = SCM_CLASS_OF (obj); \
108 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
110 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
111 class = SCM_CLASS_OF (obj); \
115 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
116 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
118 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
119 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
121 static int goops_loaded_p
= 0;
122 static scm_t_rstate
*goops_rstate
;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
126 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
127 SCM scm_class_primitive_generic
;
128 SCM scm_class_vector
, scm_class_null
;
129 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
130 SCM scm_class_unknown
;
131 SCM scm_class_top
, scm_class_object
, scm_class_class
;
132 SCM scm_class_applicable
;
133 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
134 SCM scm_class_generic
, scm_class_generic_with_setter
;
135 SCM scm_class_accessor
;
136 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
137 SCM scm_class_extended_accessor
;
138 SCM scm_class_method
;
139 SCM scm_class_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_applicable_struct_class
;
142 SCM scm_class_number
, scm_class_list
;
143 SCM scm_class_keyword
;
144 SCM scm_class_port
, scm_class_input_output_port
;
145 SCM scm_class_input_port
, scm_class_output_port
;
146 SCM scm_class_foreign_slot
;
147 SCM scm_class_self
, scm_class_protected
;
148 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
149 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
151 SCM scm_class_int
, scm_class_float
, scm_class_double
;
153 static SCM class_foreign
;
154 static SCM class_hashtable
;
155 static SCM class_fluid
;
156 static SCM class_dynamic_state
;
157 static SCM class_frame
;
158 static SCM class_objcode
;
160 static SCM class_vm_cont
;
161 static SCM class_bytevector
;
162 static SCM class_uvec
;
163 static SCM class_array
;
164 static SCM class_bitvector
;
166 static SCM vtable_class_map
= SCM_BOOL_F
;
168 /* Port classes. Allocate 3 times the maximum number of port types so that
169 input ports, output ports, and in/out ports can be stored at different
170 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
171 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
174 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
176 SCM scm_no_applicable_method
;
178 SCM_SYMBOL (scm_sym_define_public
, "define-public");
180 static SCM
scm_make_unbound (void);
181 static SCM
scm_unbound_p (SCM obj
);
182 static SCM
scm_assert_bound (SCM value
, SCM obj
);
183 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
184 static SCM
scm_sys_goops_loaded (void);
185 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
190 scm_i_define_class_for_vtable (SCM vtable
)
194 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
195 if (scm_is_false (vtable_class_map
))
196 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
197 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
199 if (scm_is_false (scm_struct_vtable_p (vtable
)))
202 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
204 if (scm_is_false (class))
206 if (SCM_UNPACK (scm_class_class
))
208 SCM name
= SCM_VTABLE_NAME (vtable
);
209 if (!scm_is_symbol (name
))
210 name
= scm_string_to_symbol (scm_nullstr
);
212 class = scm_make_extended_class_from_symbol
213 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
216 /* `create_struct_classes' will fill this in later. */
219 /* Don't worry about races. This only happens when creating a
220 vtable, which happens by definition in one thread. */
221 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
227 /* This function is used for efficient type dispatch. */
228 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
230 "Return the class of @var{x}.")
231 #define FUNC_NAME s_scm_class_of
233 switch (SCM_ITAG3 (x
))
237 return scm_class_integer
;
241 return scm_class_char
;
242 else if (scm_is_bool (x
))
243 return scm_class_boolean
;
244 else if (scm_is_null (x
))
245 return scm_class_null
;
247 return scm_class_unknown
;
250 switch (SCM_TYP7 (x
))
252 case scm_tcs_cons_nimcar
:
253 return scm_class_pair
;
255 return scm_class_symbol
;
258 return scm_class_vector
;
259 case scm_tc7_pointer
:
260 return class_foreign
;
261 case scm_tc7_hashtable
:
262 return class_hashtable
;
265 case scm_tc7_dynamic_state
:
266 return class_dynamic_state
;
269 case scm_tc7_objcode
:
270 return class_objcode
;
273 case scm_tc7_vm_cont
:
274 return class_vm_cont
;
275 case scm_tc7_bytevector
:
276 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
277 return class_bytevector
;
282 case scm_tc7_bitvector
:
283 return class_bitvector
;
285 return scm_class_string
;
287 switch SCM_TYP16 (x
) {
289 return scm_class_integer
;
291 return scm_class_real
;
292 case scm_tc16_complex
:
293 return scm_class_complex
;
294 case scm_tc16_fraction
:
295 return scm_class_fraction
;
297 case scm_tc7_program
:
298 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
299 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
300 return scm_class_primitive_generic
;
302 return scm_class_procedure
;
306 scm_t_bits type
= SCM_TYP16 (x
);
307 if (type
!= scm_tc16_port_with_ps
)
308 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
309 x
= SCM_PORT_WITH_PS_PORT (x
);
310 /* fall through to ports */
313 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
314 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
315 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
316 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
317 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
319 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
320 return SCM_CLASS_OF (x
);
321 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
324 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
325 scm_change_object_class (x
,
326 SCM_CLASS_OF (x
), /* old */
327 SCM_OBJ_CLASS_REDEF (x
)); /* new */
328 return SCM_CLASS_OF (x
);
331 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
334 return scm_class_pair
;
336 return scm_class_unknown
;
342 /* case scm_tc3_unused: */
346 return scm_class_unknown
;
350 /******************************************************************************
354 * This version doesn't fully handle multiple-inheritance. It serves
355 * only for booting classes and will be overloaded in Scheme
357 ******************************************************************************/
360 map (SCM (*proc
) (SCM
), SCM ls
)
362 if (scm_is_null (ls
))
366 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
369 while (scm_is_pair (ls
))
371 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
383 while (scm_is_pair (ls
))
385 SCM el
= SCM_CAR (ls
);
386 if (scm_is_false (scm_c_memq (el
, res
)))
387 res
= scm_cons (el
, res
);
394 compute_cpl (SCM
class)
397 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
400 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
401 SCM ls
= scm_append (scm_acons (class, supers
,
402 map (compute_cpl
, supers
)));
403 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
407 /******************************************************************************
411 ******************************************************************************/
414 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
418 if (!scm_is_pair (l
))
422 if (!scm_is_symbol (tmp
))
423 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
425 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
426 res
= scm_cons (SCM_CAR (l
), res
);
427 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
430 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
434 check_cpl (SCM slots
, SCM bslots
)
436 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
437 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
438 scm_misc_error ("init-object", "a predefined <class> inherited "
439 "field cannot be redefined", SCM_EOL
);
443 build_class_class_slots (void);
446 build_slots_list (SCM dslots
, SCM cpl
)
448 SCM bslots
, class_slots
;
452 class_slots
= SCM_EOL
;
453 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
457 bslots
= build_class_class_slots ();
458 check_cpl (res
, bslots
);
463 if (scm_is_pair (cpl
))
465 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
467 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
468 scm_si_direct_slots
);
471 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
472 check_cpl (new_slots
, bslots
);
475 /* Move class slots to the head of the list. */
476 class_slots
= new_slots
;
480 res
= scm_append (scm_list_2 (new_slots
, res
));
484 scm_misc_error ("%compute-slots", "malformed cpl argument in "
485 "build_slots_list", SCM_EOL
);
487 /* make sure to add the <class> slots to the head of the list */
489 res
= scm_append (scm_list_2 (class_slots
, res
));
491 /* res contains a list of slots. Remove slots which appears more than once */
492 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
499 while (!scm_is_null (ls
))
501 if (!scm_is_pair (ls
))
502 scm_misc_error ("%compute-slots", "malformed ls argument in "
504 if (!scm_is_pair (SCM_CAR (ls
)))
505 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
512 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
514 "Return a list consisting of the names of all slots belonging to\n"
515 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
517 #define FUNC_NAME s_scm_sys_compute_slots
519 SCM_VALIDATE_CLASS (1, class);
520 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
521 SCM_SLOT (class, scm_si_cpl
));
526 /******************************************************************************
528 * compute-getters-n-setters
530 * This version doesn't handle slot options. It serves only for booting
531 * classes and will be overloaded in Scheme.
533 ******************************************************************************/
535 SCM_KEYWORD (k_init_value
, "init-value");
536 SCM_KEYWORD (k_init_thunk
, "init-thunk");
539 compute_getters_n_setters (SCM slots
)
545 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
547 SCM init
= SCM_BOOL_F
;
548 SCM options
= SCM_CDAR (slots
);
549 if (!scm_is_null (options
))
551 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
552 if (SCM_UNPACK (init
))
554 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
556 scm_list_2 (scm_sym_quote
,
560 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
562 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
564 scm_from_int (i
++))),
566 cdrloc
= SCM_CDRLOC (*cdrloc
);
571 /******************************************************************************
575 ******************************************************************************/
577 /*fixme* Manufacture keywords in advance */
579 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
583 for (i
= 0; i
!= len
; i
+= 2)
585 SCM obj
= SCM_CAR (l
);
587 if (!scm_is_keyword (obj
))
588 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
589 else if (scm_is_eq (obj
, key
))
595 return default_value
;
599 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
600 (SCM key
, SCM l
, SCM default_value
),
601 "Determine an associated value for the keyword @var{key} from\n"
602 "the list @var{l}. The list @var{l} has to consist of an even\n"
603 "number of elements, where, starting with the first, every\n"
604 "second element is a keyword, followed by its associated value.\n"
605 "If @var{l} does not hold a value for @var{key}, the value\n"
606 "@var{default_value} is returned.")
607 #define FUNC_NAME s_scm_get_keyword
611 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
612 len
= scm_ilength (l
);
613 if (len
< 0 || len
% 2 == 1)
614 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
616 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
621 SCM_KEYWORD (k_init_keyword
, "init-keyword");
623 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
624 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
626 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
627 (SCM obj
, SCM initargs
),
628 "Initialize the object @var{obj} with the given arguments\n"
630 #define FUNC_NAME s_scm_sys_initialize_object
632 SCM tmp
, get_n_set
, slots
;
633 SCM
class = SCM_CLASS_OF (obj
);
636 SCM_VALIDATE_INSTANCE (1, obj
);
637 n_initargs
= scm_ilength (initargs
);
638 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
640 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
641 slots
= SCM_SLOT (class, scm_si_slots
);
643 /* See for each slot how it must be initialized */
645 !scm_is_null (slots
);
646 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
648 SCM slot_name
= SCM_CAR (slots
);
649 SCM slot_value
= SCM_PACK (0);
651 if (!scm_is_null (SCM_CDR (slot_name
)))
653 /* This slot admits (perhaps) to be initialized at creation time */
654 long n
= scm_ilength (SCM_CDR (slot_name
));
655 if (n
& 1) /* odd or -1 */
656 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
657 scm_list_1 (slot_name
));
658 tmp
= scm_i_get_keyword (k_init_keyword
,
663 slot_name
= SCM_CAR (slot_name
);
664 if (SCM_UNPACK (tmp
))
666 /* an initarg was provided for this slot */
667 if (!scm_is_keyword (tmp
))
668 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
670 slot_value
= scm_i_get_keyword (tmp
,
678 if (SCM_UNPACK (slot_value
))
679 /* set slot to provided value */
680 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
683 /* set slot to its :init-form if it exists */
684 tmp
= SCM_CADAR (get_n_set
);
685 if (scm_is_true (tmp
))
687 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
688 if (SCM_GOOPS_UNBOUNDP (slot_value
))
689 set_slot_value (class,
701 /* NOTE: The following macros are interdependent with code
702 * in goops.scm:compute-getters-n-setters
704 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
705 (SCM_I_INUMP (SCM_CDDR (gns)) \
706 || (scm_is_pair (SCM_CDDR (gns)) \
707 && scm_is_pair (SCM_CDDDR (gns)) \
708 && scm_is_pair (SCM_CDDDDR (gns))))
709 #define SCM_GNS_INDEX(gns) \
710 (SCM_I_INUMP (SCM_CDDR (gns)) \
711 ? SCM_I_INUM (SCM_CDDR (gns)) \
712 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
713 #define SCM_GNS_SIZE(gns) \
714 (SCM_I_INUMP (SCM_CDDR (gns)) \
716 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
718 SCM_KEYWORD (k_class
, "class");
719 SCM_KEYWORD (k_allocation
, "allocation");
720 SCM_KEYWORD (k_instance
, "instance");
722 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
725 #define FUNC_NAME s_scm_sys_prep_layout_x
727 SCM slots
, getters_n_setters
, nfields
;
728 unsigned long int n
, i
;
732 SCM_VALIDATE_INSTANCE (1, class);
733 slots
= SCM_SLOT (class, scm_si_slots
);
734 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
735 nfields
= SCM_SLOT (class, scm_si_nfields
);
736 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
737 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
738 scm_list_1 (nfields
));
739 n
= 2 * SCM_I_INUM (nfields
);
740 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
741 && SCM_SUBCLASSP (class, scm_class_class
))
742 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
743 scm_list_1 (nfields
));
745 layout
= scm_i_make_string (n
, &s
, 0);
747 while (scm_is_pair (getters_n_setters
))
749 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
752 int len
, index
, size
;
755 if (i
>= n
|| !scm_is_pair (slots
))
758 /* extract slot type */
759 len
= scm_ilength (SCM_CDAR (slots
));
760 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
761 len
, SCM_BOOL_F
, FUNC_NAME
);
762 /* determine slot GC protection and access mode */
763 if (scm_is_false (type
))
770 if (!SCM_CLASSP (type
))
771 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
772 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
774 if (SCM_SUBCLASSP (type
, scm_class_self
))
776 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
781 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
783 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
785 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
797 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
798 if (index
!= (i
>> 1))
800 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
808 slots
= SCM_CDR (slots
);
809 getters_n_setters
= SCM_CDR (getters_n_setters
);
811 if (!scm_is_null (slots
))
814 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
816 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
817 return SCM_UNSPECIFIED
;
821 static void prep_hashsets (SCM
);
823 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
824 (SCM
class, SCM dsupers
),
826 #define FUNC_NAME s_scm_sys_inherit_magic_x
828 SCM_VALIDATE_INSTANCE (1, class);
829 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
830 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
832 prep_hashsets (class);
834 return SCM_UNSPECIFIED
;
839 prep_hashsets (SCM
class)
843 for (i
= 0; i
< 8; ++i
)
844 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
847 /******************************************************************************/
850 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
852 SCM z
, cpl
, slots
, nfields
, g_n_s
;
854 /* Allocate one instance */
855 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
857 /* Initialize its slots */
858 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
859 cpl
= compute_cpl (z
);
860 slots
= build_slots_list (maplist (dslots
), cpl
);
861 nfields
= scm_from_int (scm_ilength (slots
));
862 g_n_s
= compute_getters_n_setters (slots
);
864 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
865 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
866 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
867 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
868 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
869 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
870 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
871 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
872 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
874 /* Add this class in the direct-subclasses slot of dsupers */
877 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
878 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
879 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
880 scm_si_direct_subclasses
)));
887 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
889 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
890 scm_sys_prep_layout_x (z
);
891 scm_sys_inherit_magic_x (z
, dsupers
);
895 /******************************************************************************/
897 SCM_SYMBOL (sym_layout
, "layout");
898 SCM_SYMBOL (sym_flags
, "flags");
899 SCM_SYMBOL (sym_self
, "%self");
900 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
901 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
902 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
903 SCM_SYMBOL (sym_print
, "print");
904 SCM_SYMBOL (sym_procedure
, "procedure");
905 SCM_SYMBOL (sym_setter
, "setter");
906 SCM_SYMBOL (sym_redefined
, "redefined");
907 SCM_SYMBOL (sym_h0
, "h0");
908 SCM_SYMBOL (sym_h1
, "h1");
909 SCM_SYMBOL (sym_h2
, "h2");
910 SCM_SYMBOL (sym_h3
, "h3");
911 SCM_SYMBOL (sym_h4
, "h4");
912 SCM_SYMBOL (sym_h5
, "h5");
913 SCM_SYMBOL (sym_h6
, "h6");
914 SCM_SYMBOL (sym_h7
, "h7");
915 SCM_SYMBOL (sym_name
, "name");
916 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
917 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
918 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
919 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
920 SCM_SYMBOL (sym_cpl
, "cpl");
921 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
922 SCM_SYMBOL (sym_slots
, "slots");
923 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
924 SCM_SYMBOL (sym_nfields
, "nfields");
928 build_class_class_slots (void)
930 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
931 SCM_CLASS_CLASS_LAYOUT */
933 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
934 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
935 scm_list_3 (sym_self
, k_class
, scm_class_self
),
936 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
937 scm_list_1 (sym_print
),
938 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
939 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
940 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
941 scm_list_1 (sym_redefined
),
942 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
943 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
944 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
945 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
946 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
947 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
948 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
949 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
950 scm_list_1 (sym_direct_supers
),
951 scm_list_1 (sym_direct_slots
),
952 scm_list_1 (sym_direct_subclasses
),
953 scm_list_1 (sym_direct_methods
),
954 scm_list_1 (sym_cpl
),
955 scm_list_1 (sym_default_slot_definition_class
),
956 scm_list_1 (sym_slots
),
957 scm_list_1 (sym_getters_n_setters
),
958 scm_list_1 (sym_nfields
),
963 create_basic_classes (void)
965 /* SCM slots_of_class = build_class_class_slots (); */
968 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
969 SCM name
= scm_from_latin1_symbol ("<class>");
970 scm_class_class
= scm_i_make_vtable_vtable (cs
);
971 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
972 | SCM_CLASSF_METACLASS
));
974 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
975 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
976 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
977 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
978 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
979 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
980 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
981 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
982 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
983 compute_getters_n_setters (slots_of_class)); */
984 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
986 prep_hashsets (scm_class_class
);
988 scm_module_define (scm_module_goops
, name
, scm_class_class
);
991 name
= scm_from_latin1_symbol ("<top>");
992 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
995 scm_module_define (scm_module_goops
, name
, scm_class_top
);
998 name
= scm_from_latin1_symbol ("<object>");
999 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
1000 scm_list_1 (scm_class_top
), SCM_EOL
);
1002 scm_module_define (scm_module_goops
, name
, scm_class_object
);
1004 /* <top> <object> and <class> were partially initialized. Correct them here */
1005 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1007 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1008 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1011 /******************************************************************************/
1013 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1015 "Return @code{#t} if @var{obj} is an instance.")
1016 #define FUNC_NAME s_scm_instance_p
1018 return scm_from_bool (SCM_INSTANCEP (obj
));
1023 /******************************************************************************
1025 * Meta object accessors
1027 ******************************************************************************/
1028 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1030 "Return the class name of @var{obj}.")
1031 #define FUNC_NAME s_scm_class_name
1033 SCM_VALIDATE_CLASS (1, obj
);
1034 return scm_slot_ref (obj
, sym_name
);
1038 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1040 "Return the direct superclasses of the class @var{obj}.")
1041 #define FUNC_NAME s_scm_class_direct_supers
1043 SCM_VALIDATE_CLASS (1, obj
);
1044 return scm_slot_ref (obj
, sym_direct_supers
);
1048 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1050 "Return the direct slots of the class @var{obj}.")
1051 #define FUNC_NAME s_scm_class_direct_slots
1053 SCM_VALIDATE_CLASS (1, obj
);
1054 return scm_slot_ref (obj
, sym_direct_slots
);
1058 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1060 "Return the direct subclasses of the class @var{obj}.")
1061 #define FUNC_NAME s_scm_class_direct_subclasses
1063 SCM_VALIDATE_CLASS (1, obj
);
1064 return scm_slot_ref(obj
, sym_direct_subclasses
);
1068 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1070 "Return the direct methods of the class @var{obj}")
1071 #define FUNC_NAME s_scm_class_direct_methods
1073 SCM_VALIDATE_CLASS (1, obj
);
1074 return scm_slot_ref (obj
, sym_direct_methods
);
1078 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1080 "Return the class precedence list of the class @var{obj}.")
1081 #define FUNC_NAME s_scm_class_precedence_list
1083 SCM_VALIDATE_CLASS (1, obj
);
1084 return scm_slot_ref (obj
, sym_cpl
);
1088 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1090 "Return the slot list of the class @var{obj}.")
1091 #define FUNC_NAME s_scm_class_slots
1093 SCM_VALIDATE_CLASS (1, obj
);
1094 return scm_slot_ref (obj
, sym_slots
);
1098 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1100 "Return the name of the generic function @var{obj}.")
1101 #define FUNC_NAME s_scm_generic_function_name
1103 SCM_VALIDATE_GENERIC (1, obj
);
1104 return scm_procedure_property (obj
, scm_sym_name
);
1108 SCM_SYMBOL (sym_methods
, "methods");
1109 SCM_SYMBOL (sym_extended_by
, "extended-by");
1110 SCM_SYMBOL (sym_extends
, "extends");
1113 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1115 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1116 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1117 while (!scm_is_null (gfs
))
1119 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1120 gfs
= SCM_CDR (gfs
);
1122 return method_lists
;
1126 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1128 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1130 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1131 while (!scm_is_null (gfs
))
1133 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1134 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1137 gfs
= SCM_CDR (gfs
);
1140 return method_lists
;
1143 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1145 "Return the methods of the generic function @var{obj}.")
1146 #define FUNC_NAME s_scm_generic_function_methods
1149 SCM_VALIDATE_GENERIC (1, obj
);
1150 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1151 methods
= fold_downward_gf_methods (methods
, obj
);
1152 return scm_append (methods
);
1156 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1158 "Return the generic function for the method @var{obj}.")
1159 #define FUNC_NAME s_scm_method_generic_function
1161 SCM_VALIDATE_METHOD (1, obj
);
1162 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1166 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1168 "Return specializers of the method @var{obj}.")
1169 #define FUNC_NAME s_scm_method_specializers
1171 SCM_VALIDATE_METHOD (1, obj
);
1172 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1176 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1178 "Return the procedure of the method @var{obj}.")
1179 #define FUNC_NAME s_scm_method_procedure
1181 SCM_VALIDATE_METHOD (1, obj
);
1182 return scm_slot_ref (obj
, sym_procedure
);
1186 /******************************************************************************
1188 * S l o t a c c e s s
1190 ******************************************************************************/
1192 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1194 "Return the unbound value.")
1195 #define FUNC_NAME s_scm_make_unbound
1197 return SCM_GOOPS_UNBOUND
;
1201 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1203 "Return @code{#t} if @var{obj} is unbound.")
1204 #define FUNC_NAME s_scm_unbound_p
1206 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1210 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1211 (SCM value
, SCM obj
),
1212 "Return @var{value} if it is bound, and invoke the\n"
1213 "@var{slot-unbound} method of @var{obj} if it is not.")
1214 #define FUNC_NAME s_scm_assert_bound
1216 if (SCM_GOOPS_UNBOUNDP (value
))
1217 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1222 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1223 (SCM obj
, SCM index
),
1224 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1225 "the value from @var{obj}.")
1226 #define FUNC_NAME s_scm_at_assert_bound_ref
1228 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1229 if (SCM_GOOPS_UNBOUNDP (value
))
1230 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1235 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1236 (SCM obj
, SCM index
),
1237 "Return the slot value with index @var{index} from @var{obj}.")
1238 #define FUNC_NAME s_scm_sys_fast_slot_ref
1242 SCM_VALIDATE_INSTANCE (1, obj
);
1243 i
= scm_to_unsigned_integer (index
, 0,
1244 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1247 return SCM_SLOT (obj
, i
);
1251 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1252 (SCM obj
, SCM index
, SCM value
),
1253 "Set the slot with index @var{index} in @var{obj} to\n"
1255 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1259 SCM_VALIDATE_INSTANCE (1, obj
);
1260 i
= scm_to_unsigned_integer (index
, 0,
1261 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1265 SCM_SET_SLOT (obj
, i
, value
);
1267 return SCM_UNSPECIFIED
;
1275 /* In the future, this function will return the effective slot
1276 * definition associated with SLOT_NAME. Now it just returns some of
1277 * the information which will be stored in the effective slot
1282 slot_definition_using_name (SCM
class, SCM slot_name
)
1284 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1285 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1286 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1287 return SCM_CAR (slots
);
1292 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1293 #define FUNC_NAME "%get-slot-value"
1295 SCM access
= SCM_CDDR (slotdef
);
1297 * - access is an integer (the offset of this slot in the slots vector)
1298 * - otherwise (car access) is the getter function to apply
1300 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1301 * we can just assume fixnums here.
1303 if (SCM_I_INUMP (access
))
1304 /* Don't poke at the slots directly, because scm_struct_ref handles the
1305 access bits for us. */
1306 return scm_struct_ref (obj
, access
);
1308 return scm_call_1 (SCM_CAR (access
), obj
);
1313 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1315 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1316 if (scm_is_true (slotdef
))
1317 return get_slot_value (class, obj
, slotdef
);
1319 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1323 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1324 #define FUNC_NAME "%set-slot-value"
1326 SCM access
= SCM_CDDR (slotdef
);
1328 * - access is an integer (the offset of this slot in the slots vector)
1329 * - otherwise (cadr access) is the setter function to apply
1331 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1332 * we can just assume fixnums here.
1334 if (SCM_I_INUMP (access
))
1335 /* obey permissions bits via going through struct-set! */
1336 scm_struct_set_x (obj
, access
, value
);
1338 /* ((cadr l) obj value) */
1339 scm_call_2 (SCM_CADR (access
), obj
, value
);
1340 return SCM_UNSPECIFIED
;
1345 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1347 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1348 if (scm_is_true (slotdef
))
1349 return set_slot_value (class, obj
, slotdef
, value
);
1351 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1355 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1359 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1360 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1366 /* ======================================== */
1368 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1369 (SCM
class, SCM obj
, SCM slot_name
),
1371 #define FUNC_NAME s_scm_slot_ref_using_class
1375 SCM_VALIDATE_CLASS (1, class);
1376 SCM_VALIDATE_INSTANCE (2, obj
);
1377 SCM_VALIDATE_SYMBOL (3, slot_name
);
1379 res
= get_slot_value_using_name (class, obj
, slot_name
);
1380 if (SCM_GOOPS_UNBOUNDP (res
))
1381 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1387 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1388 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1390 #define FUNC_NAME s_scm_slot_set_using_class_x
1392 SCM_VALIDATE_CLASS (1, class);
1393 SCM_VALIDATE_INSTANCE (2, obj
);
1394 SCM_VALIDATE_SYMBOL (3, slot_name
);
1396 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1401 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1402 (SCM
class, SCM obj
, SCM slot_name
),
1404 #define FUNC_NAME s_scm_slot_bound_using_class_p
1406 SCM_VALIDATE_CLASS (1, class);
1407 SCM_VALIDATE_INSTANCE (2, obj
);
1408 SCM_VALIDATE_SYMBOL (3, slot_name
);
1410 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1416 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1417 (SCM
class, SCM obj
, SCM slot_name
),
1419 #define FUNC_NAME s_scm_slot_exists_using_class_p
1421 SCM_VALIDATE_CLASS (1, class);
1422 SCM_VALIDATE_INSTANCE (2, obj
);
1423 SCM_VALIDATE_SYMBOL (3, slot_name
);
1424 return test_slot_existence (class, obj
, slot_name
);
1429 /* ======================================== */
1431 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1432 (SCM obj
, SCM slot_name
),
1433 "Return the value from @var{obj}'s slot with the name\n"
1435 #define FUNC_NAME s_scm_slot_ref
1439 SCM_VALIDATE_INSTANCE (1, obj
);
1440 TEST_CHANGE_CLASS (obj
, class);
1442 res
= get_slot_value_using_name (class, obj
, slot_name
);
1443 if (SCM_GOOPS_UNBOUNDP (res
))
1444 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1449 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1450 (SCM obj
, SCM slot_name
, SCM value
),
1451 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1452 #define FUNC_NAME s_scm_slot_set_x
1456 SCM_VALIDATE_INSTANCE (1, obj
);
1457 TEST_CHANGE_CLASS(obj
, class);
1459 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1463 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1465 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1466 (SCM obj
, SCM slot_name
),
1467 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1469 #define FUNC_NAME s_scm_slot_bound_p
1473 SCM_VALIDATE_INSTANCE (1, obj
);
1474 TEST_CHANGE_CLASS(obj
, class);
1476 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1484 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1485 (SCM obj
, SCM slot_name
),
1486 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1487 #define FUNC_NAME s_scm_slot_exists_p
1491 SCM_VALIDATE_INSTANCE (1, obj
);
1492 SCM_VALIDATE_SYMBOL (2, slot_name
);
1493 TEST_CHANGE_CLASS (obj
, class);
1495 return test_slot_existence (class, obj
, slot_name
);
1500 /******************************************************************************
1502 * %allocate-instance (the low level instance allocation primitive)
1504 ******************************************************************************/
1506 static void clear_method_cache (SCM
);
1508 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1509 (SCM
class, SCM initargs
),
1510 "Create a new instance of class @var{class} and initialize it\n"
1511 "from the arguments @var{initargs}.")
1512 #define FUNC_NAME s_scm_sys_allocate_instance
1515 scm_t_signed_bits n
, i
;
1518 SCM_VALIDATE_CLASS (1, class);
1520 /* FIXME: duplicates some of scm_make_struct. */
1522 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1523 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1525 layout
= SCM_VTABLE_LAYOUT (class);
1527 /* Set all SCM-holding slots to unbound */
1528 for (i
= 0; i
< n
; i
++)
1530 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1532 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1534 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1536 SCM_STRUCT_DATA (obj
)[i
] = 0;
1539 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1540 clear_method_cache (obj
);
1546 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1547 (SCM obj
, SCM setter
),
1549 #define FUNC_NAME s_scm_sys_set_object_setter_x
1551 SCM_ASSERT (SCM_STRUCTP (obj
)
1552 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1556 SCM_SET_GENERIC_SETTER (obj
, setter
);
1557 return SCM_UNSPECIFIED
;
1561 /******************************************************************************
1563 * %modify-instance (used by change-class to modify in place)
1565 ******************************************************************************/
1567 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1570 #define FUNC_NAME s_scm_sys_modify_instance
1572 SCM_VALIDATE_INSTANCE (1, old
);
1573 SCM_VALIDATE_INSTANCE (2, new);
1575 /* Exchange the data contained in old and new. We exchange rather than
1576 * scratch the old value with new to be correct with GC.
1577 * See "Class redefinition protocol above".
1579 SCM_CRITICAL_SECTION_START
;
1581 scm_t_bits word0
, word1
;
1582 word0
= SCM_CELL_WORD_0 (old
);
1583 word1
= SCM_CELL_WORD_1 (old
);
1584 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1585 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1586 SCM_SET_CELL_WORD_0 (new, word0
);
1587 SCM_SET_CELL_WORD_1 (new, word1
);
1589 SCM_CRITICAL_SECTION_END
;
1590 return SCM_UNSPECIFIED
;
1594 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1597 #define FUNC_NAME s_scm_sys_modify_class
1599 SCM_VALIDATE_CLASS (1, old
);
1600 SCM_VALIDATE_CLASS (2, new);
1602 SCM_CRITICAL_SECTION_START
;
1604 scm_t_bits word0
, word1
;
1605 word0
= SCM_CELL_WORD_0 (old
);
1606 word1
= SCM_CELL_WORD_1 (old
);
1607 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1608 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1609 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1610 SCM_SET_CELL_WORD_0 (new, word0
);
1611 SCM_SET_CELL_WORD_1 (new, word1
);
1612 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1614 SCM_CRITICAL_SECTION_END
;
1615 return SCM_UNSPECIFIED
;
1619 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1622 #define FUNC_NAME s_scm_sys_invalidate_class
1624 SCM_VALIDATE_CLASS (1, class);
1625 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1626 return SCM_UNSPECIFIED
;
1630 /* When instances change class, they finally get a new body, but
1631 * before that, they go through purgatory in hell. Odd as it may
1632 * seem, this data structure saves us from eternal suffering in
1633 * infinite recursions.
1636 static scm_t_bits
**hell
;
1637 static long n_hell
= 1; /* one place for the evil one himself */
1638 static long hell_size
= 4;
1639 static SCM hell_mutex
;
1645 for (i
= 1; i
< n_hell
; ++i
)
1646 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1652 go_to_hell (void *o
)
1655 scm_lock_mutex (hell_mutex
);
1656 if (n_hell
>= hell_size
)
1659 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1661 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1662 scm_unlock_mutex (hell_mutex
);
1666 go_to_heaven (void *o
)
1669 scm_lock_mutex (hell_mutex
);
1670 hell
[burnin (obj
)] = hell
[--n_hell
];
1671 scm_unlock_mutex (hell_mutex
);
1675 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1678 purgatory (SCM obj
, SCM new_class
)
1680 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1683 /* This function calls the generic function change-class for all
1684 * instances which aren't currently undergoing class change.
1688 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1692 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1693 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1694 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1695 purgatory (obj
, new_class
);
1700 /******************************************************************************
1706 * GGG E N E R I C F U N C T I O N S
1708 * This implementation provides
1709 * - generic functions (with class specializers)
1712 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1714 ******************************************************************************/
1716 SCM_KEYWORD (k_name
, "name");
1718 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1721 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1723 make_dispatch_procedure (SCM gf
)
1725 static SCM var
= SCM_BOOL_F
;
1726 if (scm_is_false (var
))
1727 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1728 sym_delayed_compile
);
1729 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1733 clear_method_cache (SCM gf
)
1735 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1736 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1739 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1742 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1744 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1745 clear_method_cache (gf
);
1746 return SCM_UNSPECIFIED
;
1750 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1753 #define FUNC_NAME s_scm_generic_capability_p
1755 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1756 proc
, SCM_ARG1
, FUNC_NAME
);
1757 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1761 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1764 #define FUNC_NAME s_scm_enable_primitive_generic_x
1766 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1767 while (!scm_is_null (subrs
))
1769 SCM subr
= SCM_CAR (subrs
);
1770 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1771 SCM_SET_SUBR_GENERIC (subr
,
1772 scm_make (scm_list_3 (scm_class_generic
,
1774 SCM_SUBR_NAME (subr
))));
1775 subrs
= SCM_CDR (subrs
);
1777 return SCM_UNSPECIFIED
;
1781 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1782 (SCM subr
, SCM generic
),
1784 #define FUNC_NAME s_scm_set_primitive_generic_x
1786 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1787 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1788 SCM_SET_SUBR_GENERIC (subr
, generic
);
1789 return SCM_UNSPECIFIED
;
1793 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1796 #define FUNC_NAME s_scm_primitive_generic_generic
1798 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1800 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1801 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1802 return *SCM_SUBR_GENERIC (subr
);
1804 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1808 typedef struct t_extension
{
1809 struct t_extension
*next
;
1815 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1817 static const char extension_gc_hint
[] = "GOOPS extension";
1819 static t_extension
*extensions
= 0;
1822 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1827 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1828 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1829 gf
= *SCM_SUBR_GENERIC (extended
);
1830 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1832 SCM_SUBR_NAME (extension
));
1833 SCM_SET_SUBR_GENERIC (extension
, gext
);
1837 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1839 t_extension
**loc
= &extensions
;
1840 /* Make sure that extensions are placed before their own
1841 * extensions in the extensions list. O(N^2) algorithm, but
1842 * extensions of primitive generics are rare.
1844 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1845 loc
= &(*loc
)->next
;
1847 e
->extended
= extended
;
1848 e
->extension
= extension
;
1854 setup_extended_primitive_generics ()
1858 t_extension
*e
= extensions
;
1859 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1860 extensions
= e
->next
;
1864 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1865 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1866 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1870 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1872 if (!SCM_UNPACK (gf
))
1873 scm_error_num_args_subr (subr
);
1875 return scm_call_0 (gf
);
1879 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1881 if (!SCM_UNPACK (gf
))
1882 scm_wrong_type_arg (subr
, pos
, a1
);
1884 return scm_call_1 (gf
, a1
);
1888 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1890 if (!SCM_UNPACK (gf
))
1891 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1893 return scm_call_2 (gf
, a1
, a2
);
1897 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1899 if (!SCM_UNPACK (gf
))
1900 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1902 return scm_apply_0 (gf
, args
);
1905 /******************************************************************************
1907 * Protocol for calling a generic fumction
1908 * This protocol is roughly equivalent to (parameter are a little bit different
1909 * for efficiency reasons):
1911 * + apply-generic (gf args)
1912 * + compute-applicable-methods (gf args ...)
1913 * + sort-applicable-methods (methods args)
1914 * + apply-methods (gf methods args)
1916 * apply-methods calls make-next-method to build the "continuation" of a a
1917 * method. Applying a next-method will call apply-next-method which in
1918 * turn will call apply again to call effectively the following method.
1920 ******************************************************************************/
1923 applicablep (SCM actual
, SCM formal
)
1925 /* We already know that the cpl is well formed. */
1926 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1930 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1932 register SCM s1
, s2
;
1936 * m1 and m2 can have != length (i.e. one can be one element longer than the
1937 * other when we have a dotted parameter list). For instance, with the call
1940 * (define-method M (a . l) ....)
1941 * (define-method M (a) ....)
1943 * we consider that the second method is more specific.
1945 * BTW, targs is an array of types. We don't need it's size since
1946 * we already know that m1 and m2 are applicable (no risk to go past
1947 * the end of this array).
1950 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1951 if (scm_is_null(s1
)) return 1;
1952 if (scm_is_null(s2
)) return 0;
1953 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1954 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1956 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1957 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1959 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1962 return 0;/* should not occur! */
1965 return 0; /* should not occur! */
1968 #define BUFFSIZE 32 /* big enough for most uses */
1971 scm_i_vector2list (SCM l
, long len
)
1974 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1976 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1977 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1983 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1986 SCM
*v
, vector
= SCM_EOL
;
1987 SCM buffer
[BUFFSIZE
];
1988 SCM save
= method_list
;
1989 scm_t_array_handle handle
;
1991 /* For reasonably sized method_lists we can try to avoid all the
1992 * consing and reorder the list in place...
1993 * This idea is due to David McClain <Dave_McClain@msn.com>
1995 if (size
<= BUFFSIZE
)
1997 for (i
= 0; i
< size
; i
++)
1999 buffer
[i
] = SCM_CAR (method_list
);
2000 method_list
= SCM_CDR (method_list
);
2006 /* Too many elements in method_list to keep everything locally */
2007 vector
= scm_i_vector2list (save
, size
);
2008 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2011 /* Use a simple shell sort since it is generally faster than qsort on
2012 * small vectors (which is probably mostly the case when we have to
2013 * sort a list of applicable methods).
2015 for (incr
= size
/ 2; incr
; incr
/= 2)
2017 for (i
= incr
; i
< size
; i
++)
2019 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2021 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2025 SCM tmp
= v
[j
+ incr
];
2033 if (size
<= BUFFSIZE
)
2035 /* We did it in locally, so restore the original list (reordered) in-place */
2036 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2038 SCM_SETCAR (method_list
, *v
);
2039 method_list
= SCM_CDR (method_list
);
2044 /* If we are here, that's that we did it the hard way... */
2045 scm_array_handle_release (&handle
);
2046 return scm_vector_to_list (vector
);
2050 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2054 SCM l
, fl
, applicable
= SCM_EOL
;
2056 SCM buffer
[BUFFSIZE
];
2060 scm_t_array_handle handle
;
2062 /* Build the list of arguments types */
2063 if (len
>= BUFFSIZE
)
2065 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2066 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2069 note that we don't have to work to reset the generation
2070 count. TMP is a new vector anyway, and it is found
2077 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2078 *p
++ = scm_class_of (SCM_CAR (args
));
2080 /* Build a list of all applicable methods */
2081 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2083 fl
= SPEC_OF (SCM_CAR (l
));
2084 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2086 if (SCM_INSTANCEP (fl
)
2087 /* We have a dotted argument list */
2088 || (i
>= len
&& scm_is_null (fl
)))
2089 { /* both list exhausted */
2090 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2096 || !applicablep (types
[i
], SCM_CAR (fl
)))
2101 if (len
>= BUFFSIZE
)
2102 scm_array_handle_release (&handle
);
2108 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2109 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2115 : sort_applicable_methods (applicable
, count
, types
));
2119 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2122 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2125 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2126 #define FUNC_NAME s_sys_compute_applicable_methods
2129 SCM_VALIDATE_GENERIC (1, gf
);
2130 n
= scm_ilength (args
);
2131 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2132 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2136 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2137 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2138 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2139 scm_sys_compute_applicable_methods
));
2141 /******************************************************************************
2143 * A simple make (which will be redefined later in Scheme)
2144 * This version handles only creation of gf, methods and classes (no instances)
2146 * Since this code will disappear when Goops will be fully booted,
2147 * no precaution is taken to be efficient.
2149 ******************************************************************************/
2151 SCM_KEYWORD (k_setter
, "setter");
2152 SCM_KEYWORD (k_specializers
, "specializers");
2153 SCM_KEYWORD (k_procedure
, "procedure");
2154 SCM_KEYWORD (k_formals
, "formals");
2155 SCM_KEYWORD (k_body
, "body");
2156 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2157 SCM_KEYWORD (k_dsupers
, "dsupers");
2158 SCM_KEYWORD (k_slots
, "slots");
2159 SCM_KEYWORD (k_gf
, "generic-function");
2161 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2163 "Make a new object. @var{args} must contain the class and\n"
2164 "all necessary initialization information.")
2165 #define FUNC_NAME s_scm_make
2168 long len
= scm_ilength (args
);
2170 if (len
<= 0 || (len
& 1) == 0)
2171 SCM_WRONG_NUM_ARGS ();
2173 class = SCM_CAR(args
);
2174 args
= SCM_CDR(args
);
2176 if (scm_is_eq (class, scm_class_generic
)
2177 || scm_is_eq (class, scm_class_accessor
))
2179 z
= scm_make_struct (class, SCM_INUM0
,
2180 scm_list_4 (SCM_BOOL_F
,
2184 scm_set_procedure_property_x (z
, scm_sym_name
,
2185 scm_get_keyword (k_name
,
2188 clear_method_cache (z
);
2189 if (scm_is_eq (class, scm_class_accessor
))
2191 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2192 if (scm_is_true (setter
))
2193 scm_sys_set_object_setter_x (z
, setter
);
2198 z
= scm_sys_allocate_instance (class, args
);
2200 if (scm_is_eq (class, scm_class_method
)
2201 || scm_is_eq (class, scm_class_accessor_method
))
2203 SCM_SET_SLOT (z
, scm_si_generic_function
,
2204 scm_i_get_keyword (k_gf
,
2209 SCM_SET_SLOT (z
, scm_si_specializers
,
2210 scm_i_get_keyword (k_specializers
,
2215 SCM_SET_SLOT (z
, scm_si_procedure
,
2216 scm_i_get_keyword (k_procedure
,
2221 SCM_SET_SLOT (z
, scm_si_formals
,
2222 scm_i_get_keyword (k_formals
,
2227 SCM_SET_SLOT (z
, scm_si_body
,
2228 scm_i_get_keyword (k_body
,
2233 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2234 scm_i_get_keyword (k_make_procedure
,
2242 /* In all the others case, make a new class .... No instance here */
2243 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2244 scm_i_get_keyword (k_name
,
2247 scm_from_latin1_symbol ("???"),
2249 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2250 scm_i_get_keyword (k_dsupers
,
2255 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2256 scm_i_get_keyword (k_slots
,
2267 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2270 #define FUNC_NAME s_scm_find_method
2273 long len
= scm_ilength (l
);
2276 SCM_WRONG_NUM_ARGS ();
2278 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2279 SCM_VALIDATE_GENERIC (1, gf
);
2280 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2281 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2283 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2287 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2288 (SCM m1
, SCM m2
, SCM targs
),
2289 "Return true if method @var{m1} is more specific than @var{m2} "
2290 "given the argument types (classes) listed in @var{targs}.")
2291 #define FUNC_NAME s_scm_sys_method_more_specific_p
2295 long i
, len
, m1_specs
, m2_specs
;
2296 scm_t_array_handle handle
;
2298 SCM_VALIDATE_METHOD (1, m1
);
2299 SCM_VALIDATE_METHOD (2, m2
);
2301 len
= scm_ilength (targs
);
2302 m1_specs
= scm_ilength (SPEC_OF (m1
));
2303 m2_specs
= scm_ilength (SPEC_OF (m2
));
2304 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2305 targs
, SCM_ARG3
, FUNC_NAME
);
2307 /* Verify that all the arguments of TARGS are classes and place them
2310 v
= scm_c_make_vector (len
, SCM_EOL
);
2311 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2313 for (i
= 0, l
= targs
;
2314 i
< len
&& scm_is_pair (l
);
2315 i
++, l
= SCM_CDR (l
))
2317 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2318 v_elts
[i
] = SCM_CAR (l
);
2320 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2322 scm_array_handle_release (&handle
);
2330 /******************************************************************************
2334 ******************************************************************************/
2336 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2337 assuming that currently the reverse is true. Recalculate slots and
2338 associated getters-n-setters. */
2340 fix_cpl (SCM c
, SCM before
, SCM after
)
2342 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2343 SCM ls
= scm_c_memq (after
, cpl
);
2346 if (scm_is_false (ls
))
2347 /* if this condition occurs, fix_cpl should not be applied this way */
2350 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2351 SCM_SETCAR (ls
, before
);
2352 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2354 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2355 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2356 SCM g_n_s
= compute_getters_n_setters (slots
);
2357 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2358 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2364 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2366 SCM tmp
= scm_from_utf8_symbol (name
);
2368 *var
= scm_basic_make_class (meta
, tmp
,
2369 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2371 scm_module_define (scm_module_goops
, tmp
, *var
);
2375 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2378 create_standard_classes (void)
2381 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2382 scm_from_latin1_symbol ("specializers"),
2384 scm_from_latin1_symbol ("formals"),
2385 scm_from_latin1_symbol ("body"),
2386 scm_from_latin1_symbol ("make-procedure"),
2388 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2390 k_slot_definition
));
2391 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2392 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2395 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2398 scm_from_latin1_symbol ("effective-methods"));
2399 SCM setter_slots
= scm_list_1 (sym_setter
);
2400 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2403 /* Foreign class slot classes */
2404 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2405 scm_class_class
, scm_class_top
, SCM_EOL
);
2406 make_stdcls (&scm_class_protected
, "<protected-slot>",
2407 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2408 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2409 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2410 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2411 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2412 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2413 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2414 make_stdcls (&scm_class_self
, "<self-slot>",
2415 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2416 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2418 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2420 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2422 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2424 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2426 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2428 make_stdcls (&scm_class_scm
, "<scm-slot>",
2429 scm_class_class
, scm_class_protected
, SCM_EOL
);
2430 make_stdcls (&scm_class_int
, "<int-slot>",
2431 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2432 make_stdcls (&scm_class_float
, "<float-slot>",
2433 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2434 make_stdcls (&scm_class_double
, "<double-slot>",
2435 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2437 /* Continue initialization of class <class> */
2439 slots
= build_class_class_slots ();
2440 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2441 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2442 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2443 compute_getters_n_setters (slots
));
2445 /* scm_class_generic functions classes */
2446 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2447 scm_class_class
, scm_class_class
, SCM_EOL
);
2448 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2449 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2450 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2451 make_stdcls (&scm_class_method
, "<method>",
2452 scm_class_class
, scm_class_object
, method_slots
);
2453 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2454 scm_class_class
, scm_class_method
, amethod_slots
);
2455 make_stdcls (&scm_class_applicable
, "<applicable>",
2456 scm_class_class
, scm_class_top
, SCM_EOL
);
2457 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2458 scm_class_applicable_struct_class
,
2459 scm_list_2 (scm_class_object
, scm_class_applicable
),
2460 scm_list_1 (sym_procedure
));
2461 make_stdcls (&scm_class_generic
, "<generic>",
2462 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2463 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2464 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2465 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2466 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2467 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2468 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2469 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2470 make_stdcls (&scm_class_accessor
, "<accessor>",
2471 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2472 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2473 make_stdcls (&scm_class_extended_generic_with_setter
,
2474 "<extended-generic-with-setter>",
2475 scm_class_applicable_struct_class
,
2476 scm_list_2 (scm_class_extended_generic
,
2477 scm_class_generic_with_setter
),
2479 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2480 SCM_CLASSF_PURE_GENERIC
);
2481 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2482 scm_class_applicable_struct_class
,
2483 scm_list_2 (scm_class_accessor
,
2484 scm_class_extended_generic_with_setter
),
2486 /* <extended-generic> is misplaced. */
2487 fix_cpl (scm_class_extended_accessor
,
2488 scm_class_extended_generic
, scm_class_generic_with_setter
);
2489 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2491 /* Primitive types classes */
2492 make_stdcls (&scm_class_boolean
, "<boolean>",
2493 scm_class_class
, scm_class_top
, SCM_EOL
);
2494 make_stdcls (&scm_class_char
, "<char>",
2495 scm_class_class
, scm_class_top
, SCM_EOL
);
2496 make_stdcls (&scm_class_list
, "<list>",
2497 scm_class_class
, scm_class_top
, SCM_EOL
);
2498 make_stdcls (&scm_class_pair
, "<pair>",
2499 scm_class_class
, scm_class_list
, SCM_EOL
);
2500 make_stdcls (&scm_class_null
, "<null>",
2501 scm_class_class
, scm_class_list
, SCM_EOL
);
2502 make_stdcls (&scm_class_string
, "<string>",
2503 scm_class_class
, scm_class_top
, SCM_EOL
);
2504 make_stdcls (&scm_class_symbol
, "<symbol>",
2505 scm_class_class
, scm_class_top
, SCM_EOL
);
2506 make_stdcls (&scm_class_vector
, "<vector>",
2507 scm_class_class
, scm_class_top
, SCM_EOL
);
2508 make_stdcls (&class_foreign
, "<foreign>",
2509 scm_class_class
, scm_class_top
, SCM_EOL
);
2510 make_stdcls (&class_hashtable
, "<hashtable>",
2511 scm_class_class
, scm_class_top
, SCM_EOL
);
2512 make_stdcls (&class_fluid
, "<fluid>",
2513 scm_class_class
, scm_class_top
, SCM_EOL
);
2514 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2515 scm_class_class
, scm_class_top
, SCM_EOL
);
2516 make_stdcls (&class_frame
, "<frame>",
2517 scm_class_class
, scm_class_top
, SCM_EOL
);
2518 make_stdcls (&class_objcode
, "<objcode>",
2519 scm_class_class
, scm_class_top
, SCM_EOL
);
2520 make_stdcls (&class_vm
, "<vm>",
2521 scm_class_class
, scm_class_top
, SCM_EOL
);
2522 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2523 scm_class_class
, scm_class_top
, SCM_EOL
);
2524 make_stdcls (&class_bytevector
, "<bytevector>",
2525 scm_class_class
, scm_class_top
, SCM_EOL
);
2526 make_stdcls (&class_uvec
, "<uvec>",
2527 scm_class_class
, class_bytevector
, SCM_EOL
);
2528 make_stdcls (&class_array
, "<array>",
2529 scm_class_class
, scm_class_top
, SCM_EOL
);
2530 make_stdcls (&class_bitvector
, "<bitvector>",
2531 scm_class_class
, scm_class_top
, SCM_EOL
);
2532 make_stdcls (&scm_class_number
, "<number>",
2533 scm_class_class
, scm_class_top
, SCM_EOL
);
2534 make_stdcls (&scm_class_complex
, "<complex>",
2535 scm_class_class
, scm_class_number
, SCM_EOL
);
2536 make_stdcls (&scm_class_real
, "<real>",
2537 scm_class_class
, scm_class_complex
, SCM_EOL
);
2538 make_stdcls (&scm_class_integer
, "<integer>",
2539 scm_class_class
, scm_class_real
, SCM_EOL
);
2540 make_stdcls (&scm_class_fraction
, "<fraction>",
2541 scm_class_class
, scm_class_real
, SCM_EOL
);
2542 make_stdcls (&scm_class_keyword
, "<keyword>",
2543 scm_class_class
, scm_class_top
, SCM_EOL
);
2544 make_stdcls (&scm_class_unknown
, "<unknown>",
2545 scm_class_class
, scm_class_top
, SCM_EOL
);
2546 make_stdcls (&scm_class_procedure
, "<procedure>",
2547 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2548 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2549 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2550 make_stdcls (&scm_class_port
, "<port>",
2551 scm_class_class
, scm_class_top
, SCM_EOL
);
2552 make_stdcls (&scm_class_input_port
, "<input-port>",
2553 scm_class_class
, scm_class_port
, SCM_EOL
);
2554 make_stdcls (&scm_class_output_port
, "<output-port>",
2555 scm_class_class
, scm_class_port
, SCM_EOL
);
2556 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2558 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2562 /**********************************************************************
2566 **********************************************************************/
2569 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2575 sprintf (buffer
, template, type_name
);
2576 name
= scm_from_utf8_symbol (buffer
);
2579 name
= SCM_GOOPS_UNBOUND
;
2581 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2582 name
, supers
, SCM_EOL
);
2586 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2590 if (scm_is_true (type_name_sym
))
2592 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2593 scm_symbol_to_string (type_name_sym
),
2594 scm_from_locale_string (">")));
2595 name
= scm_string_to_symbol (name
);
2598 name
= SCM_GOOPS_UNBOUND
;
2600 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2601 name
, supers
, SCM_EOL
);
2605 scm_make_extended_class (char const *type_name
, int applicablep
)
2607 return make_class_from_template ("<%s>",
2609 scm_list_1 (applicablep
2610 ? scm_class_applicable
2616 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2618 return make_class_from_symbol (type_name_sym
,
2619 scm_list_1 (applicablep
2620 ? scm_class_applicable
2626 scm_i_inherit_applicable (SCM c
)
2628 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2630 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2631 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2632 /* patch scm_class_applicable into direct-supers */
2633 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2634 if (scm_is_false (top
))
2635 dsupers
= scm_append (scm_list_2 (dsupers
,
2636 scm_list_1 (scm_class_applicable
)));
2639 SCM_SETCAR (top
, scm_class_applicable
);
2640 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2642 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2643 /* patch scm_class_applicable into cpl */
2644 top
= scm_c_memq (scm_class_top
, cpl
);
2645 if (scm_is_false (top
))
2649 SCM_SETCAR (top
, scm_class_applicable
);
2650 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2652 /* add class to direct-subclasses of scm_class_applicable */
2653 SCM_SET_SLOT (scm_class_applicable
,
2654 scm_si_direct_subclasses
,
2655 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2656 scm_si_direct_subclasses
)));
2661 create_smob_classes (void)
2665 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2666 scm_smob_class
[i
] = SCM_BOOL_F
;
2668 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2670 for (i
= 0; i
< scm_numsmob
; ++i
)
2671 if (scm_is_false (scm_smob_class
[i
]))
2672 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2673 scm_smobs
[i
].apply
!= 0);
2677 scm_make_port_classes (long ptobnum
, char *type_name
)
2679 SCM c
, class = make_class_from_template ("<%s-port>",
2681 scm_list_1 (scm_class_port
),
2683 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2684 = make_class_from_template ("<%s-input-port>",
2686 scm_list_2 (class, scm_class_input_port
),
2688 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2689 = make_class_from_template ("<%s-output-port>",
2691 scm_list_2 (class, scm_class_output_port
),
2693 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2695 = make_class_from_template ("<%s-input-output-port>",
2697 scm_list_2 (class, scm_class_input_output_port
),
2699 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2700 SCM_SET_SLOT (c
, scm_si_cpl
,
2701 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2705 create_port_classes (void)
2709 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2710 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2714 make_struct_class (void *closure SCM_UNUSED
,
2715 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2717 if (scm_is_false (data
))
2718 scm_i_define_class_for_vtable (vtable
);
2719 return SCM_UNSPECIFIED
;
2723 create_struct_classes (void)
2725 /* FIXME: take the vtable_class_map while initializing goops? */
2726 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2730 /**********************************************************************
2734 **********************************************************************/
2739 if (!goops_loaded_p
)
2740 scm_c_resolve_module ("oop goops");
2744 SCM_SYMBOL (sym_o
, "o");
2745 SCM_SYMBOL (sym_x
, "x");
2747 SCM_KEYWORD (k_accessor
, "accessor");
2748 SCM_KEYWORD (k_getter
, "getter");
2751 scm_ensure_accessor (SCM name
)
2755 var
= scm_module_variable (scm_current_module (), name
);
2756 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2757 gf
= SCM_VARIABLE_REF (var
);
2761 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2763 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2764 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2765 k_name
, name
, k_setter
, gf
));
2773 * Debugging utilities
2776 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2778 "Return @code{#t} if @var{obj} is a pure generic.")
2779 #define FUNC_NAME s_scm_pure_generic_p
2781 return scm_from_bool (SCM_PUREGENERICP (obj
));
2785 #endif /* GUILE_DEBUG */
2791 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2793 "Announce that GOOPS is loaded and perform initialization\n"
2794 "on the C level which depends on the loaded GOOPS modules.")
2795 #define FUNC_NAME s_scm_sys_goops_loaded
2798 var_compute_applicable_methods
=
2799 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2801 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2803 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2805 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2806 var_no_applicable_method
=
2807 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2809 scm_module_variable (scm_module_goops
, sym_change_class
);
2810 setup_extended_primitive_generics ();
2811 return SCM_UNSPECIFIED
;
2815 SCM scm_module_goops
;
2818 scm_init_goops_builtins (void)
2820 scm_module_goops
= scm_current_module ();
2822 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2824 #include "libguile/goops.x"
2826 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2827 hell_mutex
= scm_make_mutex ();
2829 create_basic_classes ();
2830 create_standard_classes ();
2831 create_smob_classes ();
2832 create_struct_classes ();
2833 create_port_classes ();
2836 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2837 scm_no_applicable_method
=
2838 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2839 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2842 return SCM_UNSPECIFIED
;
2848 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2849 scm_init_goops_builtins
);