1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
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>.
35 #include "libguile/_scm.h"
36 #include "libguile/alist.h"
37 #include "libguile/async.h"
38 #include "libguile/chars.h"
39 #include "libguile/debug.h"
40 #include "libguile/dynl.h"
41 #include "libguile/dynwind.h"
42 #include "libguile/eval.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/objects.h"
48 #include "libguile/ports.h"
49 #include "libguile/procprop.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
61 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
63 /* this file is a mess. in theory, though, we shouldn't have many SCM references
64 -- most of the references should be to vars. */
66 static SCM var_slot_unbound
= SCM_BOOL_F
;
67 static SCM var_slot_missing
= SCM_BOOL_F
;
68 static SCM var_compute_cpl
= SCM_BOOL_F
;
69 static SCM var_no_applicable_method
= SCM_BOOL_F
;
70 static SCM var_memoize_method_x
= SCM_BOOL_F
;
71 static SCM var_change_class
= SCM_BOOL_F
;
73 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
74 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
75 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
76 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
77 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
78 SCM_SYMBOL (sym_change_class
, "change-class");
80 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
83 /* FIXME, exports should come from the scm file only */
84 #define DEFVAR(v, val) \
85 { scm_module_define (scm_module_goops, (v), (val)); \
86 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
90 /* Class redefinition protocol:
92 A class is represented by a heap header h1 which points to a
93 malloc:ed memory block m1.
95 When a new version of a class is created, a new header h2 and
96 memory block m2 are allocated. The headers h1 and h2 then switch
97 pointers so that h1 refers to m2 and h2 to m1. In this way, names
98 bound to h1 will point to the new class at the same time as h2 will
99 be a handle which the GC will use to free m1.
101 The `redefined' slot of m1 will be set to point to h1. An old
102 instance will have its class pointer (the CAR of the heap header)
103 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
104 the class modification and the new class pointer can be found via
108 /* The following definition is located in libguile/objects.h:
109 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
112 #define TEST_CHANGE_CLASS(obj, class) \
114 class = SCM_CLASS_OF (obj); \
115 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
117 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
118 class = SCM_CLASS_OF (obj); \
122 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
123 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
125 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
126 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
128 static int goops_loaded_p
= 0;
129 static scm_t_rstate
*goops_rstate
;
131 /* These variables are filled in by the object system when loaded. */
132 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
133 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
134 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
135 SCM scm_class_vector
, scm_class_null
;
136 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
137 SCM scm_class_unknown
;
138 SCM scm_class_top
, scm_class_object
, scm_class_class
;
139 SCM scm_class_applicable
;
140 SCM scm_class_entity
, scm_class_entity_with_setter
;
141 SCM scm_class_generic
, scm_class_generic_with_setter
;
142 SCM scm_class_accessor
;
143 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
144 SCM scm_class_extended_accessor
;
145 SCM scm_class_method
;
146 SCM scm_class_simple_method
, scm_class_accessor_method
;
147 SCM scm_class_procedure_class
;
148 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
149 SCM scm_class_entity_class
;
150 SCM scm_class_number
, scm_class_list
;
151 SCM scm_class_keyword
;
152 SCM scm_class_port
, scm_class_input_output_port
;
153 SCM scm_class_input_port
, scm_class_output_port
;
154 SCM scm_class_foreign_class
, scm_class_foreign_object
;
155 SCM scm_class_foreign_slot
;
156 SCM scm_class_self
, scm_class_protected
;
157 SCM scm_class_opaque
, scm_class_read_only
;
158 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
160 SCM scm_class_int
, scm_class_float
, scm_class_double
;
162 /* Port classes. Allocate 3 times the maximum number of port types so that
163 input ports, output ports, and in/out ports can be stored at different
164 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
165 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
168 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
170 SCM scm_no_applicable_method
;
172 SCM_SYMBOL (scm_sym_define_public
, "define-public");
174 static SCM
scm_make_unbound (void);
175 static SCM
scm_unbound_p (SCM obj
);
176 static SCM
scm_assert_bound (SCM value
, SCM obj
);
177 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
178 static SCM
scm_sys_goops_loaded (void);
179 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
182 /* This function is used for efficient type dispatch. */
183 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
185 "Return the class of @var{x}.")
186 #define FUNC_NAME s_scm_class_of
188 switch (SCM_ITAG3 (x
))
192 return scm_class_integer
;
196 return scm_class_char
;
197 else if (scm_is_bool (x
))
198 return scm_class_boolean
;
199 else if (scm_is_null (x
))
200 return scm_class_null
;
202 return scm_class_unknown
;
205 switch (SCM_TYP7 (x
))
207 case scm_tcs_cons_nimcar
:
208 return scm_class_pair
;
209 case scm_tcs_closures
:
210 return scm_class_procedure
;
212 return scm_class_symbol
;
215 return scm_class_vector
;
217 return scm_class_string
;
219 switch SCM_TYP16 (x
) {
221 return scm_class_integer
;
223 return scm_class_real
;
224 case scm_tc16_complex
:
225 return scm_class_complex
;
226 case scm_tc16_fraction
:
227 return scm_class_fraction
;
237 case scm_tc7_subr_1o
:
238 case scm_tc7_subr_2o
:
239 case scm_tc7_lsubr_2
:
241 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
242 return scm_class_primitive_generic
;
244 return scm_class_procedure
;
246 case scm_tc7_program
:
247 return scm_class_procedure
;
249 return scm_class_procedure_with_setter
;
253 scm_t_bits type
= SCM_TYP16 (x
);
254 if (type
!= scm_tc16_port_with_ps
)
255 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
256 x
= SCM_PORT_WITH_PS_PORT (x
);
257 /* fall through to ports */
260 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
261 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
262 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
263 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
264 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
266 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
267 return SCM_CLASS_OF (x
);
268 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
271 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
272 scm_change_object_class (x
,
273 SCM_CLASS_OF (x
), /* old */
274 SCM_OBJ_CLASS_REDEF (x
)); /* new */
275 return SCM_CLASS_OF (x
);
279 /* ordinary struct */
280 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
281 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
282 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
285 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
286 SCM
class = scm_make_extended_class_from_symbol (scm_is_true (name
)
289 SCM_I_OPERATORP (x
));
290 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
296 return scm_class_pair
;
298 return scm_class_unknown
;
304 case scm_tc3_closure
:
308 return scm_class_unknown
;
312 /******************************************************************************
316 * This version doesn't fully handle multiple-inheritance. It serves
317 * only for booting classes and will be overloaded in Scheme
319 ******************************************************************************/
322 map (SCM (*proc
) (SCM
), SCM ls
)
324 if (scm_is_null (ls
))
328 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
331 while (!scm_is_null (ls
))
333 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
345 while (!scm_is_null (ls
))
347 SCM el
= SCM_CAR (ls
);
348 if (scm_is_false (scm_c_memq (el
, res
)))
349 res
= scm_cons (el
, res
);
356 compute_cpl (SCM
class)
359 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
362 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
363 SCM ls
= scm_append (scm_acons (class, supers
,
364 map (compute_cpl
, supers
)));
365 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
369 /******************************************************************************
373 ******************************************************************************/
376 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
384 if (!scm_is_symbol (tmp
))
385 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
387 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
388 res
= scm_cons (SCM_CAR (l
), res
);
389 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
392 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
396 build_slots_list (SCM dslots
, SCM cpl
)
398 register SCM res
= dslots
;
400 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
401 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
402 scm_si_direct_slots
),
405 /* res contains a list of slots. Remove slots which appears more than once */
406 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
413 while (!scm_is_null (ls
))
415 if (!scm_is_pair (SCM_CAR (ls
)))
416 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
423 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
425 "Return a list consisting of the names of all slots belonging to\n"
426 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
428 #define FUNC_NAME s_scm_sys_compute_slots
430 SCM_VALIDATE_CLASS (1, class);
431 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
432 SCM_SLOT (class, scm_si_cpl
));
437 /******************************************************************************
439 * compute-getters-n-setters
441 * This version doesn't handle slot options. It serves only for booting
442 * classes and will be overloaded in Scheme.
444 ******************************************************************************/
446 SCM_KEYWORD (k_init_value
, "init-value");
447 SCM_KEYWORD (k_init_thunk
, "init-thunk");
450 compute_getters_n_setters (SCM slots
)
456 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
458 SCM init
= SCM_BOOL_F
;
459 SCM options
= SCM_CDAR (slots
);
460 if (!scm_is_null (options
))
462 init
= scm_get_keyword (k_init_value
, options
, 0);
465 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
467 scm_list_2 (scm_sym_quote
,
472 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
474 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
476 scm_from_int (i
++))),
478 cdrloc
= SCM_CDRLOC (*cdrloc
);
483 /******************************************************************************
487 ******************************************************************************/
489 /*fixme* Manufacture keywords in advance */
491 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
495 for (i
= 0; i
!= len
; i
+= 2)
497 SCM obj
= SCM_CAR (l
);
499 if (!scm_is_keyword (obj
))
500 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
501 else if (scm_is_eq (obj
, key
))
507 return default_value
;
511 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
512 (SCM key
, SCM l
, SCM default_value
),
513 "Determine an associated value for the keyword @var{key} from\n"
514 "the list @var{l}. The list @var{l} has to consist of an even\n"
515 "number of elements, where, starting with the first, every\n"
516 "second element is a keyword, followed by its associated value.\n"
517 "If @var{l} does not hold a value for @var{key}, the value\n"
518 "@var{default_value} is returned.")
519 #define FUNC_NAME s_scm_get_keyword
523 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
524 len
= scm_ilength (l
);
525 if (len
< 0 || len
% 2 == 1)
526 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
528 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
533 SCM_KEYWORD (k_init_keyword
, "init-keyword");
535 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
536 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
538 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
539 (SCM obj
, SCM initargs
),
540 "Initialize the object @var{obj} with the given arguments\n"
542 #define FUNC_NAME s_scm_sys_initialize_object
544 SCM tmp
, get_n_set
, slots
;
545 SCM
class = SCM_CLASS_OF (obj
);
548 SCM_VALIDATE_INSTANCE (1, obj
);
549 n_initargs
= scm_ilength (initargs
);
550 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
552 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
553 slots
= SCM_SLOT (class, scm_si_slots
);
555 /* See for each slot how it must be initialized */
557 !scm_is_null (slots
);
558 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
560 SCM slot_name
= SCM_CAR (slots
);
563 if (!scm_is_null (SCM_CDR (slot_name
)))
565 /* This slot admits (perhaps) to be initialized at creation time */
566 long n
= scm_ilength (SCM_CDR (slot_name
));
567 if (n
& 1) /* odd or -1 */
568 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
569 scm_list_1 (slot_name
));
570 tmp
= scm_i_get_keyword (k_init_keyword
,
575 slot_name
= SCM_CAR (slot_name
);
578 /* an initarg was provided for this slot */
579 if (!scm_is_keyword (tmp
))
580 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
582 slot_value
= scm_i_get_keyword (tmp
,
591 /* set slot to provided value */
592 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
595 /* set slot to its :init-form if it exists */
596 tmp
= SCM_CADAR (get_n_set
);
597 if (scm_is_true (tmp
))
599 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
600 if (SCM_GOOPS_UNBOUNDP (slot_value
))
601 set_slot_value (class,
613 /* NOTE: The following macros are interdependent with code
614 * in goops.scm:compute-getters-n-setters
616 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
617 (SCM_I_INUMP (SCM_CDDR (gns)) \
618 || (scm_is_pair (SCM_CDDR (gns)) \
619 && scm_is_pair (SCM_CDDDR (gns)) \
620 && scm_is_pair (SCM_CDDDDR (gns))))
621 #define SCM_GNS_INDEX(gns) \
622 (SCM_I_INUMP (SCM_CDDR (gns)) \
623 ? SCM_I_INUM (SCM_CDDR (gns)) \
624 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
625 #define SCM_GNS_SIZE(gns) \
626 (SCM_I_INUMP (SCM_CDDR (gns)) \
628 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
630 SCM_KEYWORD (k_class
, "class");
631 SCM_KEYWORD (k_allocation
, "allocation");
632 SCM_KEYWORD (k_instance
, "instance");
634 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
637 #define FUNC_NAME s_scm_sys_prep_layout_x
639 SCM slots
, getters_n_setters
, nfields
;
640 unsigned long int n
, i
;
644 SCM_VALIDATE_INSTANCE (1, class);
645 slots
= SCM_SLOT (class, scm_si_slots
);
646 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
647 nfields
= SCM_SLOT (class, scm_si_nfields
);
648 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
649 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
650 scm_list_1 (nfields
));
651 n
= 2 * SCM_I_INUM (nfields
);
652 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
653 && SCM_SUBCLASSP (class, scm_class_class
))
654 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
655 scm_list_1 (nfields
));
657 layout
= scm_i_make_string (n
, &s
);
659 while (scm_is_pair (getters_n_setters
))
661 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
664 int len
, index
, size
;
667 if (i
>= n
|| !scm_is_pair (slots
))
670 /* extract slot type */
671 len
= scm_ilength (SCM_CDAR (slots
));
672 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
673 len
, SCM_BOOL_F
, FUNC_NAME
);
674 /* determine slot GC protection and access mode */
675 if (scm_is_false (type
))
682 if (!SCM_CLASSP (type
))
683 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
684 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
686 if (SCM_SUBCLASSP (type
, scm_class_self
))
688 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
693 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
695 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
707 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
708 if (index
!= (i
>> 1))
710 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
718 slots
= SCM_CDR (slots
);
719 getters_n_setters
= SCM_CDR (getters_n_setters
);
721 if (!scm_is_null (slots
))
724 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
726 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
727 return SCM_UNSPECIFIED
;
731 static void prep_hashsets (SCM
);
733 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
734 (SCM
class, SCM dsupers
),
736 #define FUNC_NAME s_scm_sys_inherit_magic_x
740 SCM_VALIDATE_INSTANCE (1, class);
741 while (!scm_is_null (ls
))
743 SCM_ASSERT (scm_is_pair (ls
)
744 && SCM_INSTANCEP (SCM_CAR (ls
)),
748 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
751 flags
&= SCM_CLASSF_INHERIT
;
753 if (! (flags
& SCM_CLASSF_ENTITY
))
755 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
758 * We could avoid calling scm_gc_malloc in the allocation code
759 * (in which case the following two lines are needed). Instead
760 * we make 0-slot instances non-light, so that the light case
761 * can be handled without special cases.
764 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
766 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
768 /* NOTE: The following depends on scm_struct_i_size. */
769 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
772 SCM_SET_CLASS_FLAGS (class, flags
);
774 prep_hashsets (class);
776 return SCM_UNSPECIFIED
;
781 prep_hashsets (SCM
class)
785 for (i
= 0; i
< 7; ++i
)
786 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
789 /******************************************************************************/
792 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
794 SCM z
, cpl
, slots
, nfields
, g_n_s
;
796 /* Allocate one instance */
797 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
799 /* Initialize its slots */
800 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
801 cpl
= compute_cpl (z
);
802 slots
= build_slots_list (maplist (dslots
), cpl
);
803 nfields
= scm_from_int (scm_ilength (slots
));
804 g_n_s
= compute_getters_n_setters (slots
);
806 SCM_SET_SLOT (z
, scm_si_name
, name
);
807 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
808 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
809 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
810 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
811 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
812 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
813 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
814 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
815 SCM_SET_SLOT (z
, scm_si_environment
,
816 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
818 /* Add this class in the direct-subclasses slot of dsupers */
821 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
822 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
823 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
824 scm_si_direct_subclasses
)));
827 /* Support for the underlying structs: */
828 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
829 ? (SCM_CLASSF_GOOPS_OR_VALID
830 | SCM_CLASSF_OPERATOR
832 : class == scm_class_operator_class
833 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
834 : SCM_CLASSF_GOOPS_OR_VALID
));
839 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
841 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
842 scm_sys_inherit_magic_x (z
, dsupers
);
843 scm_sys_prep_layout_x (z
);
847 /******************************************************************************/
849 SCM_SYMBOL (sym_layout
, "layout");
850 SCM_SYMBOL (sym_vcell
, "vcell");
851 SCM_SYMBOL (sym_vtable
, "vtable");
852 SCM_SYMBOL (sym_print
, "print");
853 SCM_SYMBOL (sym_procedure
, "procedure");
854 SCM_SYMBOL (sym_setter
, "setter");
855 SCM_SYMBOL (sym_redefined
, "redefined");
856 SCM_SYMBOL (sym_h0
, "h0");
857 SCM_SYMBOL (sym_h1
, "h1");
858 SCM_SYMBOL (sym_h2
, "h2");
859 SCM_SYMBOL (sym_h3
, "h3");
860 SCM_SYMBOL (sym_h4
, "h4");
861 SCM_SYMBOL (sym_h5
, "h5");
862 SCM_SYMBOL (sym_h6
, "h6");
863 SCM_SYMBOL (sym_h7
, "h7");
864 SCM_SYMBOL (sym_name
, "name");
865 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
866 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
867 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
868 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
869 SCM_SYMBOL (sym_cpl
, "cpl");
870 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
871 SCM_SYMBOL (sym_slots
, "slots");
872 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
873 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
874 SCM_SYMBOL (sym_nfields
, "nfields");
875 SCM_SYMBOL (sym_environment
, "environment");
879 build_class_class_slots ()
882 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
883 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
884 scm_list_1 (sym_print
),
885 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
886 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
887 scm_list_1 (sym_redefined
),
888 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
889 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
890 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
891 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
892 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
893 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
894 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
895 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
896 scm_list_1 (sym_name
),
897 scm_list_1 (sym_direct_supers
),
898 scm_list_1 (sym_direct_slots
),
899 scm_list_1 (sym_direct_subclasses
),
900 scm_list_1 (sym_direct_methods
),
901 scm_list_1 (sym_cpl
),
902 scm_list_1 (sym_default_slot_definition_class
),
903 scm_list_1 (sym_slots
),
904 scm_list_1 (sym_getters_n_setters
),
905 scm_list_1 (sym_keyword_access
),
906 scm_list_1 (sym_nfields
),
907 scm_list_1 (sym_environment
),
912 create_basic_classes (void)
914 /* SCM slots_of_class = build_class_class_slots (); */
916 /**** <scm_class_class> ****/
917 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
918 + 2 * scm_vtable_offset_user
);
919 SCM name
= scm_from_locale_symbol ("<class>");
920 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
923 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
924 | SCM_CLASSF_METACLASS
));
926 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
927 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
928 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
929 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
930 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
931 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
932 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
933 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
934 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
935 compute_getters_n_setters (slots_of_class)); */
936 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
937 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
938 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
940 prep_hashsets (scm_class_class
);
942 DEFVAR(name
, scm_class_class
);
944 /**** <scm_class_top> ****/
945 name
= scm_from_locale_symbol ("<top>");
946 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
951 DEFVAR(name
, scm_class_top
);
953 /**** <scm_class_object> ****/
954 name
= scm_from_locale_symbol ("<object>");
955 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
957 scm_list_1 (scm_class_top
),
960 DEFVAR (name
, scm_class_object
);
962 /* <top> <object> and <class> were partially initialized. Correct them here */
963 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
965 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
966 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
969 /******************************************************************************/
971 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
973 "Return @code{#t} if @var{obj} is an instance.")
974 #define FUNC_NAME s_scm_instance_p
976 return scm_from_bool (SCM_INSTANCEP (obj
));
981 /******************************************************************************
983 * Meta object accessors
985 ******************************************************************************/
986 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
988 "Return the class name of @var{obj}.")
989 #define FUNC_NAME s_scm_class_name
991 SCM_VALIDATE_CLASS (1, obj
);
992 return scm_slot_ref (obj
, sym_name
);
996 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
998 "Return the direct superclasses of the class @var{obj}.")
999 #define FUNC_NAME s_scm_class_direct_supers
1001 SCM_VALIDATE_CLASS (1, obj
);
1002 return scm_slot_ref (obj
, sym_direct_supers
);
1006 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1008 "Return the direct slots of the class @var{obj}.")
1009 #define FUNC_NAME s_scm_class_direct_slots
1011 SCM_VALIDATE_CLASS (1, obj
);
1012 return scm_slot_ref (obj
, sym_direct_slots
);
1016 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1018 "Return the direct subclasses of the class @var{obj}.")
1019 #define FUNC_NAME s_scm_class_direct_subclasses
1021 SCM_VALIDATE_CLASS (1, obj
);
1022 return scm_slot_ref(obj
, sym_direct_subclasses
);
1026 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1028 "Return the direct methods of the class @var{obj}")
1029 #define FUNC_NAME s_scm_class_direct_methods
1031 SCM_VALIDATE_CLASS (1, obj
);
1032 return scm_slot_ref (obj
, sym_direct_methods
);
1036 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1038 "Return the class precedence list of the class @var{obj}.")
1039 #define FUNC_NAME s_scm_class_precedence_list
1041 SCM_VALIDATE_CLASS (1, obj
);
1042 return scm_slot_ref (obj
, sym_cpl
);
1046 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1048 "Return the slot list of the class @var{obj}.")
1049 #define FUNC_NAME s_scm_class_slots
1051 SCM_VALIDATE_CLASS (1, obj
);
1052 return scm_slot_ref (obj
, sym_slots
);
1056 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1058 "Return the environment of the class @var{obj}.")
1059 #define FUNC_NAME s_scm_class_environment
1061 SCM_VALIDATE_CLASS (1, obj
);
1062 return scm_slot_ref(obj
, sym_environment
);
1067 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1069 "Return the name of the generic function @var{obj}.")
1070 #define FUNC_NAME s_scm_generic_function_name
1072 SCM_VALIDATE_GENERIC (1, obj
);
1073 return scm_procedure_property (obj
, scm_sym_name
);
1077 SCM_SYMBOL (sym_methods
, "methods");
1078 SCM_SYMBOL (sym_extended_by
, "extended-by");
1079 SCM_SYMBOL (sym_extends
, "extends");
1082 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1084 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1085 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1086 while (!scm_is_null (gfs
))
1088 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1089 gfs
= SCM_CDR (gfs
);
1091 return method_lists
;
1095 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1097 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1099 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1100 while (!scm_is_null (gfs
))
1102 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1103 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1106 gfs
= SCM_CDR (gfs
);
1109 return method_lists
;
1112 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1114 "Return the methods of the generic function @var{obj}.")
1115 #define FUNC_NAME s_scm_generic_function_methods
1118 SCM_VALIDATE_GENERIC (1, obj
);
1119 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1120 methods
= fold_downward_gf_methods (methods
, obj
);
1121 return scm_append (methods
);
1125 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1127 "Return the generic function for the method @var{obj}.")
1128 #define FUNC_NAME s_scm_method_generic_function
1130 SCM_VALIDATE_METHOD (1, obj
);
1131 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1135 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1137 "Return specializers of the method @var{obj}.")
1138 #define FUNC_NAME s_scm_method_specializers
1140 SCM_VALIDATE_METHOD (1, obj
);
1141 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1145 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1147 "Return the procedure of the method @var{obj}.")
1148 #define FUNC_NAME s_scm_method_procedure
1150 SCM_VALIDATE_METHOD (1, obj
);
1151 return scm_slot_ref (obj
, sym_procedure
);
1155 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1157 "Return the slot definition of the accessor @var{obj}.")
1158 #define FUNC_NAME s_scm_accessor_method_slot_definition
1160 SCM_VALIDATE_ACCESSOR (1, obj
);
1161 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1165 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1167 "Internal GOOPS magic---don't use this function!")
1168 #define FUNC_NAME s_scm_sys_tag_body
1170 return scm_cons (SCM_IM_LAMBDA
, body
);
1174 /******************************************************************************
1176 * S l o t a c c e s s
1178 ******************************************************************************/
1180 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1182 "Return the unbound value.")
1183 #define FUNC_NAME s_scm_make_unbound
1185 return SCM_GOOPS_UNBOUND
;
1189 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1191 "Return @code{#t} if @var{obj} is unbound.")
1192 #define FUNC_NAME s_scm_unbound_p
1194 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1198 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1199 (SCM value
, SCM obj
),
1200 "Return @var{value} if it is bound, and invoke the\n"
1201 "@var{slot-unbound} method of @var{obj} if it is not.")
1202 #define FUNC_NAME s_scm_assert_bound
1204 if (SCM_GOOPS_UNBOUNDP (value
))
1205 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1210 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1211 (SCM obj
, SCM index
),
1212 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1213 "the value from @var{obj}.")
1214 #define FUNC_NAME s_scm_at_assert_bound_ref
1216 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1217 if (SCM_GOOPS_UNBOUNDP (value
))
1218 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1223 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1224 (SCM obj
, SCM index
),
1225 "Return the slot value with index @var{index} from @var{obj}.")
1226 #define FUNC_NAME s_scm_sys_fast_slot_ref
1228 unsigned long int i
;
1230 SCM_VALIDATE_INSTANCE (1, obj
);
1231 i
= scm_to_unsigned_integer (index
, 0,
1232 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1235 return SCM_SLOT (obj
, i
);
1239 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1240 (SCM obj
, SCM index
, SCM value
),
1241 "Set the slot with index @var{index} in @var{obj} to\n"
1243 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1245 unsigned long int i
;
1247 SCM_VALIDATE_INSTANCE (1, obj
);
1248 i
= scm_to_unsigned_integer (index
, 0,
1249 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1253 SCM_SET_SLOT (obj
, i
, value
);
1255 return SCM_UNSPECIFIED
;
1263 /* In the future, this function will return the effective slot
1264 * definition associated with SLOT_NAME. Now it just returns some of
1265 * the information which will be stored in the effective slot
1270 slot_definition_using_name (SCM
class, SCM slot_name
)
1272 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1273 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1274 if (SCM_CAAR (slots
) == slot_name
)
1275 return SCM_CAR (slots
);
1280 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1281 #define FUNC_NAME "%get-slot-value"
1283 SCM access
= SCM_CDDR (slotdef
);
1285 * - access is an integer (the offset of this slot in the slots vector)
1286 * - otherwise (car access) is the getter function to apply
1288 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1289 * we can just assume fixnums here.
1291 if (SCM_I_INUMP (access
))
1292 /* Don't poke at the slots directly, because scm_struct_ref handles the
1293 access bits for us. */
1294 return scm_struct_ref (obj
, access
);
1297 /* We must evaluate (apply (car access) (list obj))
1298 * where (car access) is known to be a closure of arity 1 */
1299 register SCM code
, env
;
1301 code
= SCM_CAR (access
);
1302 if (!SCM_CLOSUREP (code
))
1303 return scm_call_1 (code
, obj
);
1304 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1307 /* Evaluate the closure body */
1308 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1314 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1316 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1317 if (scm_is_true (slotdef
))
1318 return get_slot_value (class, obj
, slotdef
);
1320 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1324 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1325 #define FUNC_NAME "%set-slot-value"
1327 SCM access
= SCM_CDDR (slotdef
);
1329 * - access is an integer (the offset of this slot in the slots vector)
1330 * - otherwise (cadr access) is the setter function to apply
1332 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1333 * we can just assume fixnums here.
1335 if (SCM_I_INUMP (access
))
1336 /* obey permissions bits via going through struct-set! */
1337 scm_struct_set_x (obj
, access
, value
);
1340 /* We must evaluate (apply (cadr l) (list obj value))
1341 * where (cadr l) is known to be a closure of arity 2 */
1342 register SCM code
, env
;
1344 code
= SCM_CADR (access
);
1345 if (!SCM_CLOSUREP (code
))
1346 scm_call_2 (code
, obj
, value
);
1349 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1350 scm_list_2 (obj
, value
),
1352 /* Evaluate the closure body */
1353 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1356 return SCM_UNSPECIFIED
;
1361 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1363 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1364 if (scm_is_true (slotdef
))
1365 return set_slot_value (class, obj
, slotdef
, value
);
1367 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1371 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1375 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1376 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1382 /* ======================================== */
1384 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1385 (SCM
class, SCM obj
, SCM slot_name
),
1387 #define FUNC_NAME s_scm_slot_ref_using_class
1391 SCM_VALIDATE_CLASS (1, class);
1392 SCM_VALIDATE_INSTANCE (2, obj
);
1393 SCM_VALIDATE_SYMBOL (3, slot_name
);
1395 res
= get_slot_value_using_name (class, obj
, slot_name
);
1396 if (SCM_GOOPS_UNBOUNDP (res
))
1397 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1403 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1404 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1406 #define FUNC_NAME s_scm_slot_set_using_class_x
1408 SCM_VALIDATE_CLASS (1, class);
1409 SCM_VALIDATE_INSTANCE (2, obj
);
1410 SCM_VALIDATE_SYMBOL (3, slot_name
);
1412 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1417 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1418 (SCM
class, SCM obj
, SCM slot_name
),
1420 #define FUNC_NAME s_scm_slot_bound_using_class_p
1422 SCM_VALIDATE_CLASS (1, class);
1423 SCM_VALIDATE_INSTANCE (2, obj
);
1424 SCM_VALIDATE_SYMBOL (3, slot_name
);
1426 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1432 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1433 (SCM
class, SCM obj
, SCM slot_name
),
1435 #define FUNC_NAME s_scm_slot_exists_using_class_p
1437 SCM_VALIDATE_CLASS (1, class);
1438 SCM_VALIDATE_INSTANCE (2, obj
);
1439 SCM_VALIDATE_SYMBOL (3, slot_name
);
1440 return test_slot_existence (class, obj
, slot_name
);
1445 /* ======================================== */
1447 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1448 (SCM obj
, SCM slot_name
),
1449 "Return the value from @var{obj}'s slot with the name\n"
1451 #define FUNC_NAME s_scm_slot_ref
1455 SCM_VALIDATE_INSTANCE (1, obj
);
1456 TEST_CHANGE_CLASS (obj
, class);
1458 res
= get_slot_value_using_name (class, obj
, slot_name
);
1459 if (SCM_GOOPS_UNBOUNDP (res
))
1460 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1465 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1466 (SCM obj
, SCM slot_name
, SCM value
),
1467 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1468 #define FUNC_NAME s_scm_slot_set_x
1472 SCM_VALIDATE_INSTANCE (1, obj
);
1473 TEST_CHANGE_CLASS(obj
, class);
1475 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1479 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1481 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1482 (SCM obj
, SCM slot_name
),
1483 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1485 #define FUNC_NAME s_scm_slot_bound_p
1489 SCM_VALIDATE_INSTANCE (1, obj
);
1490 TEST_CHANGE_CLASS(obj
, class);
1492 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1500 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1501 (SCM obj
, SCM slot_name
),
1502 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1503 #define FUNC_NAME s_scm_slot_exists_p
1507 SCM_VALIDATE_INSTANCE (1, obj
);
1508 SCM_VALIDATE_SYMBOL (2, slot_name
);
1509 TEST_CHANGE_CLASS (obj
, class);
1511 return test_slot_existence (class, obj
, slot_name
);
1516 /******************************************************************************
1518 * %allocate-instance (the low level instance allocation primitive)
1520 ******************************************************************************/
1522 static void clear_method_cache (SCM
);
1525 wrap_init (SCM
class, SCM
*m
, long n
)
1528 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1529 SCM layout
= SCM_PACK (slayout
);
1531 /* Set all SCM-holding slots to unbound */
1532 for (i
= 0; i
< n
; i
++)
1533 if (scm_i_symbol_ref (layout
, i
*2) == 'p')
1534 m
[i
] = SCM_GOOPS_UNBOUND
;
1538 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1540 (scm_t_bits
) m
, 0, 0);
1543 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1544 (SCM
class, SCM initargs
),
1545 "Create a new instance of class @var{class} and initialize it\n"
1546 "from the arguments @var{initargs}.")
1547 #define FUNC_NAME s_scm_sys_allocate_instance
1552 SCM_VALIDATE_CLASS (1, class);
1554 /* Most instances */
1555 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1557 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1558 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1559 return wrap_init (class, m
, n
);
1562 /* Foreign objects */
1563 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1564 return scm_make_foreign_object (class, initargs
);
1566 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1569 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1571 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1573 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1574 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1575 /* Generic functions */
1576 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1578 SCM gf
= wrap_init (class, m
, n
);
1579 clear_method_cache (gf
);
1583 return wrap_init (class, m
, n
);
1587 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1591 /* allocate class object */
1592 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1594 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1595 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1596 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1598 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1599 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1600 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1601 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1606 /* Non-light instances */
1608 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1609 return wrap_init (class, m
, n
);
1614 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1615 (SCM obj
, SCM setter
),
1617 #define FUNC_NAME s_scm_sys_set_object_setter_x
1619 SCM_ASSERT (SCM_STRUCTP (obj
)
1620 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1621 || SCM_I_ENTITYP (obj
)),
1625 if (SCM_I_ENTITYP (obj
))
1626 SCM_SET_ENTITY_SETTER (obj
, setter
);
1628 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1629 return SCM_UNSPECIFIED
;
1633 /******************************************************************************
1635 * %modify-instance (used by change-class to modify in place)
1637 ******************************************************************************/
1639 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1642 #define FUNC_NAME s_scm_sys_modify_instance
1644 SCM_VALIDATE_INSTANCE (1, old
);
1645 SCM_VALIDATE_INSTANCE (2, new);
1647 /* Exchange the data contained in old and new. We exchange rather than
1648 * scratch the old value with new to be correct with GC.
1649 * See "Class redefinition protocol above".
1651 SCM_CRITICAL_SECTION_START
;
1653 SCM car
= SCM_CAR (old
);
1654 SCM cdr
= SCM_CDR (old
);
1655 SCM_SETCAR (old
, SCM_CAR (new));
1656 SCM_SETCDR (old
, SCM_CDR (new));
1657 SCM_SETCAR (new, car
);
1658 SCM_SETCDR (new, cdr
);
1660 SCM_CRITICAL_SECTION_END
;
1661 return SCM_UNSPECIFIED
;
1665 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1668 #define FUNC_NAME s_scm_sys_modify_class
1670 SCM_VALIDATE_CLASS (1, old
);
1671 SCM_VALIDATE_CLASS (2, new);
1673 SCM_CRITICAL_SECTION_START
;
1675 SCM car
= SCM_CAR (old
);
1676 SCM cdr
= SCM_CDR (old
);
1677 SCM_SETCAR (old
, SCM_CAR (new));
1678 SCM_SETCDR (old
, SCM_CDR (new));
1679 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1680 SCM_SETCAR (new, car
);
1681 SCM_SETCDR (new, cdr
);
1682 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1684 SCM_CRITICAL_SECTION_END
;
1685 return SCM_UNSPECIFIED
;
1689 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1692 #define FUNC_NAME s_scm_sys_invalidate_class
1694 SCM_VALIDATE_CLASS (1, class);
1695 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1696 return SCM_UNSPECIFIED
;
1700 /* When instances change class, they finally get a new body, but
1701 * before that, they go through purgatory in hell. Odd as it may
1702 * seem, this data structure saves us from eternal suffering in
1703 * infinite recursions.
1706 static scm_t_bits
**hell
;
1707 static long n_hell
= 1; /* one place for the evil one himself */
1708 static long hell_size
= 4;
1709 static SCM hell_mutex
;
1715 for (i
= 1; i
< n_hell
; ++i
)
1716 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1722 go_to_hell (void *o
)
1724 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1725 scm_lock_mutex (hell_mutex
);
1726 if (n_hell
>= hell_size
)
1729 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1731 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1732 scm_unlock_mutex (hell_mutex
);
1736 go_to_heaven (void *o
)
1738 scm_lock_mutex (hell_mutex
);
1739 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1740 scm_unlock_mutex (hell_mutex
);
1744 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1747 purgatory (void *args
)
1749 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1750 SCM_PACK ((scm_t_bits
) args
));
1753 /* This function calls the generic function change-class for all
1754 * instances which aren't currently undergoing class change.
1758 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1761 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1762 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1763 (void *) SCM_UNPACK (obj
));
1766 /******************************************************************************
1772 * GGG E N E R I C F U N C T I O N S
1774 * This implementation provides
1775 * - generic functions (with class specializers)
1778 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1780 ******************************************************************************/
1782 SCM_KEYWORD (k_name
, "name");
1784 SCM_SYMBOL (sym_no_method
, "no-method");
1786 static SCM list_of_no_method
;
1788 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1792 scm_make_method_cache (SCM gf
)
1794 return scm_list_5 (SCM_IM_DISPATCH
,
1797 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1803 clear_method_cache (SCM gf
)
1805 SCM cache
= scm_make_method_cache (gf
);
1806 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1807 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1810 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1813 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1816 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1817 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1818 if (scm_is_true (used_by
))
1820 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1821 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1822 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1823 clear_method_cache (gf
);
1824 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1825 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1828 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1829 /* The sign of n is a flag indicating rest args. */
1830 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1832 return SCM_UNSPECIFIED
;
1836 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1839 #define FUNC_NAME s_scm_generic_capability_p
1841 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1842 proc
, SCM_ARG1
, FUNC_NAME
);
1843 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1849 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1852 #define FUNC_NAME s_scm_enable_primitive_generic_x
1854 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1855 while (!scm_is_null (subrs
))
1857 SCM subr
= SCM_CAR (subrs
);
1858 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1859 subr
, SCM_ARGn
, FUNC_NAME
);
1860 *SCM_SUBR_GENERIC (subr
)
1861 = scm_make (scm_list_3 (scm_class_generic
,
1863 SCM_SUBR_NAME (subr
)));
1864 subrs
= SCM_CDR (subrs
);
1866 return SCM_UNSPECIFIED
;
1870 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1873 #define FUNC_NAME s_scm_primitive_generic_generic
1875 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1877 if (!*SCM_SUBR_GENERIC (subr
))
1878 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1879 return *SCM_SUBR_GENERIC (subr
);
1881 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1885 typedef struct t_extension
{
1886 struct t_extension
*next
;
1892 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1894 static const char extension_gc_hint
[] = "GOOPS extension";
1896 static t_extension
*extensions
= 0;
1898 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1901 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1906 if (!*SCM_SUBR_GENERIC (extended
))
1907 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1908 gf
= *SCM_SUBR_GENERIC (extended
);
1909 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1911 SCM_SUBR_NAME (extension
));
1912 SCM_SET_SUBR_GENERIC (extension
, gext
);
1916 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1918 t_extension
**loc
= &extensions
;
1919 /* Make sure that extensions are placed before their own
1920 * extensions in the extensions list. O(N^2) algorithm, but
1921 * extensions of primitive generics are rare.
1923 while (*loc
&& extension
!= (*loc
)->extended
)
1924 loc
= &(*loc
)->next
;
1926 e
->extended
= extended
;
1927 e
->extension
= extension
;
1933 setup_extended_primitive_generics ()
1937 t_extension
*e
= extensions
;
1938 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1939 extensions
= e
->next
;
1943 /******************************************************************************
1945 * Protocol for calling a generic fumction
1946 * This protocol is roughly equivalent to (parameter are a little bit different
1947 * for efficiency reasons):
1949 * + apply-generic (gf args)
1950 * + compute-applicable-methods (gf args ...)
1951 * + sort-applicable-methods (methods args)
1952 * + apply-methods (gf methods args)
1954 * apply-methods calls make-next-method to build the "continuation" of a a
1955 * method. Applying a next-method will call apply-next-method which in
1956 * turn will call apply again to call effectively the following method.
1958 ******************************************************************************/
1961 applicablep (SCM actual
, SCM formal
)
1963 /* We already know that the cpl is well formed. */
1964 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1968 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1970 register SCM s1
, s2
;
1974 * m1 and m2 can have != length (i.e. one can be one element longer than the
1975 * other when we have a dotted parameter list). For instance, with the call
1978 * (define-method M (a . l) ....)
1979 * (define-method M (a) ....)
1981 * we consider that the second method is more specific.
1983 * BTW, targs is an array of types. We don't need it's size since
1984 * we already know that m1 and m2 are applicable (no risk to go past
1985 * the end of this array).
1988 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1989 if (scm_is_null(s1
)) return 1;
1990 if (scm_is_null(s2
)) return 0;
1991 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1992 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1994 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1995 if (cs1
== SCM_CAR(l
))
1997 if (cs2
== SCM_CAR(l
))
2000 return 0;/* should not occur! */
2003 return 0; /* should not occur! */
2006 #define BUFFSIZE 32 /* big enough for most uses */
2009 scm_i_vector2list (SCM l
, long len
)
2012 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2014 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
2015 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2021 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2024 SCM
*v
, vector
= SCM_EOL
;
2025 SCM buffer
[BUFFSIZE
];
2026 SCM save
= method_list
;
2027 scm_t_array_handle handle
;
2029 /* For reasonably sized method_lists we can try to avoid all the
2030 * consing and reorder the list in place...
2031 * This idea is due to David McClain <Dave_McClain@msn.com>
2033 if (size
<= BUFFSIZE
)
2035 for (i
= 0; i
< size
; i
++)
2037 buffer
[i
] = SCM_CAR (method_list
);
2038 method_list
= SCM_CDR (method_list
);
2044 /* Too many elements in method_list to keep everything locally */
2045 vector
= scm_i_vector2list (save
, size
);
2046 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2049 /* Use a simple shell sort since it is generally faster than qsort on
2050 * small vectors (which is probably mostly the case when we have to
2051 * sort a list of applicable methods).
2053 for (incr
= size
/ 2; incr
; incr
/= 2)
2055 for (i
= incr
; i
< size
; i
++)
2057 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2059 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2063 SCM tmp
= v
[j
+ incr
];
2071 if (size
<= BUFFSIZE
)
2073 /* We did it in locally, so restore the original list (reordered) in-place */
2074 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2076 SCM_SETCAR (method_list
, *v
);
2077 method_list
= SCM_CDR (method_list
);
2082 /* If we are here, that's that we did it the hard way... */
2083 scm_array_handle_release (&handle
);
2084 return scm_vector_to_list (vector
);
2088 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2092 SCM l
, fl
, applicable
= SCM_EOL
;
2094 SCM buffer
[BUFFSIZE
];
2098 scm_t_array_handle handle
;
2100 /* Build the list of arguments types */
2101 if (len
>= BUFFSIZE
)
2103 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2104 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2107 note that we don't have to work to reset the generation
2108 count. TMP is a new vector anyway, and it is found
2115 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2116 *p
++ = scm_class_of (SCM_CAR (args
));
2118 /* Build a list of all applicable methods */
2119 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2121 fl
= SPEC_OF (SCM_CAR (l
));
2122 /* Only accept accessors which match exactly in first arg. */
2123 if (SCM_ACCESSORP (SCM_CAR (l
))
2124 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2126 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2128 if (SCM_INSTANCEP (fl
)
2129 /* We have a dotted argument list */
2130 || (i
>= len
&& scm_is_null (fl
)))
2131 { /* both list exhausted */
2132 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2138 || !applicablep (types
[i
], SCM_CAR (fl
)))
2143 if (len
>= BUFFSIZE
)
2144 scm_array_handle_release (&handle
);
2150 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2151 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2157 : sort_applicable_methods (applicable
, count
, types
));
2161 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2164 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2167 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2168 #define FUNC_NAME s_sys_compute_applicable_methods
2171 SCM_VALIDATE_GENERIC (1, gf
);
2172 n
= scm_ilength (args
);
2173 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2174 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2178 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2179 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0, scm_sys_compute_applicable_methods
));
2182 lock_cache_mutex (void *m
)
2184 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2185 scm_lock_mutex (mutex
);
2189 unlock_cache_mutex (void *m
)
2191 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2192 scm_unlock_mutex (mutex
);
2196 call_memoize_method (void *a
)
2198 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2199 SCM gf
= SCM_CAR (args
);
2200 SCM x
= SCM_CADR (args
);
2201 /* First check if another thread has inserted a method between
2202 * the cache miss and locking the mutex.
2204 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2205 if (scm_is_true (cmethod
))
2208 if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x
)))
2209 var_memoize_method_x
=
2210 scm_permanent_object
2211 (scm_module_variable (scm_module_goops
, sym_memoize_method_x
));
2213 return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x
), gf
, SCM_CDDR (args
), x
);
2217 scm_memoize_method (SCM x
, SCM args
)
2219 SCM gf
= SCM_CAR (scm_last_pair (x
));
2220 return scm_internal_dynamic_wind (
2222 call_memoize_method
,
2224 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2225 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2228 /******************************************************************************
2230 * A simple make (which will be redefined later in Scheme)
2231 * This version handles only creation of gf, methods and classes (no instances)
2233 * Since this code will disappear when Goops will be fully booted,
2234 * no precaution is taken to be efficient.
2236 ******************************************************************************/
2238 SCM_KEYWORD (k_setter
, "setter");
2239 SCM_KEYWORD (k_specializers
, "specializers");
2240 SCM_KEYWORD (k_procedure
, "procedure");
2241 SCM_KEYWORD (k_formals
, "formals");
2242 SCM_KEYWORD (k_body
, "body");
2243 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2244 SCM_KEYWORD (k_dsupers
, "dsupers");
2245 SCM_KEYWORD (k_slots
, "slots");
2246 SCM_KEYWORD (k_gf
, "generic-function");
2248 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2250 "Make a new object. @var{args} must contain the class and\n"
2251 "all necessary initialization information.")
2252 #define FUNC_NAME s_scm_make
2255 long len
= scm_ilength (args
);
2257 if (len
<= 0 || (len
& 1) == 0)
2258 SCM_WRONG_NUM_ARGS ();
2260 class = SCM_CAR(args
);
2261 args
= SCM_CDR(args
);
2263 if (class == scm_class_generic
|| class == scm_class_accessor
)
2265 z
= scm_make_struct (class, SCM_INUM0
,
2266 scm_list_5 (SCM_EOL
,
2271 scm_set_procedure_property_x (z
, scm_sym_name
,
2272 scm_get_keyword (k_name
,
2275 clear_method_cache (z
);
2276 if (class == scm_class_accessor
)
2278 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2279 if (scm_is_true (setter
))
2280 scm_sys_set_object_setter_x (z
, setter
);
2285 z
= scm_sys_allocate_instance (class, args
);
2287 if (class == scm_class_method
2288 || class == scm_class_simple_method
2289 || class == scm_class_accessor_method
)
2291 SCM_SET_SLOT (z
, scm_si_generic_function
,
2292 scm_i_get_keyword (k_gf
,
2297 SCM_SET_SLOT (z
, scm_si_specializers
,
2298 scm_i_get_keyword (k_specializers
,
2303 SCM_SET_SLOT (z
, scm_si_procedure
,
2304 scm_i_get_keyword (k_procedure
,
2309 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2310 SCM_SET_SLOT (z
, scm_si_formals
,
2311 scm_i_get_keyword (k_formals
,
2316 SCM_SET_SLOT (z
, scm_si_body
,
2317 scm_i_get_keyword (k_body
,
2322 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2323 scm_i_get_keyword (k_make_procedure
,
2331 /* In all the others case, make a new class .... No instance here */
2332 SCM_SET_SLOT (z
, scm_si_name
,
2333 scm_i_get_keyword (k_name
,
2336 scm_from_locale_symbol ("???"),
2338 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2339 scm_i_get_keyword (k_dsupers
,
2344 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2345 scm_i_get_keyword (k_slots
,
2356 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2359 #define FUNC_NAME s_scm_find_method
2362 long len
= scm_ilength (l
);
2365 SCM_WRONG_NUM_ARGS ();
2367 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2368 SCM_VALIDATE_GENERIC (1, gf
);
2369 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2370 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2372 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2376 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2377 (SCM m1
, SCM m2
, SCM targs
),
2378 "Return true if method @var{m1} is more specific than @var{m2} "
2379 "given the argument types (classes) listed in @var{targs}.")
2380 #define FUNC_NAME s_scm_sys_method_more_specific_p
2384 long i
, len
, m1_specs
, m2_specs
;
2385 scm_t_array_handle handle
;
2387 SCM_VALIDATE_METHOD (1, m1
);
2388 SCM_VALIDATE_METHOD (2, m2
);
2390 len
= scm_ilength (targs
);
2391 m1_specs
= scm_ilength (SPEC_OF (m1
));
2392 m2_specs
= scm_ilength (SPEC_OF (m2
));
2393 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2394 targs
, SCM_ARG3
, FUNC_NAME
);
2396 /* Verify that all the arguments of TARGS are classes and place them
2399 v
= scm_c_make_vector (len
, SCM_EOL
);
2400 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2402 for (i
= 0, l
= targs
;
2403 i
< len
&& scm_is_pair (l
);
2404 i
++, l
= SCM_CDR (l
))
2406 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2407 v_elts
[i
] = SCM_CAR (l
);
2409 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2411 scm_array_handle_release (&handle
);
2419 /******************************************************************************
2423 ******************************************************************************/
2426 fix_cpl (SCM c
, SCM before
, SCM after
)
2428 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2429 SCM ls
= scm_c_memq (after
, cpl
);
2430 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2431 if (scm_is_false (ls
))
2432 /* if this condition occurs, fix_cpl should not be applied this way */
2434 SCM_SETCAR (ls
, before
);
2435 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2437 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2438 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2439 SCM g_n_s
= compute_getters_n_setters (slots
);
2440 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2441 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2447 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2449 SCM tmp
= scm_from_locale_symbol (name
);
2451 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2455 : scm_list_1 (super
),
2461 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2464 create_standard_classes (void)
2467 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2468 scm_from_locale_symbol ("specializers"),
2470 scm_from_locale_symbol ("code-table"),
2471 scm_from_locale_symbol ("formals"),
2472 scm_from_locale_symbol ("body"),
2473 scm_from_locale_symbol ("make-procedure"),
2475 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2477 k_slot_definition
));
2478 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2479 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2483 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2484 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2487 scm_list_3 (scm_from_locale_symbol ("used-by"),
2490 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2493 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2496 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2499 /* Foreign class slot classes */
2500 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2501 scm_class_class
, scm_class_top
, SCM_EOL
);
2502 make_stdcls (&scm_class_protected
, "<protected-slot>",
2503 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2504 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2505 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2506 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2507 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2508 make_stdcls (&scm_class_self
, "<self-slot>",
2510 scm_class_read_only
,
2512 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2514 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2516 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2518 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2520 make_stdcls (&scm_class_scm
, "<scm-slot>",
2521 scm_class_class
, scm_class_protected
, SCM_EOL
);
2522 make_stdcls (&scm_class_int
, "<int-slot>",
2523 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2524 make_stdcls (&scm_class_float
, "<float-slot>",
2525 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2526 make_stdcls (&scm_class_double
, "<double-slot>",
2527 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2529 /* Continue initialization of class <class> */
2531 slots
= build_class_class_slots ();
2532 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2533 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2534 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2535 compute_getters_n_setters (slots
));
2537 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2538 scm_class_class
, scm_class_class
,
2539 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2542 scm_list_3 (scm_from_locale_symbol ("destructor"),
2544 scm_class_opaque
)));
2545 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2546 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2547 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2549 /* scm_class_generic functions classes */
2550 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2551 scm_class_class
, scm_class_class
, SCM_EOL
);
2552 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2553 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2554 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2555 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2556 make_stdcls (&scm_class_operator_with_setter_class
,
2557 "<operator-with-setter-class>",
2558 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2559 make_stdcls (&scm_class_method
, "<method>",
2560 scm_class_class
, scm_class_object
, method_slots
);
2561 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2562 scm_class_class
, scm_class_method
, SCM_EOL
);
2563 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2564 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2565 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2566 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2567 make_stdcls (&scm_class_applicable
, "<applicable>",
2568 scm_class_class
, scm_class_top
, SCM_EOL
);
2569 make_stdcls (&scm_class_entity
, "<entity>",
2570 scm_class_entity_class
,
2571 scm_list_2 (scm_class_object
, scm_class_applicable
),
2573 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2574 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2575 make_stdcls (&scm_class_generic
, "<generic>",
2576 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2577 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2578 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2579 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2580 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2581 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2582 scm_class_entity_class
,
2583 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2585 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2586 make_stdcls (&scm_class_accessor
, "<accessor>",
2587 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2588 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2589 make_stdcls (&scm_class_extended_generic_with_setter
,
2590 "<extended-generic-with-setter>",
2591 scm_class_entity_class
,
2592 scm_list_2 (scm_class_generic_with_setter
,
2593 scm_class_extended_generic
),
2595 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2596 SCM_CLASSF_PURE_GENERIC
);
2597 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2598 scm_class_entity_class
,
2599 scm_list_2 (scm_class_accessor
,
2600 scm_class_extended_generic_with_setter
),
2602 fix_cpl (scm_class_extended_accessor
,
2603 scm_class_extended_generic
, scm_class_generic
);
2604 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2606 /* Primitive types classes */
2607 make_stdcls (&scm_class_boolean
, "<boolean>",
2608 scm_class_class
, scm_class_top
, SCM_EOL
);
2609 make_stdcls (&scm_class_char
, "<char>",
2610 scm_class_class
, scm_class_top
, SCM_EOL
);
2611 make_stdcls (&scm_class_list
, "<list>",
2612 scm_class_class
, scm_class_top
, SCM_EOL
);
2613 make_stdcls (&scm_class_pair
, "<pair>",
2614 scm_class_class
, scm_class_list
, SCM_EOL
);
2615 make_stdcls (&scm_class_null
, "<null>",
2616 scm_class_class
, scm_class_list
, SCM_EOL
);
2617 make_stdcls (&scm_class_string
, "<string>",
2618 scm_class_class
, scm_class_top
, SCM_EOL
);
2619 make_stdcls (&scm_class_symbol
, "<symbol>",
2620 scm_class_class
, scm_class_top
, SCM_EOL
);
2621 make_stdcls (&scm_class_vector
, "<vector>",
2622 scm_class_class
, scm_class_top
, SCM_EOL
);
2623 make_stdcls (&scm_class_number
, "<number>",
2624 scm_class_class
, scm_class_top
, SCM_EOL
);
2625 make_stdcls (&scm_class_complex
, "<complex>",
2626 scm_class_class
, scm_class_number
, SCM_EOL
);
2627 make_stdcls (&scm_class_real
, "<real>",
2628 scm_class_class
, scm_class_complex
, SCM_EOL
);
2629 make_stdcls (&scm_class_integer
, "<integer>",
2630 scm_class_class
, scm_class_real
, SCM_EOL
);
2631 make_stdcls (&scm_class_fraction
, "<fraction>",
2632 scm_class_class
, scm_class_real
, SCM_EOL
);
2633 make_stdcls (&scm_class_keyword
, "<keyword>",
2634 scm_class_class
, scm_class_top
, SCM_EOL
);
2635 make_stdcls (&scm_class_unknown
, "<unknown>",
2636 scm_class_class
, scm_class_top
, SCM_EOL
);
2637 make_stdcls (&scm_class_procedure
, "<procedure>",
2638 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2639 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2640 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2641 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2642 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2643 make_stdcls (&scm_class_port
, "<port>",
2644 scm_class_class
, scm_class_top
, SCM_EOL
);
2645 make_stdcls (&scm_class_input_port
, "<input-port>",
2646 scm_class_class
, scm_class_port
, SCM_EOL
);
2647 make_stdcls (&scm_class_output_port
, "<output-port>",
2648 scm_class_class
, scm_class_port
, SCM_EOL
);
2649 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2651 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2655 /**********************************************************************
2659 **********************************************************************/
2662 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2668 sprintf (buffer
, template, type_name
);
2669 name
= scm_from_locale_symbol (buffer
);
2672 name
= SCM_GOOPS_UNBOUND
;
2674 class = scm_permanent_object (scm_basic_make_class (applicablep
2675 ? scm_class_procedure_class
2681 /* Only define name if doesn't already exist. */
2682 if (!SCM_GOOPS_UNBOUNDP (name
)
2683 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2684 DEFVAR (name
, class);
2689 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2692 if (type_name_sym
!= SCM_BOOL_F
)
2694 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2695 scm_symbol_to_string (type_name_sym
),
2696 scm_from_locale_string (">")));
2697 name
= scm_string_to_symbol (name
);
2700 name
= SCM_GOOPS_UNBOUND
;
2702 class = scm_permanent_object (scm_basic_make_class (applicablep
2703 ? scm_class_procedure_class
2709 /* Only define name if doesn't already exist. */
2710 if (!SCM_GOOPS_UNBOUNDP (name
)
2711 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2712 DEFVAR (name
, class);
2717 scm_make_extended_class (char const *type_name
, int applicablep
)
2719 return make_class_from_template ("<%s>",
2721 scm_list_1 (applicablep
2722 ? scm_class_applicable
2728 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2730 return make_class_from_symbol (type_name_sym
,
2731 scm_list_1 (applicablep
2732 ? scm_class_applicable
2738 scm_i_inherit_applicable (SCM c
)
2740 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2742 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2743 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2744 /* patch scm_class_applicable into direct-supers */
2745 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2746 if (scm_is_false (top
))
2747 dsupers
= scm_append (scm_list_2 (dsupers
,
2748 scm_list_1 (scm_class_applicable
)));
2751 SCM_SETCAR (top
, scm_class_applicable
);
2752 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2754 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2755 /* patch scm_class_applicable into cpl */
2756 top
= scm_c_memq (scm_class_top
, cpl
);
2757 if (scm_is_false (top
))
2761 SCM_SETCAR (top
, scm_class_applicable
);
2762 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2764 /* add class to direct-subclasses of scm_class_applicable */
2765 SCM_SET_SLOT (scm_class_applicable
,
2766 scm_si_direct_subclasses
,
2767 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2768 scm_si_direct_subclasses
)));
2773 create_smob_classes (void)
2777 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2778 scm_smob_class
[i
] = 0;
2780 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2782 for (i
= 0; i
< scm_numsmob
; ++i
)
2783 if (!scm_smob_class
[i
])
2784 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2785 scm_smobs
[i
].apply
!= 0);
2789 scm_make_port_classes (long ptobnum
, char *type_name
)
2791 SCM c
, class = make_class_from_template ("<%s-port>",
2793 scm_list_1 (scm_class_port
),
2795 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2796 = make_class_from_template ("<%s-input-port>",
2798 scm_list_2 (class, scm_class_input_port
),
2800 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2801 = make_class_from_template ("<%s-output-port>",
2803 scm_list_2 (class, scm_class_output_port
),
2805 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2807 = make_class_from_template ("<%s-input-output-port>",
2809 scm_list_2 (class, scm_class_input_output_port
),
2811 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2812 SCM_SET_SLOT (c
, scm_si_cpl
,
2813 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2817 create_port_classes (void)
2821 for (i
= 0; i
< scm_numptob
; ++i
)
2822 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2826 make_struct_class (void *closure SCM_UNUSED
,
2827 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2829 SCM sym
= SCM_STRUCT_TABLE_NAME (data
);
2830 if (scm_is_true (sym
))
2832 int applicablep
= SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
;
2834 SCM_SET_STRUCT_TABLE_CLASS (data
,
2835 scm_make_extended_class_from_symbol (sym
, applicablep
));
2838 scm_remember_upto_here_2 (data
, vtable
);
2839 return SCM_UNSPECIFIED
;
2843 create_struct_classes (void)
2845 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2848 /**********************************************************************
2852 **********************************************************************/
2857 if (!goops_loaded_p
)
2858 scm_c_resolve_module ("oop goops");
2863 scm_make_foreign_object (SCM
class, SCM initargs
)
2864 #define FUNC_NAME s_scm_make
2866 void * (*constructor
) (SCM
)
2867 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2868 if (constructor
== 0)
2869 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2870 return scm_wrap_object (class, constructor (initargs
));
2876 scm_free_foreign_object (SCM
*class, SCM
*data
)
2878 size_t (*destructor
) (void *)
2879 = (size_t (*) (void *)) class[scm_si_destructor
];
2880 return destructor (data
);
2884 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2885 void * (*constructor
) (SCM initargs
),
2886 size_t (*destructor
) (void *))
2889 name
= scm_from_locale_symbol (s_name
);
2890 if (scm_is_null (supers
))
2891 supers
= scm_list_1 (scm_class_foreign_object
);
2892 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2893 scm_sys_inherit_magic_x (class, supers
);
2895 if (destructor
!= 0)
2897 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2898 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2902 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2905 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2906 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2911 SCM_SYMBOL (sym_o
, "o");
2912 SCM_SYMBOL (sym_x
, "x");
2914 SCM_KEYWORD (k_accessor
, "accessor");
2915 SCM_KEYWORD (k_getter
, "getter");
2918 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2920 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2925 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2926 SCM (*getter
) (SCM obj
),
2927 SCM (*setter
) (SCM obj
, SCM x
),
2928 char *accessor_name
)
2931 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2932 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2933 setter
? setter
: default_setter
);
2935 /* Dirk:FIXME:: The following two expressions make use of the fact that
2936 * the memoizer will accept a subr-object in the place of a function.
2937 * This is not guaranteed to stay this way. */
2938 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2940 scm_list_2 (get
, sym_o
)),
2942 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2943 scm_list_2 (sym_o
, sym_x
),
2944 scm_list_3 (set
, sym_o
, sym_x
)),
2948 SCM name
= scm_from_locale_symbol (slot_name
);
2949 SCM aname
= scm_from_locale_symbol (accessor_name
);
2950 SCM gf
= scm_ensure_accessor (aname
);
2951 SCM slot
= scm_list_5 (name
,
2954 setter
? k_accessor
: k_getter
,
2956 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2961 scm_add_method (scm_setter (gf
),
2962 scm_make (scm_list_5 (scm_class_accessor_method
,
2964 scm_list_2 (class, scm_class_top
),
2969 SCM_SET_SLOT (class, scm_si_slots
,
2970 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2971 scm_list_1 (slot
))));
2973 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2974 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
2976 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2977 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2978 scm_list_1 (gns
))));
2979 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2986 scm_wrap_object (SCM
class, void *data
)
2988 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2996 scm_wrap_component (SCM
class, SCM container
, void *data
)
2998 SCM obj
= scm_wrap_object (class, data
);
2999 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
3003 (scm_t_assoc_fn
) scm_sloppy_assq
,
3005 SCM_SETCDR (handle
, container
);
3010 scm_ensure_accessor (SCM name
)
3012 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
3013 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
3015 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
3016 gf
= scm_make (scm_list_5 (scm_class_accessor
,
3017 k_name
, name
, k_setter
, gf
));
3022 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
3025 scm_add_method (SCM gf
, SCM m
)
3027 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
3032 * Debugging utilities
3035 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
3037 "Return @code{#t} if @var{obj} is a pure generic.")
3038 #define FUNC_NAME s_scm_pure_generic_p
3040 return scm_from_bool (SCM_PUREGENERICP (obj
));
3044 #endif /* GUILE_DEBUG */
3050 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
3052 "Announce that GOOPS is loaded and perform initialization\n"
3053 "on the C level which depends on the loaded GOOPS modules.")
3054 #define FUNC_NAME s_scm_sys_goops_loaded
3057 var_compute_applicable_methods
=
3058 scm_permanent_object
3059 (scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
));
3061 scm_permanent_object
3062 (scm_module_variable (scm_module_goops
, sym_slot_unbound
));
3064 scm_permanent_object
3065 (scm_module_variable (scm_module_goops
, sym_slot_missing
));
3067 scm_permanent_object
3068 (scm_module_variable (scm_module_goops
, sym_compute_cpl
));
3069 var_no_applicable_method
=
3070 scm_permanent_object
3071 (scm_module_variable (scm_module_goops
, sym_no_applicable_method
));
3073 scm_permanent_object
3074 (scm_module_variable (scm_module_goops
, sym_change_class
));
3075 setup_extended_primitive_generics ();
3076 return SCM_UNSPECIFIED
;
3080 SCM scm_module_goops
;
3083 scm_init_goops_builtins (void)
3085 scm_module_goops
= scm_current_module ();
3087 /* Not really necessary right now, but who knows...
3089 scm_permanent_object (scm_module_goops
);
3091 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
3092 (scm_from_int (37)));
3094 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3096 #include "libguile/goops.x"
3098 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3100 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3101 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3103 create_basic_classes ();
3104 create_standard_classes ();
3105 create_smob_classes ();
3106 create_struct_classes ();
3107 create_port_classes ();
3110 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3111 scm_no_applicable_method
3112 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3115 DEFVAR (name
, scm_no_applicable_method
);
3118 return SCM_UNSPECIFIED
;
3124 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3125 scm_init_goops_builtins
);