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
;
304 case scm_tc7_rtl_program
:
305 return scm_class_procedure
;
309 scm_t_bits type
= SCM_TYP16 (x
);
310 if (type
!= scm_tc16_port_with_ps
)
311 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
312 x
= SCM_PORT_WITH_PS_PORT (x
);
313 /* fall through to ports */
316 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
317 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
318 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
319 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
320 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
322 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
323 return SCM_CLASS_OF (x
);
324 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
327 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
328 scm_change_object_class (x
,
329 SCM_CLASS_OF (x
), /* old */
330 SCM_OBJ_CLASS_REDEF (x
)); /* new */
331 return SCM_CLASS_OF (x
);
334 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
337 return scm_class_pair
;
339 return scm_class_unknown
;
345 /* case scm_tc3_unused: */
349 return scm_class_unknown
;
353 /******************************************************************************
357 * This version doesn't fully handle multiple-inheritance. It serves
358 * only for booting classes and will be overloaded in Scheme
360 ******************************************************************************/
363 map (SCM (*proc
) (SCM
), SCM ls
)
365 if (scm_is_null (ls
))
369 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
372 while (scm_is_pair (ls
))
374 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
386 while (scm_is_pair (ls
))
388 SCM el
= SCM_CAR (ls
);
389 if (scm_is_false (scm_c_memq (el
, res
)))
390 res
= scm_cons (el
, res
);
397 compute_cpl (SCM
class)
400 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
403 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
404 SCM ls
= scm_append (scm_acons (class, supers
,
405 map (compute_cpl
, supers
)));
406 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
410 /******************************************************************************
414 ******************************************************************************/
417 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
421 if (!scm_is_pair (l
))
425 if (!scm_is_symbol (tmp
))
426 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
428 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
429 res
= scm_cons (SCM_CAR (l
), res
);
430 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
433 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
437 check_cpl (SCM slots
, SCM bslots
)
439 for (; scm_is_pair (bslots
); bslots
= SCM_CDR (bslots
))
440 if (scm_is_true (scm_assq (SCM_CAAR (bslots
), slots
)))
441 scm_misc_error ("init-object", "a predefined <class> inherited "
442 "field cannot be redefined", SCM_EOL
);
446 build_class_class_slots (void);
449 build_slots_list (SCM dslots
, SCM cpl
)
451 SCM bslots
, class_slots
;
455 class_slots
= SCM_EOL
;
456 classp
= scm_is_true (scm_memq (scm_class_class
, cpl
));
460 bslots
= build_class_class_slots ();
461 check_cpl (res
, bslots
);
466 if (scm_is_pair (cpl
))
468 for (cpl
= SCM_CDR (cpl
); scm_is_pair (cpl
); cpl
= SCM_CDR (cpl
))
470 SCM new_slots
= SCM_SLOT (SCM_CAR (cpl
),
471 scm_si_direct_slots
);
474 if (!scm_is_eq (SCM_CAR (cpl
), scm_class_class
))
475 check_cpl (new_slots
, bslots
);
478 /* Move class slots to the head of the list. */
479 class_slots
= new_slots
;
483 res
= scm_append (scm_list_2 (new_slots
, res
));
487 scm_misc_error ("%compute-slots", "malformed cpl argument in "
488 "build_slots_list", SCM_EOL
);
490 /* make sure to add the <class> slots to the head of the list */
492 res
= scm_append (scm_list_2 (class_slots
, res
));
494 /* res contains a list of slots. Remove slots which appears more than once */
495 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
502 while (!scm_is_null (ls
))
504 if (!scm_is_pair (ls
))
505 scm_misc_error ("%compute-slots", "malformed ls argument in "
507 if (!scm_is_pair (SCM_CAR (ls
)))
508 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
515 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
517 "Return a list consisting of the names of all slots belonging to\n"
518 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
520 #define FUNC_NAME s_scm_sys_compute_slots
522 SCM_VALIDATE_CLASS (1, class);
523 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
524 SCM_SLOT (class, scm_si_cpl
));
529 /******************************************************************************
531 * compute-getters-n-setters
533 * This version doesn't handle slot options. It serves only for booting
534 * classes and will be overloaded in Scheme.
536 ******************************************************************************/
538 SCM_KEYWORD (k_init_value
, "init-value");
539 SCM_KEYWORD (k_init_thunk
, "init-thunk");
542 compute_getters_n_setters (SCM slots
)
548 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
550 SCM init
= SCM_BOOL_F
;
551 SCM options
= SCM_CDAR (slots
);
552 if (!scm_is_null (options
))
554 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
555 if (SCM_UNPACK (init
))
557 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
559 scm_list_2 (scm_sym_quote
,
563 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
565 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
567 scm_from_int (i
++))),
569 cdrloc
= SCM_CDRLOC (*cdrloc
);
574 /******************************************************************************
578 ******************************************************************************/
580 /*fixme* Manufacture keywords in advance */
582 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
586 for (i
= 0; i
!= len
; i
+= 2)
588 SCM obj
= SCM_CAR (l
);
590 if (!scm_is_keyword (obj
))
591 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
592 else if (scm_is_eq (obj
, key
))
598 return default_value
;
602 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
603 (SCM key
, SCM l
, SCM default_value
),
604 "Determine an associated value for the keyword @var{key} from\n"
605 "the list @var{l}. The list @var{l} has to consist of an even\n"
606 "number of elements, where, starting with the first, every\n"
607 "second element is a keyword, followed by its associated value.\n"
608 "If @var{l} does not hold a value for @var{key}, the value\n"
609 "@var{default_value} is returned.")
610 #define FUNC_NAME s_scm_get_keyword
614 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
615 len
= scm_ilength (l
);
616 if (len
< 0 || len
% 2 == 1)
617 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
619 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
624 SCM_KEYWORD (k_init_keyword
, "init-keyword");
626 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
627 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
629 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
630 (SCM obj
, SCM initargs
),
631 "Initialize the object @var{obj} with the given arguments\n"
633 #define FUNC_NAME s_scm_sys_initialize_object
635 SCM tmp
, get_n_set
, slots
;
636 SCM
class = SCM_CLASS_OF (obj
);
639 SCM_VALIDATE_INSTANCE (1, obj
);
640 n_initargs
= scm_ilength (initargs
);
641 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
643 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
644 slots
= SCM_SLOT (class, scm_si_slots
);
646 /* See for each slot how it must be initialized */
648 !scm_is_null (slots
);
649 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
651 SCM slot_name
= SCM_CAR (slots
);
652 SCM slot_value
= SCM_PACK (0);
654 if (!scm_is_null (SCM_CDR (slot_name
)))
656 /* This slot admits (perhaps) to be initialized at creation time */
657 long n
= scm_ilength (SCM_CDR (slot_name
));
658 if (n
& 1) /* odd or -1 */
659 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
660 scm_list_1 (slot_name
));
661 tmp
= scm_i_get_keyword (k_init_keyword
,
666 slot_name
= SCM_CAR (slot_name
);
667 if (SCM_UNPACK (tmp
))
669 /* an initarg was provided for this slot */
670 if (!scm_is_keyword (tmp
))
671 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
673 slot_value
= scm_i_get_keyword (tmp
,
681 if (SCM_UNPACK (slot_value
))
682 /* set slot to provided value */
683 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
686 /* set slot to its :init-form if it exists */
687 tmp
= SCM_CADAR (get_n_set
);
688 if (scm_is_true (tmp
))
690 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
691 if (SCM_GOOPS_UNBOUNDP (slot_value
))
692 set_slot_value (class,
704 /* NOTE: The following macros are interdependent with code
705 * in goops.scm:compute-getters-n-setters
707 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
708 (SCM_I_INUMP (SCM_CDDR (gns)) \
709 || (scm_is_pair (SCM_CDDR (gns)) \
710 && scm_is_pair (SCM_CDDDR (gns)) \
711 && scm_is_pair (SCM_CDDDDR (gns))))
712 #define SCM_GNS_INDEX(gns) \
713 (SCM_I_INUMP (SCM_CDDR (gns)) \
714 ? SCM_I_INUM (SCM_CDDR (gns)) \
715 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
716 #define SCM_GNS_SIZE(gns) \
717 (SCM_I_INUMP (SCM_CDDR (gns)) \
719 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
721 SCM_KEYWORD (k_class
, "class");
722 SCM_KEYWORD (k_allocation
, "allocation");
723 SCM_KEYWORD (k_instance
, "instance");
725 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
728 #define FUNC_NAME s_scm_sys_prep_layout_x
730 SCM slots
, getters_n_setters
, nfields
;
731 unsigned long int n
, i
;
735 SCM_VALIDATE_INSTANCE (1, class);
736 slots
= SCM_SLOT (class, scm_si_slots
);
737 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
738 nfields
= SCM_SLOT (class, scm_si_nfields
);
739 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
740 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
741 scm_list_1 (nfields
));
742 n
= 2 * SCM_I_INUM (nfields
);
743 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
744 && SCM_SUBCLASSP (class, scm_class_class
))
745 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
746 scm_list_1 (nfields
));
748 layout
= scm_i_make_string (n
, &s
, 0);
750 while (scm_is_pair (getters_n_setters
))
752 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
755 int len
, index
, size
;
758 if (i
>= n
|| !scm_is_pair (slots
))
761 /* extract slot type */
762 len
= scm_ilength (SCM_CDAR (slots
));
763 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
764 len
, SCM_BOOL_F
, FUNC_NAME
);
765 /* determine slot GC protection and access mode */
766 if (scm_is_false (type
))
773 if (!SCM_CLASSP (type
))
774 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
775 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
777 if (SCM_SUBCLASSP (type
, scm_class_self
))
779 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
784 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
786 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
788 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
800 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
801 if (index
!= (i
>> 1))
803 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
811 slots
= SCM_CDR (slots
);
812 getters_n_setters
= SCM_CDR (getters_n_setters
);
814 if (!scm_is_null (slots
))
817 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
819 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
820 return SCM_UNSPECIFIED
;
824 static void prep_hashsets (SCM
);
826 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
827 (SCM
class, SCM dsupers
),
829 #define FUNC_NAME s_scm_sys_inherit_magic_x
831 SCM_VALIDATE_INSTANCE (1, class);
832 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
833 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
835 prep_hashsets (class);
837 return SCM_UNSPECIFIED
;
842 prep_hashsets (SCM
class)
846 for (i
= 0; i
< 8; ++i
)
847 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
850 /******************************************************************************/
853 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
855 SCM z
, cpl
, slots
, nfields
, g_n_s
;
857 /* Allocate one instance */
858 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
860 /* Initialize its slots */
861 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
862 cpl
= compute_cpl (z
);
863 slots
= build_slots_list (maplist (dslots
), cpl
);
864 nfields
= scm_from_int (scm_ilength (slots
));
865 g_n_s
= compute_getters_n_setters (slots
);
867 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
868 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
869 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
870 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
871 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
872 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
873 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
874 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
875 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
877 /* Add this class in the direct-subclasses slot of dsupers */
880 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
881 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
882 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
883 scm_si_direct_subclasses
)));
890 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
892 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
893 scm_sys_prep_layout_x (z
);
894 scm_sys_inherit_magic_x (z
, dsupers
);
898 /******************************************************************************/
900 SCM_SYMBOL (sym_layout
, "layout");
901 SCM_SYMBOL (sym_flags
, "flags");
902 SCM_SYMBOL (sym_self
, "%self");
903 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
904 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
905 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
906 SCM_SYMBOL (sym_print
, "print");
907 SCM_SYMBOL (sym_procedure
, "procedure");
908 SCM_SYMBOL (sym_setter
, "setter");
909 SCM_SYMBOL (sym_redefined
, "redefined");
910 SCM_SYMBOL (sym_h0
, "h0");
911 SCM_SYMBOL (sym_h1
, "h1");
912 SCM_SYMBOL (sym_h2
, "h2");
913 SCM_SYMBOL (sym_h3
, "h3");
914 SCM_SYMBOL (sym_h4
, "h4");
915 SCM_SYMBOL (sym_h5
, "h5");
916 SCM_SYMBOL (sym_h6
, "h6");
917 SCM_SYMBOL (sym_h7
, "h7");
918 SCM_SYMBOL (sym_name
, "name");
919 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
920 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
921 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
922 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
923 SCM_SYMBOL (sym_cpl
, "cpl");
924 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
925 SCM_SYMBOL (sym_slots
, "slots");
926 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
927 SCM_SYMBOL (sym_nfields
, "nfields");
931 build_class_class_slots (void)
933 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
934 SCM_CLASS_CLASS_LAYOUT */
936 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
937 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
938 scm_list_3 (sym_self
, k_class
, scm_class_self
),
939 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
940 scm_list_1 (sym_print
),
941 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
942 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
943 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
944 scm_list_1 (sym_redefined
),
945 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
946 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
947 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
948 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
949 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
950 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
951 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
952 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
953 scm_list_1 (sym_direct_supers
),
954 scm_list_1 (sym_direct_slots
),
955 scm_list_1 (sym_direct_subclasses
),
956 scm_list_1 (sym_direct_methods
),
957 scm_list_1 (sym_cpl
),
958 scm_list_1 (sym_default_slot_definition_class
),
959 scm_list_1 (sym_slots
),
960 scm_list_1 (sym_getters_n_setters
),
961 scm_list_1 (sym_nfields
),
966 create_basic_classes (void)
968 /* SCM slots_of_class = build_class_class_slots (); */
971 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
972 SCM name
= scm_from_latin1_symbol ("<class>");
973 scm_class_class
= scm_i_make_vtable_vtable (cs
);
974 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
975 | SCM_CLASSF_METACLASS
));
977 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
978 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
979 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
980 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
981 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
982 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
983 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
984 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
985 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
986 compute_getters_n_setters (slots_of_class)); */
987 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
989 prep_hashsets (scm_class_class
);
991 scm_module_define (scm_module_goops
, name
, scm_class_class
);
994 name
= scm_from_latin1_symbol ("<top>");
995 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
998 scm_module_define (scm_module_goops
, name
, scm_class_top
);
1000 /**** <object> ****/
1001 name
= scm_from_latin1_symbol ("<object>");
1002 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
1003 scm_list_1 (scm_class_top
), SCM_EOL
);
1005 scm_module_define (scm_module_goops
, name
, scm_class_object
);
1007 /* <top> <object> and <class> were partially initialized. Correct them here */
1008 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
1010 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
1011 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
1014 /******************************************************************************/
1016 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
1018 "Return @code{#t} if @var{obj} is an instance.")
1019 #define FUNC_NAME s_scm_instance_p
1021 return scm_from_bool (SCM_INSTANCEP (obj
));
1026 /******************************************************************************
1028 * Meta object accessors
1030 ******************************************************************************/
1031 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
1033 "Return the class name of @var{obj}.")
1034 #define FUNC_NAME s_scm_class_name
1036 SCM_VALIDATE_CLASS (1, obj
);
1037 return scm_slot_ref (obj
, sym_name
);
1041 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1043 "Return the direct superclasses of the class @var{obj}.")
1044 #define FUNC_NAME s_scm_class_direct_supers
1046 SCM_VALIDATE_CLASS (1, obj
);
1047 return scm_slot_ref (obj
, sym_direct_supers
);
1051 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1053 "Return the direct slots of the class @var{obj}.")
1054 #define FUNC_NAME s_scm_class_direct_slots
1056 SCM_VALIDATE_CLASS (1, obj
);
1057 return scm_slot_ref (obj
, sym_direct_slots
);
1061 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1063 "Return the direct subclasses of the class @var{obj}.")
1064 #define FUNC_NAME s_scm_class_direct_subclasses
1066 SCM_VALIDATE_CLASS (1, obj
);
1067 return scm_slot_ref(obj
, sym_direct_subclasses
);
1071 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1073 "Return the direct methods of the class @var{obj}")
1074 #define FUNC_NAME s_scm_class_direct_methods
1076 SCM_VALIDATE_CLASS (1, obj
);
1077 return scm_slot_ref (obj
, sym_direct_methods
);
1081 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1083 "Return the class precedence list of the class @var{obj}.")
1084 #define FUNC_NAME s_scm_class_precedence_list
1086 SCM_VALIDATE_CLASS (1, obj
);
1087 return scm_slot_ref (obj
, sym_cpl
);
1091 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1093 "Return the slot list of the class @var{obj}.")
1094 #define FUNC_NAME s_scm_class_slots
1096 SCM_VALIDATE_CLASS (1, obj
);
1097 return scm_slot_ref (obj
, sym_slots
);
1101 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1103 "Return the name of the generic function @var{obj}.")
1104 #define FUNC_NAME s_scm_generic_function_name
1106 SCM_VALIDATE_GENERIC (1, obj
);
1107 return scm_procedure_property (obj
, scm_sym_name
);
1111 SCM_SYMBOL (sym_methods
, "methods");
1112 SCM_SYMBOL (sym_extended_by
, "extended-by");
1113 SCM_SYMBOL (sym_extends
, "extends");
1116 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1118 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1119 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1120 while (!scm_is_null (gfs
))
1122 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1123 gfs
= SCM_CDR (gfs
);
1125 return method_lists
;
1129 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1131 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1133 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1134 while (!scm_is_null (gfs
))
1136 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1137 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1140 gfs
= SCM_CDR (gfs
);
1143 return method_lists
;
1146 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1148 "Return the methods of the generic function @var{obj}.")
1149 #define FUNC_NAME s_scm_generic_function_methods
1152 SCM_VALIDATE_GENERIC (1, obj
);
1153 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1154 methods
= fold_downward_gf_methods (methods
, obj
);
1155 return scm_append (methods
);
1159 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1161 "Return the generic function for the method @var{obj}.")
1162 #define FUNC_NAME s_scm_method_generic_function
1164 SCM_VALIDATE_METHOD (1, obj
);
1165 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1169 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1171 "Return specializers of the method @var{obj}.")
1172 #define FUNC_NAME s_scm_method_specializers
1174 SCM_VALIDATE_METHOD (1, obj
);
1175 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1179 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1181 "Return the procedure of the method @var{obj}.")
1182 #define FUNC_NAME s_scm_method_procedure
1184 SCM_VALIDATE_METHOD (1, obj
);
1185 return scm_slot_ref (obj
, sym_procedure
);
1189 /******************************************************************************
1191 * S l o t a c c e s s
1193 ******************************************************************************/
1195 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1197 "Return the unbound value.")
1198 #define FUNC_NAME s_scm_make_unbound
1200 return SCM_GOOPS_UNBOUND
;
1204 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1206 "Return @code{#t} if @var{obj} is unbound.")
1207 #define FUNC_NAME s_scm_unbound_p
1209 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1213 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1214 (SCM value
, SCM obj
),
1215 "Return @var{value} if it is bound, and invoke the\n"
1216 "@var{slot-unbound} method of @var{obj} if it is not.")
1217 #define FUNC_NAME s_scm_assert_bound
1219 if (SCM_GOOPS_UNBOUNDP (value
))
1220 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1225 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1226 (SCM obj
, SCM index
),
1227 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1228 "the value from @var{obj}.")
1229 #define FUNC_NAME s_scm_at_assert_bound_ref
1231 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1232 if (SCM_GOOPS_UNBOUNDP (value
))
1233 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1238 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1239 (SCM obj
, SCM index
),
1240 "Return the slot value with index @var{index} from @var{obj}.")
1241 #define FUNC_NAME s_scm_sys_fast_slot_ref
1245 SCM_VALIDATE_INSTANCE (1, obj
);
1246 i
= scm_to_unsigned_integer (index
, 0,
1247 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1250 return SCM_SLOT (obj
, i
);
1254 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1255 (SCM obj
, SCM index
, SCM value
),
1256 "Set the slot with index @var{index} in @var{obj} to\n"
1258 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1262 SCM_VALIDATE_INSTANCE (1, obj
);
1263 i
= scm_to_unsigned_integer (index
, 0,
1264 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1268 SCM_SET_SLOT (obj
, i
, value
);
1270 return SCM_UNSPECIFIED
;
1278 /* In the future, this function will return the effective slot
1279 * definition associated with SLOT_NAME. Now it just returns some of
1280 * the information which will be stored in the effective slot
1285 slot_definition_using_name (SCM
class, SCM slot_name
)
1287 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1288 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1289 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1290 return SCM_CAR (slots
);
1295 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1296 #define FUNC_NAME "%get-slot-value"
1298 SCM access
= SCM_CDDR (slotdef
);
1300 * - access is an integer (the offset of this slot in the slots vector)
1301 * - otherwise (car access) is the getter function to apply
1303 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1304 * we can just assume fixnums here.
1306 if (SCM_I_INUMP (access
))
1307 /* Don't poke at the slots directly, because scm_struct_ref handles the
1308 access bits for us. */
1309 return scm_struct_ref (obj
, access
);
1311 return scm_call_1 (SCM_CAR (access
), obj
);
1316 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1318 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1319 if (scm_is_true (slotdef
))
1320 return get_slot_value (class, obj
, slotdef
);
1322 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1326 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1327 #define FUNC_NAME "%set-slot-value"
1329 SCM access
= SCM_CDDR (slotdef
);
1331 * - access is an integer (the offset of this slot in the slots vector)
1332 * - otherwise (cadr access) is the setter function to apply
1334 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1335 * we can just assume fixnums here.
1337 if (SCM_I_INUMP (access
))
1338 /* obey permissions bits via going through struct-set! */
1339 scm_struct_set_x (obj
, access
, value
);
1341 /* ((cadr l) obj value) */
1342 scm_call_2 (SCM_CADR (access
), obj
, value
);
1343 return SCM_UNSPECIFIED
;
1348 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1350 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1351 if (scm_is_true (slotdef
))
1352 return set_slot_value (class, obj
, slotdef
, value
);
1354 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1358 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1362 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1363 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1369 /* ======================================== */
1371 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1372 (SCM
class, SCM obj
, SCM slot_name
),
1374 #define FUNC_NAME s_scm_slot_ref_using_class
1378 SCM_VALIDATE_CLASS (1, class);
1379 SCM_VALIDATE_INSTANCE (2, obj
);
1380 SCM_VALIDATE_SYMBOL (3, slot_name
);
1382 res
= get_slot_value_using_name (class, obj
, slot_name
);
1383 if (SCM_GOOPS_UNBOUNDP (res
))
1384 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1390 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1391 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1393 #define FUNC_NAME s_scm_slot_set_using_class_x
1395 SCM_VALIDATE_CLASS (1, class);
1396 SCM_VALIDATE_INSTANCE (2, obj
);
1397 SCM_VALIDATE_SYMBOL (3, slot_name
);
1399 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1404 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1405 (SCM
class, SCM obj
, SCM slot_name
),
1407 #define FUNC_NAME s_scm_slot_bound_using_class_p
1409 SCM_VALIDATE_CLASS (1, class);
1410 SCM_VALIDATE_INSTANCE (2, obj
);
1411 SCM_VALIDATE_SYMBOL (3, slot_name
);
1413 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1419 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1420 (SCM
class, SCM obj
, SCM slot_name
),
1422 #define FUNC_NAME s_scm_slot_exists_using_class_p
1424 SCM_VALIDATE_CLASS (1, class);
1425 SCM_VALIDATE_INSTANCE (2, obj
);
1426 SCM_VALIDATE_SYMBOL (3, slot_name
);
1427 return test_slot_existence (class, obj
, slot_name
);
1432 /* ======================================== */
1434 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1435 (SCM obj
, SCM slot_name
),
1436 "Return the value from @var{obj}'s slot with the name\n"
1438 #define FUNC_NAME s_scm_slot_ref
1442 SCM_VALIDATE_INSTANCE (1, obj
);
1443 TEST_CHANGE_CLASS (obj
, class);
1445 res
= get_slot_value_using_name (class, obj
, slot_name
);
1446 if (SCM_GOOPS_UNBOUNDP (res
))
1447 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1452 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1453 (SCM obj
, SCM slot_name
, SCM value
),
1454 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1455 #define FUNC_NAME s_scm_slot_set_x
1459 SCM_VALIDATE_INSTANCE (1, obj
);
1460 TEST_CHANGE_CLASS(obj
, class);
1462 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1466 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1468 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1469 (SCM obj
, SCM slot_name
),
1470 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1472 #define FUNC_NAME s_scm_slot_bound_p
1476 SCM_VALIDATE_INSTANCE (1, obj
);
1477 TEST_CHANGE_CLASS(obj
, class);
1479 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1487 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1488 (SCM obj
, SCM slot_name
),
1489 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1490 #define FUNC_NAME s_scm_slot_exists_p
1494 SCM_VALIDATE_INSTANCE (1, obj
);
1495 SCM_VALIDATE_SYMBOL (2, slot_name
);
1496 TEST_CHANGE_CLASS (obj
, class);
1498 return test_slot_existence (class, obj
, slot_name
);
1503 /******************************************************************************
1505 * %allocate-instance (the low level instance allocation primitive)
1507 ******************************************************************************/
1509 static void clear_method_cache (SCM
);
1511 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1512 (SCM
class, SCM initargs
),
1513 "Create a new instance of class @var{class} and initialize it\n"
1514 "from the arguments @var{initargs}.")
1515 #define FUNC_NAME s_scm_sys_allocate_instance
1518 scm_t_signed_bits n
, i
;
1521 SCM_VALIDATE_CLASS (1, class);
1523 /* FIXME: duplicates some of scm_make_struct. */
1525 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1526 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1528 layout
= SCM_VTABLE_LAYOUT (class);
1530 /* Set all SCM-holding slots to unbound */
1531 for (i
= 0; i
< n
; i
++)
1533 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1535 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1537 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1539 SCM_STRUCT_DATA (obj
)[i
] = 0;
1542 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1543 clear_method_cache (obj
);
1549 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1550 (SCM obj
, SCM setter
),
1552 #define FUNC_NAME s_scm_sys_set_object_setter_x
1554 SCM_ASSERT (SCM_STRUCTP (obj
)
1555 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1559 SCM_SET_GENERIC_SETTER (obj
, setter
);
1560 return SCM_UNSPECIFIED
;
1564 /******************************************************************************
1566 * %modify-instance (used by change-class to modify in place)
1568 ******************************************************************************/
1570 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1573 #define FUNC_NAME s_scm_sys_modify_instance
1575 SCM_VALIDATE_INSTANCE (1, old
);
1576 SCM_VALIDATE_INSTANCE (2, new);
1578 /* Exchange the data contained in old and new. We exchange rather than
1579 * scratch the old value with new to be correct with GC.
1580 * See "Class redefinition protocol above".
1582 SCM_CRITICAL_SECTION_START
;
1584 scm_t_bits word0
, word1
;
1585 word0
= SCM_CELL_WORD_0 (old
);
1586 word1
= SCM_CELL_WORD_1 (old
);
1587 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1588 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1589 SCM_SET_CELL_WORD_0 (new, word0
);
1590 SCM_SET_CELL_WORD_1 (new, word1
);
1592 SCM_CRITICAL_SECTION_END
;
1593 return SCM_UNSPECIFIED
;
1597 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1600 #define FUNC_NAME s_scm_sys_modify_class
1602 SCM_VALIDATE_CLASS (1, old
);
1603 SCM_VALIDATE_CLASS (2, new);
1605 SCM_CRITICAL_SECTION_START
;
1607 scm_t_bits word0
, word1
;
1608 word0
= SCM_CELL_WORD_0 (old
);
1609 word1
= SCM_CELL_WORD_1 (old
);
1610 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1611 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1612 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1613 SCM_SET_CELL_WORD_0 (new, word0
);
1614 SCM_SET_CELL_WORD_1 (new, word1
);
1615 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1617 SCM_CRITICAL_SECTION_END
;
1618 return SCM_UNSPECIFIED
;
1622 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1625 #define FUNC_NAME s_scm_sys_invalidate_class
1627 SCM_VALIDATE_CLASS (1, class);
1628 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1629 return SCM_UNSPECIFIED
;
1633 /* When instances change class, they finally get a new body, but
1634 * before that, they go through purgatory in hell. Odd as it may
1635 * seem, this data structure saves us from eternal suffering in
1636 * infinite recursions.
1639 static scm_t_bits
**hell
;
1640 static long n_hell
= 1; /* one place for the evil one himself */
1641 static long hell_size
= 4;
1642 static SCM hell_mutex
;
1648 for (i
= 1; i
< n_hell
; ++i
)
1649 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1655 go_to_hell (void *o
)
1658 scm_lock_mutex (hell_mutex
);
1659 if (n_hell
>= hell_size
)
1662 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1664 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1665 scm_unlock_mutex (hell_mutex
);
1669 go_to_heaven (void *o
)
1672 scm_lock_mutex (hell_mutex
);
1673 hell
[burnin (obj
)] = hell
[--n_hell
];
1674 scm_unlock_mutex (hell_mutex
);
1678 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1681 purgatory (SCM obj
, SCM new_class
)
1683 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1686 /* This function calls the generic function change-class for all
1687 * instances which aren't currently undergoing class change.
1691 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1695 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1696 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1697 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1698 purgatory (obj
, new_class
);
1703 /******************************************************************************
1709 * GGG E N E R I C F U N C T I O N S
1711 * This implementation provides
1712 * - generic functions (with class specializers)
1715 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1717 ******************************************************************************/
1719 SCM_KEYWORD (k_name
, "name");
1721 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1724 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1726 make_dispatch_procedure (SCM gf
)
1728 static SCM var
= SCM_BOOL_F
;
1729 if (scm_is_false (var
))
1730 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1731 sym_delayed_compile
);
1732 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1736 clear_method_cache (SCM gf
)
1738 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1739 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1742 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1745 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1747 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1748 clear_method_cache (gf
);
1749 return SCM_UNSPECIFIED
;
1753 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1756 #define FUNC_NAME s_scm_generic_capability_p
1758 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1759 proc
, SCM_ARG1
, FUNC_NAME
);
1760 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1764 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1767 #define FUNC_NAME s_scm_enable_primitive_generic_x
1769 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1770 while (!scm_is_null (subrs
))
1772 SCM subr
= SCM_CAR (subrs
);
1773 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1774 SCM_SET_SUBR_GENERIC (subr
,
1775 scm_make (scm_list_3 (scm_class_generic
,
1777 SCM_SUBR_NAME (subr
))));
1778 subrs
= SCM_CDR (subrs
);
1780 return SCM_UNSPECIFIED
;
1784 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1785 (SCM subr
, SCM generic
),
1787 #define FUNC_NAME s_scm_set_primitive_generic_x
1789 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1790 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1791 SCM_SET_SUBR_GENERIC (subr
, generic
);
1792 return SCM_UNSPECIFIED
;
1796 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1799 #define FUNC_NAME s_scm_primitive_generic_generic
1801 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1803 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1804 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1805 return *SCM_SUBR_GENERIC (subr
);
1807 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1811 typedef struct t_extension
{
1812 struct t_extension
*next
;
1818 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1820 static const char extension_gc_hint
[] = "GOOPS extension";
1822 static t_extension
*extensions
= 0;
1825 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1830 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1831 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1832 gf
= *SCM_SUBR_GENERIC (extended
);
1833 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1835 SCM_SUBR_NAME (extension
));
1836 SCM_SET_SUBR_GENERIC (extension
, gext
);
1840 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1842 t_extension
**loc
= &extensions
;
1843 /* Make sure that extensions are placed before their own
1844 * extensions in the extensions list. O(N^2) algorithm, but
1845 * extensions of primitive generics are rare.
1847 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1848 loc
= &(*loc
)->next
;
1850 e
->extended
= extended
;
1851 e
->extension
= extension
;
1857 setup_extended_primitive_generics ()
1861 t_extension
*e
= extensions
;
1862 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1863 extensions
= e
->next
;
1867 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1868 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1869 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1873 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1875 if (!SCM_UNPACK (gf
))
1876 scm_error_num_args_subr (subr
);
1878 return scm_call_0 (gf
);
1882 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1884 if (!SCM_UNPACK (gf
))
1885 scm_wrong_type_arg (subr
, pos
, a1
);
1887 return scm_call_1 (gf
, a1
);
1891 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1893 if (!SCM_UNPACK (gf
))
1894 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1896 return scm_call_2 (gf
, a1
, a2
);
1900 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1902 if (!SCM_UNPACK (gf
))
1903 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1905 return scm_apply_0 (gf
, args
);
1908 /******************************************************************************
1910 * Protocol for calling a generic fumction
1911 * This protocol is roughly equivalent to (parameter are a little bit different
1912 * for efficiency reasons):
1914 * + apply-generic (gf args)
1915 * + compute-applicable-methods (gf args ...)
1916 * + sort-applicable-methods (methods args)
1917 * + apply-methods (gf methods args)
1919 * apply-methods calls make-next-method to build the "continuation" of a a
1920 * method. Applying a next-method will call apply-next-method which in
1921 * turn will call apply again to call effectively the following method.
1923 ******************************************************************************/
1926 applicablep (SCM actual
, SCM formal
)
1928 /* We already know that the cpl is well formed. */
1929 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1933 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1935 register SCM s1
, s2
;
1939 * m1 and m2 can have != length (i.e. one can be one element longer than the
1940 * other when we have a dotted parameter list). For instance, with the call
1943 * (define-method M (a . l) ....)
1944 * (define-method M (a) ....)
1946 * we consider that the second method is more specific.
1948 * BTW, targs is an array of types. We don't need it's size since
1949 * we already know that m1 and m2 are applicable (no risk to go past
1950 * the end of this array).
1953 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1954 if (scm_is_null(s1
)) return 1;
1955 if (scm_is_null(s2
)) return 0;
1956 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1957 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1959 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1960 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1962 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1965 return 0;/* should not occur! */
1968 return 0; /* should not occur! */
1971 #define BUFFSIZE 32 /* big enough for most uses */
1974 scm_i_vector2list (SCM l
, long len
)
1977 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1979 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1980 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1986 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1989 SCM
*v
, vector
= SCM_EOL
;
1990 SCM buffer
[BUFFSIZE
];
1991 SCM save
= method_list
;
1992 scm_t_array_handle handle
;
1994 /* For reasonably sized method_lists we can try to avoid all the
1995 * consing and reorder the list in place...
1996 * This idea is due to David McClain <Dave_McClain@msn.com>
1998 if (size
<= BUFFSIZE
)
2000 for (i
= 0; i
< size
; i
++)
2002 buffer
[i
] = SCM_CAR (method_list
);
2003 method_list
= SCM_CDR (method_list
);
2009 /* Too many elements in method_list to keep everything locally */
2010 vector
= scm_i_vector2list (save
, size
);
2011 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2014 /* Use a simple shell sort since it is generally faster than qsort on
2015 * small vectors (which is probably mostly the case when we have to
2016 * sort a list of applicable methods).
2018 for (incr
= size
/ 2; incr
; incr
/= 2)
2020 for (i
= incr
; i
< size
; i
++)
2022 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2024 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2028 SCM tmp
= v
[j
+ incr
];
2036 if (size
<= BUFFSIZE
)
2038 /* We did it in locally, so restore the original list (reordered) in-place */
2039 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2041 SCM_SETCAR (method_list
, *v
);
2042 method_list
= SCM_CDR (method_list
);
2047 /* If we are here, that's that we did it the hard way... */
2048 scm_array_handle_release (&handle
);
2049 return scm_vector_to_list (vector
);
2053 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2057 SCM l
, fl
, applicable
= SCM_EOL
;
2059 SCM buffer
[BUFFSIZE
];
2063 scm_t_array_handle handle
;
2065 /* Build the list of arguments types */
2066 if (len
>= BUFFSIZE
)
2068 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2069 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2072 note that we don't have to work to reset the generation
2073 count. TMP is a new vector anyway, and it is found
2080 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2081 *p
++ = scm_class_of (SCM_CAR (args
));
2083 /* Build a list of all applicable methods */
2084 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2086 fl
= SPEC_OF (SCM_CAR (l
));
2087 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2089 if (SCM_INSTANCEP (fl
)
2090 /* We have a dotted argument list */
2091 || (i
>= len
&& scm_is_null (fl
)))
2092 { /* both list exhausted */
2093 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2099 || !applicablep (types
[i
], SCM_CAR (fl
)))
2104 if (len
>= BUFFSIZE
)
2105 scm_array_handle_release (&handle
);
2111 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2112 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2118 : sort_applicable_methods (applicable
, count
, types
));
2122 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2125 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2128 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2129 #define FUNC_NAME s_sys_compute_applicable_methods
2132 SCM_VALIDATE_GENERIC (1, gf
);
2133 n
= scm_ilength (args
);
2134 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2135 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2139 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2140 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2141 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2142 scm_sys_compute_applicable_methods
));
2144 /******************************************************************************
2146 * A simple make (which will be redefined later in Scheme)
2147 * This version handles only creation of gf, methods and classes (no instances)
2149 * Since this code will disappear when Goops will be fully booted,
2150 * no precaution is taken to be efficient.
2152 ******************************************************************************/
2154 SCM_KEYWORD (k_setter
, "setter");
2155 SCM_KEYWORD (k_specializers
, "specializers");
2156 SCM_KEYWORD (k_procedure
, "procedure");
2157 SCM_KEYWORD (k_formals
, "formals");
2158 SCM_KEYWORD (k_body
, "body");
2159 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2160 SCM_KEYWORD (k_dsupers
, "dsupers");
2161 SCM_KEYWORD (k_slots
, "slots");
2162 SCM_KEYWORD (k_gf
, "generic-function");
2164 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2166 "Make a new object. @var{args} must contain the class and\n"
2167 "all necessary initialization information.")
2168 #define FUNC_NAME s_scm_make
2171 long len
= scm_ilength (args
);
2173 if (len
<= 0 || (len
& 1) == 0)
2174 SCM_WRONG_NUM_ARGS ();
2176 class = SCM_CAR(args
);
2177 args
= SCM_CDR(args
);
2179 if (scm_is_eq (class, scm_class_generic
)
2180 || scm_is_eq (class, scm_class_accessor
))
2182 z
= scm_make_struct (class, SCM_INUM0
,
2183 scm_list_4 (SCM_BOOL_F
,
2187 scm_set_procedure_property_x (z
, scm_sym_name
,
2188 scm_get_keyword (k_name
,
2191 clear_method_cache (z
);
2192 if (scm_is_eq (class, scm_class_accessor
))
2194 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2195 if (scm_is_true (setter
))
2196 scm_sys_set_object_setter_x (z
, setter
);
2201 z
= scm_sys_allocate_instance (class, args
);
2203 if (scm_is_eq (class, scm_class_method
)
2204 || scm_is_eq (class, scm_class_accessor_method
))
2206 SCM_SET_SLOT (z
, scm_si_generic_function
,
2207 scm_i_get_keyword (k_gf
,
2212 SCM_SET_SLOT (z
, scm_si_specializers
,
2213 scm_i_get_keyword (k_specializers
,
2218 SCM_SET_SLOT (z
, scm_si_procedure
,
2219 scm_i_get_keyword (k_procedure
,
2224 SCM_SET_SLOT (z
, scm_si_formals
,
2225 scm_i_get_keyword (k_formals
,
2230 SCM_SET_SLOT (z
, scm_si_body
,
2231 scm_i_get_keyword (k_body
,
2236 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2237 scm_i_get_keyword (k_make_procedure
,
2245 /* In all the others case, make a new class .... No instance here */
2246 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2247 scm_i_get_keyword (k_name
,
2250 scm_from_latin1_symbol ("???"),
2252 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2253 scm_i_get_keyword (k_dsupers
,
2258 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2259 scm_i_get_keyword (k_slots
,
2270 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2273 #define FUNC_NAME s_scm_find_method
2276 long len
= scm_ilength (l
);
2279 SCM_WRONG_NUM_ARGS ();
2281 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2282 SCM_VALIDATE_GENERIC (1, gf
);
2283 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2284 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2286 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2290 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2291 (SCM m1
, SCM m2
, SCM targs
),
2292 "Return true if method @var{m1} is more specific than @var{m2} "
2293 "given the argument types (classes) listed in @var{targs}.")
2294 #define FUNC_NAME s_scm_sys_method_more_specific_p
2298 long i
, len
, m1_specs
, m2_specs
;
2299 scm_t_array_handle handle
;
2301 SCM_VALIDATE_METHOD (1, m1
);
2302 SCM_VALIDATE_METHOD (2, m2
);
2304 len
= scm_ilength (targs
);
2305 m1_specs
= scm_ilength (SPEC_OF (m1
));
2306 m2_specs
= scm_ilength (SPEC_OF (m2
));
2307 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2308 targs
, SCM_ARG3
, FUNC_NAME
);
2310 /* Verify that all the arguments of TARGS are classes and place them
2313 v
= scm_c_make_vector (len
, SCM_EOL
);
2314 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2316 for (i
= 0, l
= targs
;
2317 i
< len
&& scm_is_pair (l
);
2318 i
++, l
= SCM_CDR (l
))
2320 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2321 v_elts
[i
] = SCM_CAR (l
);
2323 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2325 scm_array_handle_release (&handle
);
2333 /******************************************************************************
2337 ******************************************************************************/
2339 /* Munge the CPL of C in place such that BEFORE appears before AFTER,
2340 assuming that currently the reverse is true. Recalculate slots and
2341 associated getters-n-setters. */
2343 fix_cpl (SCM c
, SCM before
, SCM after
)
2345 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2346 SCM ls
= scm_c_memq (after
, cpl
);
2349 if (scm_is_false (ls
))
2350 /* if this condition occurs, fix_cpl should not be applied this way */
2353 tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2354 SCM_SETCAR (ls
, before
);
2355 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2357 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2358 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2359 SCM g_n_s
= compute_getters_n_setters (slots
);
2360 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2361 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2367 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2369 SCM tmp
= scm_from_utf8_symbol (name
);
2371 *var
= scm_basic_make_class (meta
, tmp
,
2372 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2374 scm_module_define (scm_module_goops
, tmp
, *var
);
2378 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2381 create_standard_classes (void)
2384 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2385 scm_from_latin1_symbol ("specializers"),
2387 scm_from_latin1_symbol ("formals"),
2388 scm_from_latin1_symbol ("body"),
2389 scm_from_latin1_symbol ("make-procedure"),
2391 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2393 k_slot_definition
));
2394 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2395 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2398 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2401 scm_from_latin1_symbol ("effective-methods"));
2402 SCM setter_slots
= scm_list_1 (sym_setter
);
2403 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2406 /* Foreign class slot classes */
2407 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2408 scm_class_class
, scm_class_top
, SCM_EOL
);
2409 make_stdcls (&scm_class_protected
, "<protected-slot>",
2410 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2411 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2412 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2413 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2414 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2415 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2416 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2417 make_stdcls (&scm_class_self
, "<self-slot>",
2418 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2419 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2421 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2423 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2425 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2427 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2429 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2431 make_stdcls (&scm_class_scm
, "<scm-slot>",
2432 scm_class_class
, scm_class_protected
, SCM_EOL
);
2433 make_stdcls (&scm_class_int
, "<int-slot>",
2434 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2435 make_stdcls (&scm_class_float
, "<float-slot>",
2436 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2437 make_stdcls (&scm_class_double
, "<double-slot>",
2438 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2440 /* Continue initialization of class <class> */
2442 slots
= build_class_class_slots ();
2443 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2444 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2445 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2446 compute_getters_n_setters (slots
));
2448 /* scm_class_generic functions classes */
2449 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2450 scm_class_class
, scm_class_class
, SCM_EOL
);
2451 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2452 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2453 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2454 make_stdcls (&scm_class_method
, "<method>",
2455 scm_class_class
, scm_class_object
, method_slots
);
2456 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2457 scm_class_class
, scm_class_method
, amethod_slots
);
2458 make_stdcls (&scm_class_applicable
, "<applicable>",
2459 scm_class_class
, scm_class_top
, SCM_EOL
);
2460 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2461 scm_class_applicable_struct_class
,
2462 scm_list_2 (scm_class_object
, scm_class_applicable
),
2463 scm_list_1 (sym_procedure
));
2464 make_stdcls (&scm_class_generic
, "<generic>",
2465 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2466 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2467 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2468 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2469 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2470 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2471 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2472 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2473 make_stdcls (&scm_class_accessor
, "<accessor>",
2474 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2475 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2476 make_stdcls (&scm_class_extended_generic_with_setter
,
2477 "<extended-generic-with-setter>",
2478 scm_class_applicable_struct_class
,
2479 scm_list_2 (scm_class_extended_generic
,
2480 scm_class_generic_with_setter
),
2482 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2483 SCM_CLASSF_PURE_GENERIC
);
2484 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2485 scm_class_applicable_struct_class
,
2486 scm_list_2 (scm_class_accessor
,
2487 scm_class_extended_generic_with_setter
),
2489 /* <extended-generic> is misplaced. */
2490 fix_cpl (scm_class_extended_accessor
,
2491 scm_class_extended_generic
, scm_class_generic_with_setter
);
2492 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2494 /* Primitive types classes */
2495 make_stdcls (&scm_class_boolean
, "<boolean>",
2496 scm_class_class
, scm_class_top
, SCM_EOL
);
2497 make_stdcls (&scm_class_char
, "<char>",
2498 scm_class_class
, scm_class_top
, SCM_EOL
);
2499 make_stdcls (&scm_class_list
, "<list>",
2500 scm_class_class
, scm_class_top
, SCM_EOL
);
2501 make_stdcls (&scm_class_pair
, "<pair>",
2502 scm_class_class
, scm_class_list
, SCM_EOL
);
2503 make_stdcls (&scm_class_null
, "<null>",
2504 scm_class_class
, scm_class_list
, SCM_EOL
);
2505 make_stdcls (&scm_class_string
, "<string>",
2506 scm_class_class
, scm_class_top
, SCM_EOL
);
2507 make_stdcls (&scm_class_symbol
, "<symbol>",
2508 scm_class_class
, scm_class_top
, SCM_EOL
);
2509 make_stdcls (&scm_class_vector
, "<vector>",
2510 scm_class_class
, scm_class_top
, SCM_EOL
);
2511 make_stdcls (&class_foreign
, "<foreign>",
2512 scm_class_class
, scm_class_top
, SCM_EOL
);
2513 make_stdcls (&class_hashtable
, "<hashtable>",
2514 scm_class_class
, scm_class_top
, SCM_EOL
);
2515 make_stdcls (&class_fluid
, "<fluid>",
2516 scm_class_class
, scm_class_top
, SCM_EOL
);
2517 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2518 scm_class_class
, scm_class_top
, SCM_EOL
);
2519 make_stdcls (&class_frame
, "<frame>",
2520 scm_class_class
, scm_class_top
, SCM_EOL
);
2521 make_stdcls (&class_objcode
, "<objcode>",
2522 scm_class_class
, scm_class_top
, SCM_EOL
);
2523 make_stdcls (&class_vm
, "<vm>",
2524 scm_class_class
, scm_class_top
, SCM_EOL
);
2525 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2526 scm_class_class
, scm_class_top
, SCM_EOL
);
2527 make_stdcls (&class_bytevector
, "<bytevector>",
2528 scm_class_class
, scm_class_top
, SCM_EOL
);
2529 make_stdcls (&class_uvec
, "<uvec>",
2530 scm_class_class
, class_bytevector
, SCM_EOL
);
2531 make_stdcls (&class_array
, "<array>",
2532 scm_class_class
, scm_class_top
, SCM_EOL
);
2533 make_stdcls (&class_bitvector
, "<bitvector>",
2534 scm_class_class
, scm_class_top
, SCM_EOL
);
2535 make_stdcls (&scm_class_number
, "<number>",
2536 scm_class_class
, scm_class_top
, SCM_EOL
);
2537 make_stdcls (&scm_class_complex
, "<complex>",
2538 scm_class_class
, scm_class_number
, SCM_EOL
);
2539 make_stdcls (&scm_class_real
, "<real>",
2540 scm_class_class
, scm_class_complex
, SCM_EOL
);
2541 make_stdcls (&scm_class_integer
, "<integer>",
2542 scm_class_class
, scm_class_real
, SCM_EOL
);
2543 make_stdcls (&scm_class_fraction
, "<fraction>",
2544 scm_class_class
, scm_class_real
, SCM_EOL
);
2545 make_stdcls (&scm_class_keyword
, "<keyword>",
2546 scm_class_class
, scm_class_top
, SCM_EOL
);
2547 make_stdcls (&scm_class_unknown
, "<unknown>",
2548 scm_class_class
, scm_class_top
, SCM_EOL
);
2549 make_stdcls (&scm_class_procedure
, "<procedure>",
2550 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2551 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2552 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2553 make_stdcls (&scm_class_port
, "<port>",
2554 scm_class_class
, scm_class_top
, SCM_EOL
);
2555 make_stdcls (&scm_class_input_port
, "<input-port>",
2556 scm_class_class
, scm_class_port
, SCM_EOL
);
2557 make_stdcls (&scm_class_output_port
, "<output-port>",
2558 scm_class_class
, scm_class_port
, SCM_EOL
);
2559 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2561 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2565 /**********************************************************************
2569 **********************************************************************/
2572 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2578 sprintf (buffer
, template, type_name
);
2579 name
= scm_from_utf8_symbol (buffer
);
2582 name
= SCM_GOOPS_UNBOUND
;
2584 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2585 name
, supers
, SCM_EOL
);
2589 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2593 if (scm_is_true (type_name_sym
))
2595 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2596 scm_symbol_to_string (type_name_sym
),
2597 scm_from_locale_string (">")));
2598 name
= scm_string_to_symbol (name
);
2601 name
= SCM_GOOPS_UNBOUND
;
2603 return scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2604 name
, supers
, SCM_EOL
);
2608 scm_make_extended_class (char const *type_name
, int applicablep
)
2610 return make_class_from_template ("<%s>",
2612 scm_list_1 (applicablep
2613 ? scm_class_applicable
2619 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2621 return make_class_from_symbol (type_name_sym
,
2622 scm_list_1 (applicablep
2623 ? scm_class_applicable
2629 scm_i_inherit_applicable (SCM c
)
2631 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2633 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2634 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2635 /* patch scm_class_applicable into direct-supers */
2636 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2637 if (scm_is_false (top
))
2638 dsupers
= scm_append (scm_list_2 (dsupers
,
2639 scm_list_1 (scm_class_applicable
)));
2642 SCM_SETCAR (top
, scm_class_applicable
);
2643 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2645 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2646 /* patch scm_class_applicable into cpl */
2647 top
= scm_c_memq (scm_class_top
, cpl
);
2648 if (scm_is_false (top
))
2652 SCM_SETCAR (top
, scm_class_applicable
);
2653 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2655 /* add class to direct-subclasses of scm_class_applicable */
2656 SCM_SET_SLOT (scm_class_applicable
,
2657 scm_si_direct_subclasses
,
2658 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2659 scm_si_direct_subclasses
)));
2664 create_smob_classes (void)
2668 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2669 scm_smob_class
[i
] = SCM_BOOL_F
;
2671 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2673 for (i
= 0; i
< scm_numsmob
; ++i
)
2674 if (scm_is_false (scm_smob_class
[i
]))
2675 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2676 scm_smobs
[i
].apply
!= 0);
2680 scm_make_port_classes (long ptobnum
, char *type_name
)
2682 SCM c
, class = make_class_from_template ("<%s-port>",
2684 scm_list_1 (scm_class_port
),
2686 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2687 = make_class_from_template ("<%s-input-port>",
2689 scm_list_2 (class, scm_class_input_port
),
2691 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2692 = make_class_from_template ("<%s-output-port>",
2694 scm_list_2 (class, scm_class_output_port
),
2696 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2698 = make_class_from_template ("<%s-input-output-port>",
2700 scm_list_2 (class, scm_class_input_output_port
),
2702 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2703 SCM_SET_SLOT (c
, scm_si_cpl
,
2704 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2708 create_port_classes (void)
2712 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
2713 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2717 make_struct_class (void *closure SCM_UNUSED
,
2718 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2720 if (scm_is_false (data
))
2721 scm_i_define_class_for_vtable (vtable
);
2722 return SCM_UNSPECIFIED
;
2726 create_struct_classes (void)
2728 /* FIXME: take the vtable_class_map while initializing goops? */
2729 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2733 /**********************************************************************
2737 **********************************************************************/
2742 if (!goops_loaded_p
)
2743 scm_c_resolve_module ("oop goops");
2747 SCM_SYMBOL (sym_o
, "o");
2748 SCM_SYMBOL (sym_x
, "x");
2750 SCM_KEYWORD (k_accessor
, "accessor");
2751 SCM_KEYWORD (k_getter
, "getter");
2754 scm_ensure_accessor (SCM name
)
2758 var
= scm_module_variable (scm_current_module (), name
);
2759 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
2760 gf
= SCM_VARIABLE_REF (var
);
2764 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2766 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2767 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2768 k_name
, name
, k_setter
, gf
));
2776 * Debugging utilities
2779 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2781 "Return @code{#t} if @var{obj} is a pure generic.")
2782 #define FUNC_NAME s_scm_pure_generic_p
2784 return scm_from_bool (SCM_PUREGENERICP (obj
));
2788 #endif /* GUILE_DEBUG */
2794 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2796 "Announce that GOOPS is loaded and perform initialization\n"
2797 "on the C level which depends on the loaded GOOPS modules.")
2798 #define FUNC_NAME s_scm_sys_goops_loaded
2801 var_compute_applicable_methods
=
2802 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2804 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2806 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2808 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2809 var_no_applicable_method
=
2810 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2812 scm_module_variable (scm_module_goops
, sym_change_class
);
2813 setup_extended_primitive_generics ();
2814 return SCM_UNSPECIFIED
;
2818 SCM scm_module_goops
;
2821 scm_init_goops_builtins (void)
2823 scm_module_goops
= scm_current_module ();
2825 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2827 #include "libguile/goops.x"
2829 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2830 hell_mutex
= scm_make_mutex ();
2832 create_basic_classes ();
2833 create_standard_classes ();
2834 create_smob_classes ();
2835 create_struct_classes ();
2836 create_port_classes ();
2839 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2840 scm_no_applicable_method
=
2841 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2842 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
2845 return SCM_UNSPECIFIED
;
2851 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2852 scm_init_goops_builtins
);