1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/chars.h"
38 #include "libguile/debug.h"
39 #include "libguile/dynl.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eval.h"
42 #include "libguile/gsubr.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
57 #include "libguile/vm.h"
59 #include "libguile/validate.h"
60 #include "libguile/goops.h"
62 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
65 #define SCM_IN_PCLASS_INDEX 0
66 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
67 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
69 /* this file is a mess. in theory, though, we shouldn't have many SCM references
70 -- most of the references should be to vars. */
72 static SCM var_slot_unbound
= SCM_BOOL_F
;
73 static SCM var_slot_missing
= SCM_BOOL_F
;
74 static SCM var_compute_cpl
= SCM_BOOL_F
;
75 static SCM var_no_applicable_method
= SCM_BOOL_F
;
76 static SCM var_change_class
= SCM_BOOL_F
;
78 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
79 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
80 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
81 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
82 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
83 SCM_SYMBOL (sym_change_class
, "change-class");
85 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
88 /* FIXME, exports should come from the scm file only */
89 #define DEFVAR(v, val) \
90 { scm_module_define (scm_module_goops, (v), (val)); \
91 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
95 /* Class redefinition protocol:
97 A class is represented by a heap header h1 which points to a
98 malloc:ed memory block m1.
100 When a new version of a class is created, a new header h2 and
101 memory block m2 are allocated. The headers h1 and h2 then switch
102 pointers so that h1 refers to m2 and h2 to m1. In this way, names
103 bound to h1 will point to the new class at the same time as h2 will
104 be a handle which the GC will use to free m1.
106 The `redefined' slot of m1 will be set to point to h1. An old
107 instance will have its class pointer (the CAR of the heap header)
108 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
109 the class modification and the new class pointer can be found via
113 #define TEST_CHANGE_CLASS(obj, class) \
115 class = SCM_CLASS_OF (obj); \
116 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
118 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
119 class = SCM_CLASS_OF (obj); \
123 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
124 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
126 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
127 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
129 static int goops_loaded_p
= 0;
130 static scm_t_rstate
*goops_rstate
;
132 /* These variables are filled in by the object system when loaded. */
133 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
134 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
135 SCM scm_class_primitive_generic
;
136 SCM scm_class_vector
, scm_class_null
;
137 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
138 SCM scm_class_unknown
;
139 SCM scm_class_top
, scm_class_object
, scm_class_class
;
140 SCM scm_class_applicable
;
141 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
142 SCM scm_class_generic
, scm_class_generic_with_setter
;
143 SCM scm_class_accessor
;
144 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
145 SCM scm_class_extended_accessor
;
146 SCM scm_class_method
;
147 SCM scm_class_accessor_method
;
148 SCM scm_class_procedure_class
;
149 SCM scm_class_applicable_struct_class
;
150 SCM scm_class_number
, scm_class_list
;
151 SCM scm_class_keyword
;
152 SCM scm_class_port
, scm_class_input_output_port
;
153 SCM scm_class_input_port
, scm_class_output_port
;
154 SCM scm_class_foreign_slot
;
155 SCM scm_class_self
, scm_class_protected
;
156 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
157 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
159 SCM scm_class_int
, scm_class_float
, scm_class_double
;
161 static SCM class_foreign
;
162 static SCM class_hashtable
;
163 static SCM class_fluid
;
164 static SCM class_dynamic_state
;
165 static SCM class_frame
;
166 static SCM class_objcode
;
168 static SCM class_vm_cont
;
169 static SCM class_bytevector
;
170 static SCM class_uvec
;
172 /* Port classes. Allocate 3 times the maximum number of port types so that
173 input ports, output ports, and in/out ports can be stored at different
174 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
175 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
178 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
180 SCM scm_no_applicable_method
;
182 SCM_SYMBOL (scm_sym_define_public
, "define-public");
184 static SCM
scm_make_unbound (void);
185 static SCM
scm_unbound_p (SCM obj
);
186 static SCM
scm_assert_bound (SCM value
, SCM obj
);
187 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
188 static SCM
scm_sys_goops_loaded (void);
189 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
192 /* This function is used for efficient type dispatch. */
193 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
195 "Return the class of @var{x}.")
196 #define FUNC_NAME s_scm_class_of
198 switch (SCM_ITAG3 (x
))
202 return scm_class_integer
;
206 return scm_class_char
;
207 else if (scm_is_bool (x
))
208 return scm_class_boolean
;
209 else if (scm_is_null (x
))
210 return scm_class_null
;
212 return scm_class_unknown
;
215 switch (SCM_TYP7 (x
))
217 case scm_tcs_cons_nimcar
:
218 return scm_class_pair
;
220 return scm_class_symbol
;
223 return scm_class_vector
;
224 case scm_tc7_pointer
:
225 return class_foreign
;
226 case scm_tc7_hashtable
:
227 return class_hashtable
;
230 case scm_tc7_dynamic_state
:
231 return class_dynamic_state
;
234 case scm_tc7_objcode
:
235 return class_objcode
;
238 case scm_tc7_vm_cont
:
239 return class_vm_cont
;
240 case scm_tc7_bytevector
:
241 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
242 return class_bytevector
;
246 return scm_class_string
;
248 switch SCM_TYP16 (x
) {
250 return scm_class_integer
;
252 return scm_class_real
;
253 case scm_tc16_complex
:
254 return scm_class_complex
;
255 case scm_tc16_fraction
:
256 return scm_class_fraction
;
258 case scm_tc7_program
:
259 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
260 return scm_class_primitive_generic
;
262 return scm_class_procedure
;
266 scm_t_bits type
= SCM_TYP16 (x
);
267 if (type
!= scm_tc16_port_with_ps
)
268 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
269 x
= SCM_PORT_WITH_PS_PORT (x
);
270 /* fall through to ports */
273 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
274 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
275 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
276 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
277 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
279 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
280 return SCM_CLASS_OF (x
);
281 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
284 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
285 scm_change_object_class (x
,
286 SCM_CLASS_OF (x
), /* old */
287 SCM_OBJ_CLASS_REDEF (x
)); /* new */
288 return SCM_CLASS_OF (x
);
292 /* ordinary struct */
293 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
294 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
295 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
300 name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
301 if (!scm_is_symbol (name
))
302 name
= scm_string_to_symbol (scm_nullstr
);
305 scm_make_extended_class_from_symbol (name
,
306 SCM_STRUCT_APPLICABLE_P (x
));
307 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
313 return scm_class_pair
;
315 return scm_class_unknown
;
321 /* case scm_tc3_unused: */
325 return scm_class_unknown
;
329 /******************************************************************************
333 * This version doesn't fully handle multiple-inheritance. It serves
334 * only for booting classes and will be overloaded in Scheme
336 ******************************************************************************/
339 map (SCM (*proc
) (SCM
), SCM ls
)
341 if (scm_is_null (ls
))
345 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
348 while (!scm_is_null (ls
))
350 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
362 while (!scm_is_null (ls
))
364 SCM el
= SCM_CAR (ls
);
365 if (scm_is_false (scm_c_memq (el
, res
)))
366 res
= scm_cons (el
, res
);
373 compute_cpl (SCM
class)
376 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
379 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
380 SCM ls
= scm_append (scm_acons (class, supers
,
381 map (compute_cpl
, supers
)));
382 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
386 /******************************************************************************
390 ******************************************************************************/
393 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
401 if (!scm_is_symbol (tmp
))
402 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
404 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
405 res
= scm_cons (SCM_CAR (l
), res
);
406 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
409 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
413 build_slots_list (SCM dslots
, SCM cpl
)
415 register SCM res
= dslots
;
417 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
418 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
419 scm_si_direct_slots
),
422 /* res contains a list of slots. Remove slots which appears more than once */
423 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
430 while (!scm_is_null (ls
))
432 if (!scm_is_pair (SCM_CAR (ls
)))
433 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
440 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
442 "Return a list consisting of the names of all slots belonging to\n"
443 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
445 #define FUNC_NAME s_scm_sys_compute_slots
447 SCM_VALIDATE_CLASS (1, class);
448 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
449 SCM_SLOT (class, scm_si_cpl
));
454 /******************************************************************************
456 * compute-getters-n-setters
458 * This version doesn't handle slot options. It serves only for booting
459 * classes and will be overloaded in Scheme.
461 ******************************************************************************/
463 SCM_KEYWORD (k_init_value
, "init-value");
464 SCM_KEYWORD (k_init_thunk
, "init-thunk");
467 compute_getters_n_setters (SCM slots
)
473 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
475 SCM init
= SCM_BOOL_F
;
476 SCM options
= SCM_CDAR (slots
);
477 if (!scm_is_null (options
))
479 init
= scm_get_keyword (k_init_value
, options
, 0);
482 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
484 scm_list_2 (scm_sym_quote
,
488 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
490 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
492 scm_from_int (i
++))),
494 cdrloc
= SCM_CDRLOC (*cdrloc
);
499 /******************************************************************************
503 ******************************************************************************/
505 /*fixme* Manufacture keywords in advance */
507 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
511 for (i
= 0; i
!= len
; i
+= 2)
513 SCM obj
= SCM_CAR (l
);
515 if (!scm_is_keyword (obj
))
516 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
517 else if (scm_is_eq (obj
, key
))
523 return default_value
;
527 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
528 (SCM key
, SCM l
, SCM default_value
),
529 "Determine an associated value for the keyword @var{key} from\n"
530 "the list @var{l}. The list @var{l} has to consist of an even\n"
531 "number of elements, where, starting with the first, every\n"
532 "second element is a keyword, followed by its associated value.\n"
533 "If @var{l} does not hold a value for @var{key}, the value\n"
534 "@var{default_value} is returned.")
535 #define FUNC_NAME s_scm_get_keyword
539 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
540 len
= scm_ilength (l
);
541 if (len
< 0 || len
% 2 == 1)
542 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
544 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
549 SCM_KEYWORD (k_init_keyword
, "init-keyword");
551 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
552 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
554 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
555 (SCM obj
, SCM initargs
),
556 "Initialize the object @var{obj} with the given arguments\n"
558 #define FUNC_NAME s_scm_sys_initialize_object
560 SCM tmp
, get_n_set
, slots
;
561 SCM
class = SCM_CLASS_OF (obj
);
564 SCM_VALIDATE_INSTANCE (1, obj
);
565 n_initargs
= scm_ilength (initargs
);
566 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
568 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
569 slots
= SCM_SLOT (class, scm_si_slots
);
571 /* See for each slot how it must be initialized */
573 !scm_is_null (slots
);
574 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
576 SCM slot_name
= SCM_CAR (slots
);
579 if (!scm_is_null (SCM_CDR (slot_name
)))
581 /* This slot admits (perhaps) to be initialized at creation time */
582 long n
= scm_ilength (SCM_CDR (slot_name
));
583 if (n
& 1) /* odd or -1 */
584 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
585 scm_list_1 (slot_name
));
586 tmp
= scm_i_get_keyword (k_init_keyword
,
591 slot_name
= SCM_CAR (slot_name
);
594 /* an initarg was provided for this slot */
595 if (!scm_is_keyword (tmp
))
596 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
598 slot_value
= scm_i_get_keyword (tmp
,
607 /* set slot to provided value */
608 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
611 /* set slot to its :init-form if it exists */
612 tmp
= SCM_CADAR (get_n_set
);
613 if (scm_is_true (tmp
))
615 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
616 if (SCM_GOOPS_UNBOUNDP (slot_value
))
617 set_slot_value (class,
629 /* NOTE: The following macros are interdependent with code
630 * in goops.scm:compute-getters-n-setters
632 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
633 (SCM_I_INUMP (SCM_CDDR (gns)) \
634 || (scm_is_pair (SCM_CDDR (gns)) \
635 && scm_is_pair (SCM_CDDDR (gns)) \
636 && scm_is_pair (SCM_CDDDDR (gns))))
637 #define SCM_GNS_INDEX(gns) \
638 (SCM_I_INUMP (SCM_CDDR (gns)) \
639 ? SCM_I_INUM (SCM_CDDR (gns)) \
640 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
641 #define SCM_GNS_SIZE(gns) \
642 (SCM_I_INUMP (SCM_CDDR (gns)) \
644 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
646 SCM_KEYWORD (k_class
, "class");
647 SCM_KEYWORD (k_allocation
, "allocation");
648 SCM_KEYWORD (k_instance
, "instance");
650 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
653 #define FUNC_NAME s_scm_sys_prep_layout_x
655 SCM slots
, getters_n_setters
, nfields
;
656 unsigned long int n
, i
;
660 SCM_VALIDATE_INSTANCE (1, class);
661 slots
= SCM_SLOT (class, scm_si_slots
);
662 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
663 nfields
= SCM_SLOT (class, scm_si_nfields
);
664 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
665 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
666 scm_list_1 (nfields
));
667 n
= 2 * SCM_I_INUM (nfields
);
668 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
669 && SCM_SUBCLASSP (class, scm_class_class
))
670 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
671 scm_list_1 (nfields
));
673 layout
= scm_i_make_string (n
, &s
);
675 while (scm_is_pair (getters_n_setters
))
677 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
680 int len
, index
, size
;
683 if (i
>= n
|| !scm_is_pair (slots
))
686 /* extract slot type */
687 len
= scm_ilength (SCM_CDAR (slots
));
688 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
689 len
, SCM_BOOL_F
, FUNC_NAME
);
690 /* determine slot GC protection and access mode */
691 if (scm_is_false (type
))
698 if (!SCM_CLASSP (type
))
699 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
700 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
702 if (SCM_SUBCLASSP (type
, scm_class_self
))
704 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
709 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
711 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
713 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
725 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
726 if (index
!= (i
>> 1))
728 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
736 slots
= SCM_CDR (slots
);
737 getters_n_setters
= SCM_CDR (getters_n_setters
);
739 if (!scm_is_null (slots
))
742 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
744 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
745 return SCM_UNSPECIFIED
;
749 static void prep_hashsets (SCM
);
751 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
752 (SCM
class, SCM dsupers
),
754 #define FUNC_NAME s_scm_sys_inherit_magic_x
756 SCM_VALIDATE_INSTANCE (1, class);
757 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
758 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
760 prep_hashsets (class);
762 return SCM_UNSPECIFIED
;
767 prep_hashsets (SCM
class)
771 for (i
= 0; i
< 8; ++i
)
772 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
775 /******************************************************************************/
778 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
780 SCM z
, cpl
, slots
, nfields
, g_n_s
;
782 /* Allocate one instance */
783 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
785 /* Initialize its slots */
786 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
787 cpl
= compute_cpl (z
);
788 slots
= build_slots_list (maplist (dslots
), cpl
);
789 nfields
= scm_from_int (scm_ilength (slots
));
790 g_n_s
= compute_getters_n_setters (slots
);
792 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
793 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
794 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
795 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
796 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
797 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
798 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
799 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
800 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
802 /* Add this class in the direct-subclasses slot of dsupers */
805 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
806 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
807 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
808 scm_si_direct_subclasses
)));
815 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
817 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
818 scm_sys_prep_layout_x (z
);
819 scm_sys_inherit_magic_x (z
, dsupers
);
823 /******************************************************************************/
825 SCM_SYMBOL (sym_layout
, "layout");
826 SCM_SYMBOL (sym_flags
, "flags");
827 SCM_SYMBOL (sym_self
, "%self");
828 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
829 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
830 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
831 SCM_SYMBOL (sym_print
, "print");
832 SCM_SYMBOL (sym_procedure
, "procedure");
833 SCM_SYMBOL (sym_setter
, "setter");
834 SCM_SYMBOL (sym_redefined
, "redefined");
835 SCM_SYMBOL (sym_h0
, "h0");
836 SCM_SYMBOL (sym_h1
, "h1");
837 SCM_SYMBOL (sym_h2
, "h2");
838 SCM_SYMBOL (sym_h3
, "h3");
839 SCM_SYMBOL (sym_h4
, "h4");
840 SCM_SYMBOL (sym_h5
, "h5");
841 SCM_SYMBOL (sym_h6
, "h6");
842 SCM_SYMBOL (sym_h7
, "h7");
843 SCM_SYMBOL (sym_name
, "name");
844 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
845 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
846 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
847 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
848 SCM_SYMBOL (sym_cpl
, "cpl");
849 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
850 SCM_SYMBOL (sym_slots
, "slots");
851 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
852 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
853 SCM_SYMBOL (sym_nfields
, "nfields");
857 build_class_class_slots ()
859 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
860 SCM_CLASS_CLASS_LAYOUT */
862 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
863 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
864 scm_list_3 (sym_self
, k_class
, scm_class_self
),
865 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
866 scm_list_1 (sym_print
),
867 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
868 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
869 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
870 scm_list_1 (sym_redefined
),
871 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
872 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
873 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
874 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
875 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
876 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
877 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
878 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
879 scm_list_1 (sym_direct_supers
),
880 scm_list_1 (sym_direct_slots
),
881 scm_list_1 (sym_direct_subclasses
),
882 scm_list_1 (sym_direct_methods
),
883 scm_list_1 (sym_cpl
),
884 scm_list_1 (sym_default_slot_definition_class
),
885 scm_list_1 (sym_slots
),
886 scm_list_1 (sym_getters_n_setters
),
887 scm_list_1 (sym_keyword_access
),
888 scm_list_1 (sym_nfields
),
893 create_basic_classes (void)
895 /* SCM slots_of_class = build_class_class_slots (); */
898 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
899 SCM name
= scm_from_latin1_symbol ("<class>");
900 scm_class_class
= scm_make_vtable_vtable (cs
, SCM_INUM0
, SCM_EOL
);
901 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
902 | SCM_CLASSF_METACLASS
));
904 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
905 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
906 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
907 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
908 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
909 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
910 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
911 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
912 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
913 compute_getters_n_setters (slots_of_class)); */
914 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
916 prep_hashsets (scm_class_class
);
918 DEFVAR(name
, scm_class_class
);
921 name
= scm_from_latin1_symbol ("<top>");
922 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
925 DEFVAR(name
, scm_class_top
);
928 name
= scm_from_latin1_symbol ("<object>");
929 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
930 scm_list_1 (scm_class_top
), SCM_EOL
);
932 DEFVAR (name
, scm_class_object
);
934 /* <top> <object> and <class> were partially initialized. Correct them here */
935 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
937 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
938 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
941 /******************************************************************************/
943 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
945 "Return @code{#t} if @var{obj} is an instance.")
946 #define FUNC_NAME s_scm_instance_p
948 return scm_from_bool (SCM_INSTANCEP (obj
));
953 /******************************************************************************
955 * Meta object accessors
957 ******************************************************************************/
958 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
960 "Return the class name of @var{obj}.")
961 #define FUNC_NAME s_scm_class_name
963 SCM_VALIDATE_CLASS (1, obj
);
964 return scm_slot_ref (obj
, sym_name
);
968 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
970 "Return the direct superclasses of the class @var{obj}.")
971 #define FUNC_NAME s_scm_class_direct_supers
973 SCM_VALIDATE_CLASS (1, obj
);
974 return scm_slot_ref (obj
, sym_direct_supers
);
978 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
980 "Return the direct slots of the class @var{obj}.")
981 #define FUNC_NAME s_scm_class_direct_slots
983 SCM_VALIDATE_CLASS (1, obj
);
984 return scm_slot_ref (obj
, sym_direct_slots
);
988 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
990 "Return the direct subclasses of the class @var{obj}.")
991 #define FUNC_NAME s_scm_class_direct_subclasses
993 SCM_VALIDATE_CLASS (1, obj
);
994 return scm_slot_ref(obj
, sym_direct_subclasses
);
998 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1000 "Return the direct methods of the class @var{obj}")
1001 #define FUNC_NAME s_scm_class_direct_methods
1003 SCM_VALIDATE_CLASS (1, obj
);
1004 return scm_slot_ref (obj
, sym_direct_methods
);
1008 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1010 "Return the class precedence list of the class @var{obj}.")
1011 #define FUNC_NAME s_scm_class_precedence_list
1013 SCM_VALIDATE_CLASS (1, obj
);
1014 return scm_slot_ref (obj
, sym_cpl
);
1018 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1020 "Return the slot list of the class @var{obj}.")
1021 #define FUNC_NAME s_scm_class_slots
1023 SCM_VALIDATE_CLASS (1, obj
);
1024 return scm_slot_ref (obj
, sym_slots
);
1028 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1030 "Return the name of the generic function @var{obj}.")
1031 #define FUNC_NAME s_scm_generic_function_name
1033 SCM_VALIDATE_GENERIC (1, obj
);
1034 return scm_procedure_property (obj
, scm_sym_name
);
1038 SCM_SYMBOL (sym_methods
, "methods");
1039 SCM_SYMBOL (sym_extended_by
, "extended-by");
1040 SCM_SYMBOL (sym_extends
, "extends");
1043 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1045 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1046 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1047 while (!scm_is_null (gfs
))
1049 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1050 gfs
= SCM_CDR (gfs
);
1052 return method_lists
;
1056 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1058 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1060 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1061 while (!scm_is_null (gfs
))
1063 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1064 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1067 gfs
= SCM_CDR (gfs
);
1070 return method_lists
;
1073 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1075 "Return the methods of the generic function @var{obj}.")
1076 #define FUNC_NAME s_scm_generic_function_methods
1079 SCM_VALIDATE_GENERIC (1, obj
);
1080 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1081 methods
= fold_downward_gf_methods (methods
, obj
);
1082 return scm_append (methods
);
1086 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1088 "Return the generic function for the method @var{obj}.")
1089 #define FUNC_NAME s_scm_method_generic_function
1091 SCM_VALIDATE_METHOD (1, obj
);
1092 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1096 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1098 "Return specializers of the method @var{obj}.")
1099 #define FUNC_NAME s_scm_method_specializers
1101 SCM_VALIDATE_METHOD (1, obj
);
1102 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1106 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1108 "Return the procedure of the method @var{obj}.")
1109 #define FUNC_NAME s_scm_method_procedure
1111 SCM_VALIDATE_METHOD (1, obj
);
1112 return scm_slot_ref (obj
, sym_procedure
);
1116 /******************************************************************************
1118 * S l o t a c c e s s
1120 ******************************************************************************/
1122 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1124 "Return the unbound value.")
1125 #define FUNC_NAME s_scm_make_unbound
1127 return SCM_GOOPS_UNBOUND
;
1131 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1133 "Return @code{#t} if @var{obj} is unbound.")
1134 #define FUNC_NAME s_scm_unbound_p
1136 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1140 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1141 (SCM value
, SCM obj
),
1142 "Return @var{value} if it is bound, and invoke the\n"
1143 "@var{slot-unbound} method of @var{obj} if it is not.")
1144 #define FUNC_NAME s_scm_assert_bound
1146 if (SCM_GOOPS_UNBOUNDP (value
))
1147 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1152 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1153 (SCM obj
, SCM index
),
1154 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1155 "the value from @var{obj}.")
1156 #define FUNC_NAME s_scm_at_assert_bound_ref
1158 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1159 if (SCM_GOOPS_UNBOUNDP (value
))
1160 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1165 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1166 (SCM obj
, SCM index
),
1167 "Return the slot value with index @var{index} from @var{obj}.")
1168 #define FUNC_NAME s_scm_sys_fast_slot_ref
1172 SCM_VALIDATE_INSTANCE (1, obj
);
1173 i
= scm_to_unsigned_integer (index
, 0,
1174 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1177 return SCM_SLOT (obj
, i
);
1181 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1182 (SCM obj
, SCM index
, SCM value
),
1183 "Set the slot with index @var{index} in @var{obj} to\n"
1185 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1189 SCM_VALIDATE_INSTANCE (1, obj
);
1190 i
= scm_to_unsigned_integer (index
, 0,
1191 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1195 SCM_SET_SLOT (obj
, i
, value
);
1197 return SCM_UNSPECIFIED
;
1205 /* In the future, this function will return the effective slot
1206 * definition associated with SLOT_NAME. Now it just returns some of
1207 * the information which will be stored in the effective slot
1212 slot_definition_using_name (SCM
class, SCM slot_name
)
1214 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1215 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1216 if (SCM_CAAR (slots
) == slot_name
)
1217 return SCM_CAR (slots
);
1222 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1223 #define FUNC_NAME "%get-slot-value"
1225 SCM access
= SCM_CDDR (slotdef
);
1227 * - access is an integer (the offset of this slot in the slots vector)
1228 * - otherwise (car access) is the getter function to apply
1230 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1231 * we can just assume fixnums here.
1233 if (SCM_I_INUMP (access
))
1234 /* Don't poke at the slots directly, because scm_struct_ref handles the
1235 access bits for us. */
1236 return scm_struct_ref (obj
, access
);
1238 return scm_call_1 (SCM_CAR (access
), obj
);
1243 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1245 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1246 if (scm_is_true (slotdef
))
1247 return get_slot_value (class, obj
, slotdef
);
1249 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1253 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1254 #define FUNC_NAME "%set-slot-value"
1256 SCM access
= SCM_CDDR (slotdef
);
1258 * - access is an integer (the offset of this slot in the slots vector)
1259 * - otherwise (cadr access) is the setter function to apply
1261 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1262 * we can just assume fixnums here.
1264 if (SCM_I_INUMP (access
))
1265 /* obey permissions bits via going through struct-set! */
1266 scm_struct_set_x (obj
, access
, value
);
1268 /* ((cadr l) obj value) */
1269 scm_call_2 (SCM_CADR (access
), obj
, value
);
1270 return SCM_UNSPECIFIED
;
1275 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1277 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1278 if (scm_is_true (slotdef
))
1279 return set_slot_value (class, obj
, slotdef
, value
);
1281 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1285 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1289 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1290 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1296 /* ======================================== */
1298 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1299 (SCM
class, SCM obj
, SCM slot_name
),
1301 #define FUNC_NAME s_scm_slot_ref_using_class
1305 SCM_VALIDATE_CLASS (1, class);
1306 SCM_VALIDATE_INSTANCE (2, obj
);
1307 SCM_VALIDATE_SYMBOL (3, slot_name
);
1309 res
= get_slot_value_using_name (class, obj
, slot_name
);
1310 if (SCM_GOOPS_UNBOUNDP (res
))
1311 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1317 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1318 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1320 #define FUNC_NAME s_scm_slot_set_using_class_x
1322 SCM_VALIDATE_CLASS (1, class);
1323 SCM_VALIDATE_INSTANCE (2, obj
);
1324 SCM_VALIDATE_SYMBOL (3, slot_name
);
1326 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1331 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1332 (SCM
class, SCM obj
, SCM slot_name
),
1334 #define FUNC_NAME s_scm_slot_bound_using_class_p
1336 SCM_VALIDATE_CLASS (1, class);
1337 SCM_VALIDATE_INSTANCE (2, obj
);
1338 SCM_VALIDATE_SYMBOL (3, slot_name
);
1340 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1346 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1347 (SCM
class, SCM obj
, SCM slot_name
),
1349 #define FUNC_NAME s_scm_slot_exists_using_class_p
1351 SCM_VALIDATE_CLASS (1, class);
1352 SCM_VALIDATE_INSTANCE (2, obj
);
1353 SCM_VALIDATE_SYMBOL (3, slot_name
);
1354 return test_slot_existence (class, obj
, slot_name
);
1359 /* ======================================== */
1361 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1362 (SCM obj
, SCM slot_name
),
1363 "Return the value from @var{obj}'s slot with the name\n"
1365 #define FUNC_NAME s_scm_slot_ref
1369 SCM_VALIDATE_INSTANCE (1, obj
);
1370 TEST_CHANGE_CLASS (obj
, class);
1372 res
= get_slot_value_using_name (class, obj
, slot_name
);
1373 if (SCM_GOOPS_UNBOUNDP (res
))
1374 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1379 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1380 (SCM obj
, SCM slot_name
, SCM value
),
1381 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1382 #define FUNC_NAME s_scm_slot_set_x
1386 SCM_VALIDATE_INSTANCE (1, obj
);
1387 TEST_CHANGE_CLASS(obj
, class);
1389 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1393 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1395 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1396 (SCM obj
, SCM slot_name
),
1397 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1399 #define FUNC_NAME s_scm_slot_bound_p
1403 SCM_VALIDATE_INSTANCE (1, obj
);
1404 TEST_CHANGE_CLASS(obj
, class);
1406 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1414 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1415 (SCM obj
, SCM slot_name
),
1416 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1417 #define FUNC_NAME s_scm_slot_exists_p
1421 SCM_VALIDATE_INSTANCE (1, obj
);
1422 SCM_VALIDATE_SYMBOL (2, slot_name
);
1423 TEST_CHANGE_CLASS (obj
, class);
1425 return test_slot_existence (class, obj
, slot_name
);
1430 /******************************************************************************
1432 * %allocate-instance (the low level instance allocation primitive)
1434 ******************************************************************************/
1436 static void clear_method_cache (SCM
);
1438 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1439 (SCM
class, SCM initargs
),
1440 "Create a new instance of class @var{class} and initialize it\n"
1441 "from the arguments @var{initargs}.")
1442 #define FUNC_NAME s_scm_sys_allocate_instance
1445 scm_t_signed_bits n
, i
;
1448 SCM_VALIDATE_CLASS (1, class);
1450 /* FIXME: duplicates some of scm_make_struct. */
1452 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1453 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1455 layout
= SCM_VTABLE_LAYOUT (class);
1457 /* Set all SCM-holding slots to unbound */
1458 for (i
= 0; i
< n
; i
++)
1460 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1462 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1464 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1466 SCM_STRUCT_DATA (obj
)[i
] = 0;
1469 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1470 clear_method_cache (obj
);
1476 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1477 (SCM obj
, SCM setter
),
1479 #define FUNC_NAME s_scm_sys_set_object_setter_x
1481 SCM_ASSERT (SCM_STRUCTP (obj
)
1482 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1486 SCM_SET_GENERIC_SETTER (obj
, setter
);
1487 return SCM_UNSPECIFIED
;
1491 /******************************************************************************
1493 * %modify-instance (used by change-class to modify in place)
1495 ******************************************************************************/
1497 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1500 #define FUNC_NAME s_scm_sys_modify_instance
1502 SCM_VALIDATE_INSTANCE (1, old
);
1503 SCM_VALIDATE_INSTANCE (2, new);
1505 /* Exchange the data contained in old and new. We exchange rather than
1506 * scratch the old value with new to be correct with GC.
1507 * See "Class redefinition protocol above".
1509 SCM_CRITICAL_SECTION_START
;
1511 scm_t_bits word0
, word1
;
1512 word0
= SCM_CELL_WORD_0 (old
);
1513 word1
= SCM_CELL_WORD_1 (old
);
1514 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1515 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1516 SCM_SET_CELL_WORD_0 (new, word0
);
1517 SCM_SET_CELL_WORD_1 (new, word1
);
1519 SCM_CRITICAL_SECTION_END
;
1520 return SCM_UNSPECIFIED
;
1524 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1527 #define FUNC_NAME s_scm_sys_modify_class
1529 SCM_VALIDATE_CLASS (1, old
);
1530 SCM_VALIDATE_CLASS (2, new);
1532 SCM_CRITICAL_SECTION_START
;
1534 scm_t_bits word0
, word1
;
1535 word0
= SCM_CELL_WORD_0 (old
);
1536 word1
= SCM_CELL_WORD_1 (old
);
1537 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1538 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1539 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1540 SCM_SET_CELL_WORD_0 (new, word0
);
1541 SCM_SET_CELL_WORD_1 (new, word1
);
1542 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1544 SCM_CRITICAL_SECTION_END
;
1545 return SCM_UNSPECIFIED
;
1549 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1552 #define FUNC_NAME s_scm_sys_invalidate_class
1554 SCM_VALIDATE_CLASS (1, class);
1555 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1556 return SCM_UNSPECIFIED
;
1560 /* When instances change class, they finally get a new body, but
1561 * before that, they go through purgatory in hell. Odd as it may
1562 * seem, this data structure saves us from eternal suffering in
1563 * infinite recursions.
1566 static scm_t_bits
**hell
;
1567 static long n_hell
= 1; /* one place for the evil one himself */
1568 static long hell_size
= 4;
1569 static SCM hell_mutex
;
1575 for (i
= 1; i
< n_hell
; ++i
)
1576 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1582 go_to_hell (void *o
)
1584 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1585 scm_lock_mutex (hell_mutex
);
1586 if (n_hell
>= hell_size
)
1589 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1591 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1592 scm_unlock_mutex (hell_mutex
);
1596 go_to_heaven (void *o
)
1598 scm_lock_mutex (hell_mutex
);
1599 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1600 scm_unlock_mutex (hell_mutex
);
1604 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1607 purgatory (void *args
)
1609 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1610 SCM_PACK ((scm_t_bits
) args
));
1613 /* This function calls the generic function change-class for all
1614 * instances which aren't currently undergoing class change.
1618 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1621 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1622 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1623 (void *) SCM_UNPACK (obj
));
1626 /******************************************************************************
1632 * GGG E N E R I C F U N C T I O N S
1634 * This implementation provides
1635 * - generic functions (with class specializers)
1638 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1640 ******************************************************************************/
1642 SCM_KEYWORD (k_name
, "name");
1644 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1648 scm_apply_generic (SCM gf
, SCM args
)
1650 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1654 scm_call_generic_0 (SCM gf
)
1656 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1660 scm_call_generic_1 (SCM gf
, SCM a1
)
1662 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1666 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1668 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1672 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1674 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1677 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1679 make_dispatch_procedure (SCM gf
)
1681 static SCM var
= SCM_BOOL_F
;
1682 if (var
== SCM_BOOL_F
)
1683 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1684 sym_delayed_compile
);
1685 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1689 clear_method_cache (SCM gf
)
1691 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1692 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1695 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1698 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1700 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1701 clear_method_cache (gf
);
1702 return SCM_UNSPECIFIED
;
1706 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1709 #define FUNC_NAME s_scm_generic_capability_p
1711 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1712 proc
, SCM_ARG1
, FUNC_NAME
);
1713 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1717 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1720 #define FUNC_NAME s_scm_enable_primitive_generic_x
1722 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1723 while (!scm_is_null (subrs
))
1725 SCM subr
= SCM_CAR (subrs
);
1726 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1727 SCM_SET_SUBR_GENERIC (subr
,
1728 scm_make (scm_list_3 (scm_class_generic
,
1730 SCM_SUBR_NAME (subr
))));
1731 subrs
= SCM_CDR (subrs
);
1733 return SCM_UNSPECIFIED
;
1737 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1738 (SCM subr
, SCM generic
),
1740 #define FUNC_NAME s_scm_set_primitive_generic_x
1742 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1743 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1744 SCM_SET_SUBR_GENERIC (subr
, generic
);
1745 return SCM_UNSPECIFIED
;
1749 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1752 #define FUNC_NAME s_scm_primitive_generic_generic
1754 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1756 if (!*SCM_SUBR_GENERIC (subr
))
1757 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1758 return *SCM_SUBR_GENERIC (subr
);
1760 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1764 typedef struct t_extension
{
1765 struct t_extension
*next
;
1771 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1773 static const char extension_gc_hint
[] = "GOOPS extension";
1775 static t_extension
*extensions
= 0;
1778 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1783 if (!*SCM_SUBR_GENERIC (extended
))
1784 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1785 gf
= *SCM_SUBR_GENERIC (extended
);
1786 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1788 SCM_SUBR_NAME (extension
));
1789 SCM_SET_SUBR_GENERIC (extension
, gext
);
1793 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1795 t_extension
**loc
= &extensions
;
1796 /* Make sure that extensions are placed before their own
1797 * extensions in the extensions list. O(N^2) algorithm, but
1798 * extensions of primitive generics are rare.
1800 while (*loc
&& extension
!= (*loc
)->extended
)
1801 loc
= &(*loc
)->next
;
1803 e
->extended
= extended
;
1804 e
->extension
= extension
;
1810 setup_extended_primitive_generics ()
1814 t_extension
*e
= extensions
;
1815 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1816 extensions
= e
->next
;
1820 /******************************************************************************
1822 * Protocol for calling a generic fumction
1823 * This protocol is roughly equivalent to (parameter are a little bit different
1824 * for efficiency reasons):
1826 * + apply-generic (gf args)
1827 * + compute-applicable-methods (gf args ...)
1828 * + sort-applicable-methods (methods args)
1829 * + apply-methods (gf methods args)
1831 * apply-methods calls make-next-method to build the "continuation" of a a
1832 * method. Applying a next-method will call apply-next-method which in
1833 * turn will call apply again to call effectively the following method.
1835 ******************************************************************************/
1838 applicablep (SCM actual
, SCM formal
)
1840 /* We already know that the cpl is well formed. */
1841 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1845 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1847 register SCM s1
, s2
;
1851 * m1 and m2 can have != length (i.e. one can be one element longer than the
1852 * other when we have a dotted parameter list). For instance, with the call
1855 * (define-method M (a . l) ....)
1856 * (define-method M (a) ....)
1858 * we consider that the second method is more specific.
1860 * BTW, targs is an array of types. We don't need it's size since
1861 * we already know that m1 and m2 are applicable (no risk to go past
1862 * the end of this array).
1865 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1866 if (scm_is_null(s1
)) return 1;
1867 if (scm_is_null(s2
)) return 0;
1868 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1869 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1871 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1872 if (cs1
== SCM_CAR(l
))
1874 if (cs2
== SCM_CAR(l
))
1877 return 0;/* should not occur! */
1880 return 0; /* should not occur! */
1883 #define BUFFSIZE 32 /* big enough for most uses */
1886 scm_i_vector2list (SCM l
, long len
)
1889 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1891 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1892 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1898 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1901 SCM
*v
, vector
= SCM_EOL
;
1902 SCM buffer
[BUFFSIZE
];
1903 SCM save
= method_list
;
1904 scm_t_array_handle handle
;
1906 /* For reasonably sized method_lists we can try to avoid all the
1907 * consing and reorder the list in place...
1908 * This idea is due to David McClain <Dave_McClain@msn.com>
1910 if (size
<= BUFFSIZE
)
1912 for (i
= 0; i
< size
; i
++)
1914 buffer
[i
] = SCM_CAR (method_list
);
1915 method_list
= SCM_CDR (method_list
);
1921 /* Too many elements in method_list to keep everything locally */
1922 vector
= scm_i_vector2list (save
, size
);
1923 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
1926 /* Use a simple shell sort since it is generally faster than qsort on
1927 * small vectors (which is probably mostly the case when we have to
1928 * sort a list of applicable methods).
1930 for (incr
= size
/ 2; incr
; incr
/= 2)
1932 for (i
= incr
; i
< size
; i
++)
1934 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1936 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1940 SCM tmp
= v
[j
+ incr
];
1948 if (size
<= BUFFSIZE
)
1950 /* We did it in locally, so restore the original list (reordered) in-place */
1951 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1953 SCM_SETCAR (method_list
, *v
);
1954 method_list
= SCM_CDR (method_list
);
1959 /* If we are here, that's that we did it the hard way... */
1960 scm_array_handle_release (&handle
);
1961 return scm_vector_to_list (vector
);
1965 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1969 SCM l
, fl
, applicable
= SCM_EOL
;
1971 SCM buffer
[BUFFSIZE
];
1975 scm_t_array_handle handle
;
1977 /* Build the list of arguments types */
1978 if (len
>= BUFFSIZE
)
1980 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1981 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
1984 note that we don't have to work to reset the generation
1985 count. TMP is a new vector anyway, and it is found
1992 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
1993 *p
++ = scm_class_of (SCM_CAR (args
));
1995 /* Build a list of all applicable methods */
1996 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
1998 fl
= SPEC_OF (SCM_CAR (l
));
1999 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2001 if (SCM_INSTANCEP (fl
)
2002 /* We have a dotted argument list */
2003 || (i
>= len
&& scm_is_null (fl
)))
2004 { /* both list exhausted */
2005 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2011 || !applicablep (types
[i
], SCM_CAR (fl
)))
2016 if (len
>= BUFFSIZE
)
2017 scm_array_handle_release (&handle
);
2023 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2024 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2030 : sort_applicable_methods (applicable
, count
, types
));
2034 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2037 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2040 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2041 #define FUNC_NAME s_sys_compute_applicable_methods
2044 SCM_VALIDATE_GENERIC (1, gf
);
2045 n
= scm_ilength (args
);
2046 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2047 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2051 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2052 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2053 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2054 scm_sys_compute_applicable_methods
));
2056 /******************************************************************************
2058 * A simple make (which will be redefined later in Scheme)
2059 * This version handles only creation of gf, methods and classes (no instances)
2061 * Since this code will disappear when Goops will be fully booted,
2062 * no precaution is taken to be efficient.
2064 ******************************************************************************/
2066 SCM_KEYWORD (k_setter
, "setter");
2067 SCM_KEYWORD (k_specializers
, "specializers");
2068 SCM_KEYWORD (k_procedure
, "procedure");
2069 SCM_KEYWORD (k_formals
, "formals");
2070 SCM_KEYWORD (k_body
, "body");
2071 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2072 SCM_KEYWORD (k_dsupers
, "dsupers");
2073 SCM_KEYWORD (k_slots
, "slots");
2074 SCM_KEYWORD (k_gf
, "generic-function");
2076 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2078 "Make a new object. @var{args} must contain the class and\n"
2079 "all necessary initialization information.")
2080 #define FUNC_NAME s_scm_make
2083 long len
= scm_ilength (args
);
2085 if (len
<= 0 || (len
& 1) == 0)
2086 SCM_WRONG_NUM_ARGS ();
2088 class = SCM_CAR(args
);
2089 args
= SCM_CDR(args
);
2091 if (class == scm_class_generic
|| class == scm_class_accessor
)
2093 z
= scm_make_struct (class, SCM_INUM0
,
2094 scm_list_4 (SCM_BOOL_F
,
2098 scm_set_procedure_property_x (z
, scm_sym_name
,
2099 scm_get_keyword (k_name
,
2102 clear_method_cache (z
);
2103 if (class == scm_class_accessor
)
2105 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2106 if (scm_is_true (setter
))
2107 scm_sys_set_object_setter_x (z
, setter
);
2112 z
= scm_sys_allocate_instance (class, args
);
2114 if (class == scm_class_method
2115 || class == scm_class_accessor_method
)
2117 SCM_SET_SLOT (z
, scm_si_generic_function
,
2118 scm_i_get_keyword (k_gf
,
2123 SCM_SET_SLOT (z
, scm_si_specializers
,
2124 scm_i_get_keyword (k_specializers
,
2129 SCM_SET_SLOT (z
, scm_si_procedure
,
2130 scm_i_get_keyword (k_procedure
,
2135 SCM_SET_SLOT (z
, scm_si_formals
,
2136 scm_i_get_keyword (k_formals
,
2141 SCM_SET_SLOT (z
, scm_si_body
,
2142 scm_i_get_keyword (k_body
,
2147 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2148 scm_i_get_keyword (k_make_procedure
,
2156 /* In all the others case, make a new class .... No instance here */
2157 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2158 scm_i_get_keyword (k_name
,
2161 scm_from_latin1_symbol ("???"),
2163 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2164 scm_i_get_keyword (k_dsupers
,
2169 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2170 scm_i_get_keyword (k_slots
,
2181 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2184 #define FUNC_NAME s_scm_find_method
2187 long len
= scm_ilength (l
);
2190 SCM_WRONG_NUM_ARGS ();
2192 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2193 SCM_VALIDATE_GENERIC (1, gf
);
2194 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2195 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2197 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2201 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2202 (SCM m1
, SCM m2
, SCM targs
),
2203 "Return true if method @var{m1} is more specific than @var{m2} "
2204 "given the argument types (classes) listed in @var{targs}.")
2205 #define FUNC_NAME s_scm_sys_method_more_specific_p
2209 long i
, len
, m1_specs
, m2_specs
;
2210 scm_t_array_handle handle
;
2212 SCM_VALIDATE_METHOD (1, m1
);
2213 SCM_VALIDATE_METHOD (2, m2
);
2215 len
= scm_ilength (targs
);
2216 m1_specs
= scm_ilength (SPEC_OF (m1
));
2217 m2_specs
= scm_ilength (SPEC_OF (m2
));
2218 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2219 targs
, SCM_ARG3
, FUNC_NAME
);
2221 /* Verify that all the arguments of TARGS are classes and place them
2224 v
= scm_c_make_vector (len
, SCM_EOL
);
2225 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2227 for (i
= 0, l
= targs
;
2228 i
< len
&& scm_is_pair (l
);
2229 i
++, l
= SCM_CDR (l
))
2231 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2232 v_elts
[i
] = SCM_CAR (l
);
2234 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2236 scm_array_handle_release (&handle
);
2244 /******************************************************************************
2248 ******************************************************************************/
2251 fix_cpl (SCM c
, SCM before
, SCM after
)
2253 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2254 SCM ls
= scm_c_memq (after
, cpl
);
2255 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2256 if (scm_is_false (ls
))
2257 /* if this condition occurs, fix_cpl should not be applied this way */
2259 SCM_SETCAR (ls
, before
);
2260 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2262 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2263 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2264 SCM g_n_s
= compute_getters_n_setters (slots
);
2265 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2266 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2272 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2274 SCM tmp
= scm_from_locale_symbol (name
);
2276 *var
= scm_basic_make_class (meta
, tmp
,
2277 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2283 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2286 create_standard_classes (void)
2289 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2290 scm_from_latin1_symbol ("specializers"),
2292 scm_from_latin1_symbol ("formals"),
2293 scm_from_latin1_symbol ("body"),
2294 scm_from_latin1_symbol ("make-procedure"),
2296 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2298 k_slot_definition
));
2299 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2300 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2303 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2306 scm_from_latin1_symbol ("effective-methods"));
2307 SCM setter_slots
= scm_list_1 (sym_setter
);
2308 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2311 /* Foreign class slot classes */
2312 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2313 scm_class_class
, scm_class_top
, SCM_EOL
);
2314 make_stdcls (&scm_class_protected
, "<protected-slot>",
2315 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2316 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2317 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2318 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2319 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2320 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2321 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2322 make_stdcls (&scm_class_self
, "<self-slot>",
2323 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2324 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2326 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2328 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2330 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2332 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2334 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2336 make_stdcls (&scm_class_scm
, "<scm-slot>",
2337 scm_class_class
, scm_class_protected
, SCM_EOL
);
2338 make_stdcls (&scm_class_int
, "<int-slot>",
2339 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2340 make_stdcls (&scm_class_float
, "<float-slot>",
2341 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2342 make_stdcls (&scm_class_double
, "<double-slot>",
2343 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2345 /* Continue initialization of class <class> */
2347 slots
= build_class_class_slots ();
2348 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2349 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2350 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2351 compute_getters_n_setters (slots
));
2353 /* scm_class_generic functions classes */
2354 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2355 scm_class_class
, scm_class_class
, SCM_EOL
);
2356 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2357 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2358 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2359 make_stdcls (&scm_class_method
, "<method>",
2360 scm_class_class
, scm_class_object
, method_slots
);
2361 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2362 scm_class_class
, scm_class_method
, amethod_slots
);
2363 make_stdcls (&scm_class_applicable
, "<applicable>",
2364 scm_class_class
, scm_class_top
, SCM_EOL
);
2365 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2366 scm_class_applicable_struct_class
,
2367 scm_list_2 (scm_class_object
, scm_class_applicable
),
2368 scm_list_1 (sym_procedure
));
2369 make_stdcls (&scm_class_generic
, "<generic>",
2370 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2371 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2372 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2373 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2374 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2375 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2376 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2377 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2378 make_stdcls (&scm_class_accessor
, "<accessor>",
2379 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2380 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2381 make_stdcls (&scm_class_extended_generic_with_setter
,
2382 "<extended-generic-with-setter>",
2383 scm_class_applicable_struct_class
,
2384 scm_list_2 (scm_class_generic_with_setter
,
2385 scm_class_extended_generic
),
2387 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2388 SCM_CLASSF_PURE_GENERIC
);
2389 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2390 scm_class_applicable_struct_class
,
2391 scm_list_2 (scm_class_accessor
,
2392 scm_class_extended_generic_with_setter
),
2394 fix_cpl (scm_class_extended_accessor
,
2395 scm_class_extended_generic
, scm_class_generic
);
2396 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2398 /* Primitive types classes */
2399 make_stdcls (&scm_class_boolean
, "<boolean>",
2400 scm_class_class
, scm_class_top
, SCM_EOL
);
2401 make_stdcls (&scm_class_char
, "<char>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_list
, "<list>",
2404 scm_class_class
, scm_class_top
, SCM_EOL
);
2405 make_stdcls (&scm_class_pair
, "<pair>",
2406 scm_class_class
, scm_class_list
, SCM_EOL
);
2407 make_stdcls (&scm_class_null
, "<null>",
2408 scm_class_class
, scm_class_list
, SCM_EOL
);
2409 make_stdcls (&scm_class_string
, "<string>",
2410 scm_class_class
, scm_class_top
, SCM_EOL
);
2411 make_stdcls (&scm_class_symbol
, "<symbol>",
2412 scm_class_class
, scm_class_top
, SCM_EOL
);
2413 make_stdcls (&scm_class_vector
, "<vector>",
2414 scm_class_class
, scm_class_top
, SCM_EOL
);
2415 make_stdcls (&class_foreign
, "<foreign>",
2416 scm_class_class
, scm_class_top
, SCM_EOL
);
2417 make_stdcls (&class_hashtable
, "<hashtable>",
2418 scm_class_class
, scm_class_top
, SCM_EOL
);
2419 make_stdcls (&class_fluid
, "<fluid>",
2420 scm_class_class
, scm_class_top
, SCM_EOL
);
2421 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2422 scm_class_class
, scm_class_top
, SCM_EOL
);
2423 make_stdcls (&class_frame
, "<frame>",
2424 scm_class_class
, scm_class_top
, SCM_EOL
);
2425 make_stdcls (&class_objcode
, "<objcode>",
2426 scm_class_class
, scm_class_top
, SCM_EOL
);
2427 make_stdcls (&class_vm
, "<vm>",
2428 scm_class_class
, scm_class_top
, SCM_EOL
);
2429 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2430 scm_class_class
, scm_class_top
, SCM_EOL
);
2431 make_stdcls (&class_bytevector
, "<bytevector>",
2432 scm_class_class
, scm_class_top
, SCM_EOL
);
2433 make_stdcls (&class_uvec
, "<uvec>",
2434 scm_class_class
, class_bytevector
, SCM_EOL
);
2435 make_stdcls (&scm_class_number
, "<number>",
2436 scm_class_class
, scm_class_top
, SCM_EOL
);
2437 make_stdcls (&scm_class_complex
, "<complex>",
2438 scm_class_class
, scm_class_number
, SCM_EOL
);
2439 make_stdcls (&scm_class_real
, "<real>",
2440 scm_class_class
, scm_class_complex
, SCM_EOL
);
2441 make_stdcls (&scm_class_integer
, "<integer>",
2442 scm_class_class
, scm_class_real
, SCM_EOL
);
2443 make_stdcls (&scm_class_fraction
, "<fraction>",
2444 scm_class_class
, scm_class_real
, SCM_EOL
);
2445 make_stdcls (&scm_class_keyword
, "<keyword>",
2446 scm_class_class
, scm_class_top
, SCM_EOL
);
2447 make_stdcls (&scm_class_unknown
, "<unknown>",
2448 scm_class_class
, scm_class_top
, SCM_EOL
);
2449 make_stdcls (&scm_class_procedure
, "<procedure>",
2450 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2451 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2452 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2453 make_stdcls (&scm_class_port
, "<port>",
2454 scm_class_class
, scm_class_top
, SCM_EOL
);
2455 make_stdcls (&scm_class_input_port
, "<input-port>",
2456 scm_class_class
, scm_class_port
, SCM_EOL
);
2457 make_stdcls (&scm_class_output_port
, "<output-port>",
2458 scm_class_class
, scm_class_port
, SCM_EOL
);
2459 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2461 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2465 /**********************************************************************
2469 **********************************************************************/
2472 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2478 sprintf (buffer
, template, type_name
);
2479 name
= scm_from_locale_symbol (buffer
);
2482 name
= SCM_GOOPS_UNBOUND
;
2484 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2485 name
, supers
, SCM_EOL
);
2487 /* Only define name if doesn't already exist. */
2488 if (!SCM_GOOPS_UNBOUNDP (name
)
2489 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2490 DEFVAR (name
, class);
2495 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2498 if (type_name_sym
!= SCM_BOOL_F
)
2500 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2501 scm_symbol_to_string (type_name_sym
),
2502 scm_from_locale_string (">")));
2503 name
= scm_string_to_symbol (name
);
2506 name
= SCM_GOOPS_UNBOUND
;
2508 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2509 name
, supers
, SCM_EOL
);
2511 /* Only define name if doesn't already exist. */
2512 if (!SCM_GOOPS_UNBOUNDP (name
)
2513 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2514 DEFVAR (name
, class);
2519 scm_make_extended_class (char const *type_name
, int applicablep
)
2521 return make_class_from_template ("<%s>",
2523 scm_list_1 (applicablep
2524 ? scm_class_applicable
2530 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2532 return make_class_from_symbol (type_name_sym
,
2533 scm_list_1 (applicablep
2534 ? scm_class_applicable
2540 scm_i_inherit_applicable (SCM c
)
2542 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2544 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2545 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2546 /* patch scm_class_applicable into direct-supers */
2547 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2548 if (scm_is_false (top
))
2549 dsupers
= scm_append (scm_list_2 (dsupers
,
2550 scm_list_1 (scm_class_applicable
)));
2553 SCM_SETCAR (top
, scm_class_applicable
);
2554 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2556 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2557 /* patch scm_class_applicable into cpl */
2558 top
= scm_c_memq (scm_class_top
, cpl
);
2559 if (scm_is_false (top
))
2563 SCM_SETCAR (top
, scm_class_applicable
);
2564 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2566 /* add class to direct-subclasses of scm_class_applicable */
2567 SCM_SET_SLOT (scm_class_applicable
,
2568 scm_si_direct_subclasses
,
2569 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2570 scm_si_direct_subclasses
)));
2575 create_smob_classes (void)
2579 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2580 scm_smob_class
[i
] = 0;
2582 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2584 for (i
= 0; i
< scm_numsmob
; ++i
)
2585 if (!scm_smob_class
[i
])
2586 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2587 scm_smobs
[i
].apply
!= 0);
2591 scm_make_port_classes (long ptobnum
, char *type_name
)
2593 SCM c
, class = make_class_from_template ("<%s-port>",
2595 scm_list_1 (scm_class_port
),
2597 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2598 = make_class_from_template ("<%s-input-port>",
2600 scm_list_2 (class, scm_class_input_port
),
2602 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2603 = make_class_from_template ("<%s-output-port>",
2605 scm_list_2 (class, scm_class_output_port
),
2607 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2609 = make_class_from_template ("<%s-input-output-port>",
2611 scm_list_2 (class, scm_class_input_output_port
),
2613 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2614 SCM_SET_SLOT (c
, scm_si_cpl
,
2615 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2619 create_port_classes (void)
2623 for (i
= 0; i
< scm_numptob
; ++i
)
2624 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2628 make_struct_class (void *closure SCM_UNUSED
,
2629 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2631 SCM sym
= SCM_STRUCT_TABLE_NAME (data
);
2632 if (scm_is_true (sym
))
2634 int applicablep
= SCM_CLASS_FLAGS (vtable
) & SCM_VTABLE_FLAG_APPLICABLE
;
2636 SCM_SET_STRUCT_TABLE_CLASS (data
,
2637 scm_make_extended_class_from_symbol (sym
, applicablep
));
2640 scm_remember_upto_here_2 (data
, vtable
);
2641 return SCM_UNSPECIFIED
;
2645 create_struct_classes (void)
2647 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2650 /**********************************************************************
2654 **********************************************************************/
2659 if (!goops_loaded_p
)
2660 scm_c_resolve_module ("oop goops");
2664 SCM_SYMBOL (sym_o
, "o");
2665 SCM_SYMBOL (sym_x
, "x");
2667 SCM_KEYWORD (k_accessor
, "accessor");
2668 SCM_KEYWORD (k_getter
, "getter");
2671 scm_ensure_accessor (SCM name
)
2673 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2674 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2676 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2677 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2678 k_name
, name
, k_setter
, gf
));
2685 * Debugging utilities
2688 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2690 "Return @code{#t} if @var{obj} is a pure generic.")
2691 #define FUNC_NAME s_scm_pure_generic_p
2693 return scm_from_bool (SCM_PUREGENERICP (obj
));
2697 #endif /* GUILE_DEBUG */
2703 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2705 "Announce that GOOPS is loaded and perform initialization\n"
2706 "on the C level which depends on the loaded GOOPS modules.")
2707 #define FUNC_NAME s_scm_sys_goops_loaded
2710 var_compute_applicable_methods
=
2711 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2713 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2715 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2717 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2718 var_no_applicable_method
=
2719 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2721 scm_module_variable (scm_module_goops
, sym_change_class
);
2722 setup_extended_primitive_generics ();
2723 return SCM_UNSPECIFIED
;
2727 SCM scm_module_goops
;
2730 scm_init_goops_builtins (void)
2732 scm_module_goops
= scm_current_module ();
2734 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2736 #include "libguile/goops.x"
2738 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2739 hell_mutex
= scm_make_mutex ();
2741 create_basic_classes ();
2742 create_standard_classes ();
2743 create_smob_classes ();
2744 create_struct_classes ();
2745 create_port_classes ();
2748 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2749 scm_no_applicable_method
=
2750 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2751 DEFVAR (name
, scm_no_applicable_method
);
2754 return SCM_UNSPECIFIED
;
2760 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2761 scm_init_goops_builtins
);