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/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_procedure_with_setter
, 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 /* Port classes. Allocate 3 times the maximum number of port types so that
162 input ports, output ports, and in/out ports can be stored at different
163 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
164 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
167 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
169 SCM scm_no_applicable_method
;
171 SCM_SYMBOL (scm_sym_define_public
, "define-public");
173 static SCM
scm_make_unbound (void);
174 static SCM
scm_unbound_p (SCM obj
);
175 static SCM
scm_assert_bound (SCM value
, SCM obj
);
176 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
177 static SCM
scm_sys_goops_loaded (void);
178 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
181 /* This function is used for efficient type dispatch. */
182 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
184 "Return the class of @var{x}.")
185 #define FUNC_NAME s_scm_class_of
187 switch (SCM_ITAG3 (x
))
191 return scm_class_integer
;
195 return scm_class_char
;
196 else if (scm_is_bool (x
))
197 return scm_class_boolean
;
198 else if (scm_is_null (x
))
199 return scm_class_null
;
201 return scm_class_unknown
;
204 switch (SCM_TYP7 (x
))
206 case scm_tcs_cons_nimcar
:
207 return scm_class_pair
;
209 return scm_class_symbol
;
212 return scm_class_vector
;
214 return scm_class_string
;
216 switch SCM_TYP16 (x
) {
218 return scm_class_integer
;
220 return scm_class_real
;
221 case scm_tc16_complex
:
222 return scm_class_complex
;
223 case scm_tc16_fraction
:
224 return scm_class_fraction
;
227 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
228 return scm_class_primitive_generic
;
230 return scm_class_procedure
;
231 case scm_tc7_program
:
232 return scm_class_procedure
;
234 return scm_class_procedure_with_setter
;
238 scm_t_bits type
= SCM_TYP16 (x
);
239 if (type
!= scm_tc16_port_with_ps
)
240 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
241 x
= SCM_PORT_WITH_PS_PORT (x
);
242 /* fall through to ports */
245 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
246 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
247 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
248 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
249 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
251 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
252 return SCM_CLASS_OF (x
);
253 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
256 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
257 scm_change_object_class (x
,
258 SCM_CLASS_OF (x
), /* old */
259 SCM_OBJ_CLASS_REDEF (x
)); /* new */
260 return SCM_CLASS_OF (x
);
264 /* ordinary struct */
265 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
266 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
267 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
272 name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
273 if (!scm_is_symbol (name
))
274 name
= scm_string_to_symbol (scm_nullstr
);
277 scm_make_extended_class_from_symbol (name
,
278 SCM_STRUCT_APPLICABLE_P (x
));
279 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
285 return scm_class_pair
;
287 return scm_class_unknown
;
293 /* case scm_tc3_unused: */
297 return scm_class_unknown
;
301 /******************************************************************************
305 * This version doesn't fully handle multiple-inheritance. It serves
306 * only for booting classes and will be overloaded in Scheme
308 ******************************************************************************/
311 map (SCM (*proc
) (SCM
), SCM ls
)
313 if (scm_is_null (ls
))
317 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
320 while (!scm_is_null (ls
))
322 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
334 while (!scm_is_null (ls
))
336 SCM el
= SCM_CAR (ls
);
337 if (scm_is_false (scm_c_memq (el
, res
)))
338 res
= scm_cons (el
, res
);
345 compute_cpl (SCM
class)
348 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
351 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
352 SCM ls
= scm_append (scm_acons (class, supers
,
353 map (compute_cpl
, supers
)));
354 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
358 /******************************************************************************
362 ******************************************************************************/
365 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
373 if (!scm_is_symbol (tmp
))
374 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
376 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
377 res
= scm_cons (SCM_CAR (l
), res
);
378 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
381 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
385 build_slots_list (SCM dslots
, SCM cpl
)
387 register SCM res
= dslots
;
389 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
390 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
391 scm_si_direct_slots
),
394 /* res contains a list of slots. Remove slots which appears more than once */
395 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
402 while (!scm_is_null (ls
))
404 if (!scm_is_pair (SCM_CAR (ls
)))
405 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
412 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
414 "Return a list consisting of the names of all slots belonging to\n"
415 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
417 #define FUNC_NAME s_scm_sys_compute_slots
419 SCM_VALIDATE_CLASS (1, class);
420 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
421 SCM_SLOT (class, scm_si_cpl
));
426 /******************************************************************************
428 * compute-getters-n-setters
430 * This version doesn't handle slot options. It serves only for booting
431 * classes and will be overloaded in Scheme.
433 ******************************************************************************/
435 SCM_KEYWORD (k_init_value
, "init-value");
436 SCM_KEYWORD (k_init_thunk
, "init-thunk");
439 compute_getters_n_setters (SCM slots
)
445 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
447 SCM init
= SCM_BOOL_F
;
448 SCM options
= SCM_CDAR (slots
);
449 if (!scm_is_null (options
))
451 init
= scm_get_keyword (k_init_value
, options
, 0);
454 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
456 scm_list_2 (scm_sym_quote
,
460 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
462 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
464 scm_from_int (i
++))),
466 cdrloc
= SCM_CDRLOC (*cdrloc
);
471 /******************************************************************************
475 ******************************************************************************/
477 /*fixme* Manufacture keywords in advance */
479 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
483 for (i
= 0; i
!= len
; i
+= 2)
485 SCM obj
= SCM_CAR (l
);
487 if (!scm_is_keyword (obj
))
488 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
489 else if (scm_is_eq (obj
, key
))
495 return default_value
;
499 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
500 (SCM key
, SCM l
, SCM default_value
),
501 "Determine an associated value for the keyword @var{key} from\n"
502 "the list @var{l}. The list @var{l} has to consist of an even\n"
503 "number of elements, where, starting with the first, every\n"
504 "second element is a keyword, followed by its associated value.\n"
505 "If @var{l} does not hold a value for @var{key}, the value\n"
506 "@var{default_value} is returned.")
507 #define FUNC_NAME s_scm_get_keyword
511 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
512 len
= scm_ilength (l
);
513 if (len
< 0 || len
% 2 == 1)
514 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
516 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
521 SCM_KEYWORD (k_init_keyword
, "init-keyword");
523 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
524 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
526 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
527 (SCM obj
, SCM initargs
),
528 "Initialize the object @var{obj} with the given arguments\n"
530 #define FUNC_NAME s_scm_sys_initialize_object
532 SCM tmp
, get_n_set
, slots
;
533 SCM
class = SCM_CLASS_OF (obj
);
536 SCM_VALIDATE_INSTANCE (1, obj
);
537 n_initargs
= scm_ilength (initargs
);
538 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
540 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
541 slots
= SCM_SLOT (class, scm_si_slots
);
543 /* See for each slot how it must be initialized */
545 !scm_is_null (slots
);
546 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
548 SCM slot_name
= SCM_CAR (slots
);
551 if (!scm_is_null (SCM_CDR (slot_name
)))
553 /* This slot admits (perhaps) to be initialized at creation time */
554 long n
= scm_ilength (SCM_CDR (slot_name
));
555 if (n
& 1) /* odd or -1 */
556 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
557 scm_list_1 (slot_name
));
558 tmp
= scm_i_get_keyword (k_init_keyword
,
563 slot_name
= SCM_CAR (slot_name
);
566 /* an initarg was provided for this slot */
567 if (!scm_is_keyword (tmp
))
568 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
570 slot_value
= scm_i_get_keyword (tmp
,
579 /* set slot to provided value */
580 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
583 /* set slot to its :init-form if it exists */
584 tmp
= SCM_CADAR (get_n_set
);
585 if (scm_is_true (tmp
))
587 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
588 if (SCM_GOOPS_UNBOUNDP (slot_value
))
589 set_slot_value (class,
601 /* NOTE: The following macros are interdependent with code
602 * in goops.scm:compute-getters-n-setters
604 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
605 (SCM_I_INUMP (SCM_CDDR (gns)) \
606 || (scm_is_pair (SCM_CDDR (gns)) \
607 && scm_is_pair (SCM_CDDDR (gns)) \
608 && scm_is_pair (SCM_CDDDDR (gns))))
609 #define SCM_GNS_INDEX(gns) \
610 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 ? SCM_I_INUM (SCM_CDDR (gns)) \
612 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
613 #define SCM_GNS_SIZE(gns) \
614 (SCM_I_INUMP (SCM_CDDR (gns)) \
616 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
618 SCM_KEYWORD (k_class
, "class");
619 SCM_KEYWORD (k_allocation
, "allocation");
620 SCM_KEYWORD (k_instance
, "instance");
622 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
625 #define FUNC_NAME s_scm_sys_prep_layout_x
627 SCM slots
, getters_n_setters
, nfields
;
628 unsigned long int n
, i
;
632 SCM_VALIDATE_INSTANCE (1, class);
633 slots
= SCM_SLOT (class, scm_si_slots
);
634 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
635 nfields
= SCM_SLOT (class, scm_si_nfields
);
636 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
637 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
638 scm_list_1 (nfields
));
639 n
= 2 * SCM_I_INUM (nfields
);
640 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
641 && SCM_SUBCLASSP (class, scm_class_class
))
642 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
643 scm_list_1 (nfields
));
645 layout
= scm_i_make_string (n
, &s
);
647 while (scm_is_pair (getters_n_setters
))
649 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
652 int len
, index
, size
;
655 if (i
>= n
|| !scm_is_pair (slots
))
658 /* extract slot type */
659 len
= scm_ilength (SCM_CDAR (slots
));
660 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
661 len
, SCM_BOOL_F
, FUNC_NAME
);
662 /* determine slot GC protection and access mode */
663 if (scm_is_false (type
))
670 if (!SCM_CLASSP (type
))
671 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
672 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
674 if (SCM_SUBCLASSP (type
, scm_class_self
))
676 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
681 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
683 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
685 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
697 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
698 if (index
!= (i
>> 1))
700 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
708 slots
= SCM_CDR (slots
);
709 getters_n_setters
= SCM_CDR (getters_n_setters
);
711 if (!scm_is_null (slots
))
714 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
716 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
717 return SCM_UNSPECIFIED
;
721 static void prep_hashsets (SCM
);
723 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
724 (SCM
class, SCM dsupers
),
726 #define FUNC_NAME s_scm_sys_inherit_magic_x
728 SCM_VALIDATE_INSTANCE (1, class);
729 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
730 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
732 prep_hashsets (class);
734 return SCM_UNSPECIFIED
;
739 prep_hashsets (SCM
class)
743 for (i
= 0; i
< 8; ++i
)
744 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
747 /******************************************************************************/
750 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
752 SCM z
, cpl
, slots
, nfields
, g_n_s
;
754 /* Allocate one instance */
755 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
757 /* Initialize its slots */
758 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
759 cpl
= compute_cpl (z
);
760 slots
= build_slots_list (maplist (dslots
), cpl
);
761 nfields
= scm_from_int (scm_ilength (slots
));
762 g_n_s
= compute_getters_n_setters (slots
);
764 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
765 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
766 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
767 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
768 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
769 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
770 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
771 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
772 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
774 /* Add this class in the direct-subclasses slot of dsupers */
777 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
778 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
779 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
780 scm_si_direct_subclasses
)));
787 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
789 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
790 scm_sys_prep_layout_x (z
);
791 scm_sys_inherit_magic_x (z
, dsupers
);
795 /******************************************************************************/
797 SCM_SYMBOL (sym_layout
, "layout");
798 SCM_SYMBOL (sym_flags
, "flags");
799 SCM_SYMBOL (sym_self
, "%self");
800 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
801 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
802 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
803 SCM_SYMBOL (sym_print
, "print");
804 SCM_SYMBOL (sym_procedure
, "procedure");
805 SCM_SYMBOL (sym_setter
, "setter");
806 SCM_SYMBOL (sym_redefined
, "redefined");
807 SCM_SYMBOL (sym_h0
, "h0");
808 SCM_SYMBOL (sym_h1
, "h1");
809 SCM_SYMBOL (sym_h2
, "h2");
810 SCM_SYMBOL (sym_h3
, "h3");
811 SCM_SYMBOL (sym_h4
, "h4");
812 SCM_SYMBOL (sym_h5
, "h5");
813 SCM_SYMBOL (sym_h6
, "h6");
814 SCM_SYMBOL (sym_h7
, "h7");
815 SCM_SYMBOL (sym_name
, "name");
816 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
817 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
818 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
819 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
820 SCM_SYMBOL (sym_cpl
, "cpl");
821 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
822 SCM_SYMBOL (sym_slots
, "slots");
823 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
824 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
825 SCM_SYMBOL (sym_nfields
, "nfields");
829 build_class_class_slots ()
831 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
832 SCM_CLASS_CLASS_LAYOUT */
834 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
835 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
836 scm_list_3 (sym_self
, k_class
, scm_class_self
),
837 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
838 scm_list_1 (sym_print
),
839 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
840 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
841 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
842 scm_list_1 (sym_redefined
),
843 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
844 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
845 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
846 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
847 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
848 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
849 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
850 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
851 scm_list_1 (sym_direct_supers
),
852 scm_list_1 (sym_direct_slots
),
853 scm_list_1 (sym_direct_subclasses
),
854 scm_list_1 (sym_direct_methods
),
855 scm_list_1 (sym_cpl
),
856 scm_list_1 (sym_default_slot_definition_class
),
857 scm_list_1 (sym_slots
),
858 scm_list_1 (sym_getters_n_setters
),
859 scm_list_1 (sym_keyword_access
),
860 scm_list_1 (sym_nfields
),
865 create_basic_classes (void)
867 /* SCM slots_of_class = build_class_class_slots (); */
870 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
871 SCM name
= scm_from_locale_symbol ("<class>");
872 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
875 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
876 | SCM_CLASSF_METACLASS
));
878 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
879 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
880 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
881 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
882 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
883 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
884 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
885 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
886 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
887 compute_getters_n_setters (slots_of_class)); */
888 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
890 prep_hashsets (scm_class_class
);
892 DEFVAR(name
, scm_class_class
);
895 name
= scm_from_locale_symbol ("<top>");
896 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
901 DEFVAR(name
, scm_class_top
);
904 name
= scm_from_locale_symbol ("<object>");
905 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
907 scm_list_1 (scm_class_top
),
910 DEFVAR (name
, scm_class_object
);
912 /* <top> <object> and <class> were partially initialized. Correct them here */
913 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
915 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
916 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
919 /******************************************************************************/
921 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
923 "Return @code{#t} if @var{obj} is an instance.")
924 #define FUNC_NAME s_scm_instance_p
926 return scm_from_bool (SCM_INSTANCEP (obj
));
931 /******************************************************************************
933 * Meta object accessors
935 ******************************************************************************/
936 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
938 "Return the class name of @var{obj}.")
939 #define FUNC_NAME s_scm_class_name
941 SCM_VALIDATE_CLASS (1, obj
);
942 return scm_slot_ref (obj
, sym_name
);
946 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
948 "Return the direct superclasses of the class @var{obj}.")
949 #define FUNC_NAME s_scm_class_direct_supers
951 SCM_VALIDATE_CLASS (1, obj
);
952 return scm_slot_ref (obj
, sym_direct_supers
);
956 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
958 "Return the direct slots of the class @var{obj}.")
959 #define FUNC_NAME s_scm_class_direct_slots
961 SCM_VALIDATE_CLASS (1, obj
);
962 return scm_slot_ref (obj
, sym_direct_slots
);
966 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
968 "Return the direct subclasses of the class @var{obj}.")
969 #define FUNC_NAME s_scm_class_direct_subclasses
971 SCM_VALIDATE_CLASS (1, obj
);
972 return scm_slot_ref(obj
, sym_direct_subclasses
);
976 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
978 "Return the direct methods of the class @var{obj}")
979 #define FUNC_NAME s_scm_class_direct_methods
981 SCM_VALIDATE_CLASS (1, obj
);
982 return scm_slot_ref (obj
, sym_direct_methods
);
986 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
988 "Return the class precedence list of the class @var{obj}.")
989 #define FUNC_NAME s_scm_class_precedence_list
991 SCM_VALIDATE_CLASS (1, obj
);
992 return scm_slot_ref (obj
, sym_cpl
);
996 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
998 "Return the slot list of the class @var{obj}.")
999 #define FUNC_NAME s_scm_class_slots
1001 SCM_VALIDATE_CLASS (1, obj
);
1002 return scm_slot_ref (obj
, sym_slots
);
1006 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1008 "Return the name of the generic function @var{obj}.")
1009 #define FUNC_NAME s_scm_generic_function_name
1011 SCM_VALIDATE_GENERIC (1, obj
);
1012 return scm_procedure_property (obj
, scm_sym_name
);
1016 SCM_SYMBOL (sym_methods
, "methods");
1017 SCM_SYMBOL (sym_extended_by
, "extended-by");
1018 SCM_SYMBOL (sym_extends
, "extends");
1021 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1023 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1024 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1025 while (!scm_is_null (gfs
))
1027 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1028 gfs
= SCM_CDR (gfs
);
1030 return method_lists
;
1034 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1036 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1038 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1039 while (!scm_is_null (gfs
))
1041 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1042 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1045 gfs
= SCM_CDR (gfs
);
1048 return method_lists
;
1051 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1053 "Return the methods of the generic function @var{obj}.")
1054 #define FUNC_NAME s_scm_generic_function_methods
1057 SCM_VALIDATE_GENERIC (1, obj
);
1058 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1059 methods
= fold_downward_gf_methods (methods
, obj
);
1060 return scm_append (methods
);
1064 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1066 "Return the generic function for the method @var{obj}.")
1067 #define FUNC_NAME s_scm_method_generic_function
1069 SCM_VALIDATE_METHOD (1, obj
);
1070 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1074 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1076 "Return specializers of the method @var{obj}.")
1077 #define FUNC_NAME s_scm_method_specializers
1079 SCM_VALIDATE_METHOD (1, obj
);
1080 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1084 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1086 "Return the procedure of the method @var{obj}.")
1087 #define FUNC_NAME s_scm_method_procedure
1089 SCM_VALIDATE_METHOD (1, obj
);
1090 return scm_slot_ref (obj
, sym_procedure
);
1094 /******************************************************************************
1096 * S l o t a c c e s s
1098 ******************************************************************************/
1100 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1102 "Return the unbound value.")
1103 #define FUNC_NAME s_scm_make_unbound
1105 return SCM_GOOPS_UNBOUND
;
1109 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1111 "Return @code{#t} if @var{obj} is unbound.")
1112 #define FUNC_NAME s_scm_unbound_p
1114 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1118 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1119 (SCM value
, SCM obj
),
1120 "Return @var{value} if it is bound, and invoke the\n"
1121 "@var{slot-unbound} method of @var{obj} if it is not.")
1122 #define FUNC_NAME s_scm_assert_bound
1124 if (SCM_GOOPS_UNBOUNDP (value
))
1125 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1130 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1131 (SCM obj
, SCM index
),
1132 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1133 "the value from @var{obj}.")
1134 #define FUNC_NAME s_scm_at_assert_bound_ref
1136 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1137 if (SCM_GOOPS_UNBOUNDP (value
))
1138 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1143 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1144 (SCM obj
, SCM index
),
1145 "Return the slot value with index @var{index} from @var{obj}.")
1146 #define FUNC_NAME s_scm_sys_fast_slot_ref
1148 unsigned long int i
;
1150 SCM_VALIDATE_INSTANCE (1, obj
);
1151 i
= scm_to_unsigned_integer (index
, 0,
1152 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1155 return SCM_SLOT (obj
, i
);
1159 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1160 (SCM obj
, SCM index
, SCM value
),
1161 "Set the slot with index @var{index} in @var{obj} to\n"
1163 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1165 unsigned long int i
;
1167 SCM_VALIDATE_INSTANCE (1, obj
);
1168 i
= scm_to_unsigned_integer (index
, 0,
1169 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1173 SCM_SET_SLOT (obj
, i
, value
);
1175 return SCM_UNSPECIFIED
;
1183 /* In the future, this function will return the effective slot
1184 * definition associated with SLOT_NAME. Now it just returns some of
1185 * the information which will be stored in the effective slot
1190 slot_definition_using_name (SCM
class, SCM slot_name
)
1192 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1193 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1194 if (SCM_CAAR (slots
) == slot_name
)
1195 return SCM_CAR (slots
);
1200 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1201 #define FUNC_NAME "%get-slot-value"
1203 SCM access
= SCM_CDDR (slotdef
);
1205 * - access is an integer (the offset of this slot in the slots vector)
1206 * - otherwise (car access) is the getter function to apply
1208 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1209 * we can just assume fixnums here.
1211 if (SCM_I_INUMP (access
))
1212 /* Don't poke at the slots directly, because scm_struct_ref handles the
1213 access bits for us. */
1214 return scm_struct_ref (obj
, access
);
1216 return scm_call_1 (SCM_CAR (access
), obj
);
1221 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1223 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1224 if (scm_is_true (slotdef
))
1225 return get_slot_value (class, obj
, slotdef
);
1227 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1231 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1232 #define FUNC_NAME "%set-slot-value"
1234 SCM access
= SCM_CDDR (slotdef
);
1236 * - access is an integer (the offset of this slot in the slots vector)
1237 * - otherwise (cadr access) is the setter function to apply
1239 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1240 * we can just assume fixnums here.
1242 if (SCM_I_INUMP (access
))
1243 /* obey permissions bits via going through struct-set! */
1244 scm_struct_set_x (obj
, access
, value
);
1246 /* ((cadr l) obj value) */
1247 scm_call_2 (SCM_CADR (access
), obj
, value
);
1248 return SCM_UNSPECIFIED
;
1253 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1255 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1256 if (scm_is_true (slotdef
))
1257 return set_slot_value (class, obj
, slotdef
, value
);
1259 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1263 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1267 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1268 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1274 /* ======================================== */
1276 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1277 (SCM
class, SCM obj
, SCM slot_name
),
1279 #define FUNC_NAME s_scm_slot_ref_using_class
1283 SCM_VALIDATE_CLASS (1, class);
1284 SCM_VALIDATE_INSTANCE (2, obj
);
1285 SCM_VALIDATE_SYMBOL (3, slot_name
);
1287 res
= get_slot_value_using_name (class, obj
, slot_name
);
1288 if (SCM_GOOPS_UNBOUNDP (res
))
1289 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1295 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1296 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1298 #define FUNC_NAME s_scm_slot_set_using_class_x
1300 SCM_VALIDATE_CLASS (1, class);
1301 SCM_VALIDATE_INSTANCE (2, obj
);
1302 SCM_VALIDATE_SYMBOL (3, slot_name
);
1304 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1309 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1310 (SCM
class, SCM obj
, SCM slot_name
),
1312 #define FUNC_NAME s_scm_slot_bound_using_class_p
1314 SCM_VALIDATE_CLASS (1, class);
1315 SCM_VALIDATE_INSTANCE (2, obj
);
1316 SCM_VALIDATE_SYMBOL (3, slot_name
);
1318 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1324 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1325 (SCM
class, SCM obj
, SCM slot_name
),
1327 #define FUNC_NAME s_scm_slot_exists_using_class_p
1329 SCM_VALIDATE_CLASS (1, class);
1330 SCM_VALIDATE_INSTANCE (2, obj
);
1331 SCM_VALIDATE_SYMBOL (3, slot_name
);
1332 return test_slot_existence (class, obj
, slot_name
);
1337 /* ======================================== */
1339 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1340 (SCM obj
, SCM slot_name
),
1341 "Return the value from @var{obj}'s slot with the name\n"
1343 #define FUNC_NAME s_scm_slot_ref
1347 SCM_VALIDATE_INSTANCE (1, obj
);
1348 TEST_CHANGE_CLASS (obj
, class);
1350 res
= get_slot_value_using_name (class, obj
, slot_name
);
1351 if (SCM_GOOPS_UNBOUNDP (res
))
1352 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1357 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1358 (SCM obj
, SCM slot_name
, SCM value
),
1359 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1360 #define FUNC_NAME s_scm_slot_set_x
1364 SCM_VALIDATE_INSTANCE (1, obj
);
1365 TEST_CHANGE_CLASS(obj
, class);
1367 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1371 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1373 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1374 (SCM obj
, SCM slot_name
),
1375 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1377 #define FUNC_NAME s_scm_slot_bound_p
1381 SCM_VALIDATE_INSTANCE (1, obj
);
1382 TEST_CHANGE_CLASS(obj
, class);
1384 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1392 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1393 (SCM obj
, SCM slot_name
),
1394 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1395 #define FUNC_NAME s_scm_slot_exists_p
1399 SCM_VALIDATE_INSTANCE (1, obj
);
1400 SCM_VALIDATE_SYMBOL (2, slot_name
);
1401 TEST_CHANGE_CLASS (obj
, class);
1403 return test_slot_existence (class, obj
, slot_name
);
1408 /******************************************************************************
1410 * %allocate-instance (the low level instance allocation primitive)
1412 ******************************************************************************/
1414 static void clear_method_cache (SCM
);
1416 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1417 (SCM
class, SCM initargs
),
1418 "Create a new instance of class @var{class} and initialize it\n"
1419 "from the arguments @var{initargs}.")
1420 #define FUNC_NAME s_scm_sys_allocate_instance
1427 SCM_VALIDATE_CLASS (1, class);
1429 /* FIXME: duplicates some of scm_make_struct. */
1431 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1432 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
, "struct");
1434 layout
= SCM_VTABLE_LAYOUT (class);
1436 /* Set all SCM-holding slots to unbound */
1437 for (i
= 0; i
< n
; i
++)
1439 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1441 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1443 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1445 SCM_STRUCT_DATA (obj
)[i
] = 0;
1448 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1449 clear_method_cache (obj
);
1455 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1456 (SCM obj
, SCM setter
),
1458 #define FUNC_NAME s_scm_sys_set_object_setter_x
1460 SCM_ASSERT (SCM_STRUCTP (obj
)
1461 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1465 SCM_SET_GENERIC_SETTER (obj
, setter
);
1466 return SCM_UNSPECIFIED
;
1470 /******************************************************************************
1472 * %modify-instance (used by change-class to modify in place)
1474 ******************************************************************************/
1476 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1479 #define FUNC_NAME s_scm_sys_modify_instance
1481 SCM_VALIDATE_INSTANCE (1, old
);
1482 SCM_VALIDATE_INSTANCE (2, new);
1484 /* Exchange the data contained in old and new. We exchange rather than
1485 * scratch the old value with new to be correct with GC.
1486 * See "Class redefinition protocol above".
1488 SCM_CRITICAL_SECTION_START
;
1490 scm_t_bits word0
, word1
;
1491 word0
= SCM_CELL_WORD_0 (old
);
1492 word1
= SCM_CELL_WORD_1 (old
);
1493 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1494 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1495 SCM_SET_CELL_WORD_0 (new, word0
);
1496 SCM_SET_CELL_WORD_1 (new, word1
);
1498 SCM_CRITICAL_SECTION_END
;
1499 return SCM_UNSPECIFIED
;
1503 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1506 #define FUNC_NAME s_scm_sys_modify_class
1508 SCM_VALIDATE_CLASS (1, old
);
1509 SCM_VALIDATE_CLASS (2, new);
1511 SCM_CRITICAL_SECTION_START
;
1513 scm_t_bits word0
, word1
;
1514 word0
= SCM_CELL_WORD_0 (old
);
1515 word1
= SCM_CELL_WORD_1 (old
);
1516 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1517 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1518 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1519 SCM_SET_CELL_WORD_0 (new, word0
);
1520 SCM_SET_CELL_WORD_1 (new, word1
);
1521 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1523 SCM_CRITICAL_SECTION_END
;
1524 return SCM_UNSPECIFIED
;
1528 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1531 #define FUNC_NAME s_scm_sys_invalidate_class
1533 SCM_VALIDATE_CLASS (1, class);
1534 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1535 return SCM_UNSPECIFIED
;
1539 /* When instances change class, they finally get a new body, but
1540 * before that, they go through purgatory in hell. Odd as it may
1541 * seem, this data structure saves us from eternal suffering in
1542 * infinite recursions.
1545 static scm_t_bits
**hell
;
1546 static long n_hell
= 1; /* one place for the evil one himself */
1547 static long hell_size
= 4;
1548 static SCM hell_mutex
;
1554 for (i
= 1; i
< n_hell
; ++i
)
1555 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1561 go_to_hell (void *o
)
1563 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1564 scm_lock_mutex (hell_mutex
);
1565 if (n_hell
>= hell_size
)
1568 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1570 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1571 scm_unlock_mutex (hell_mutex
);
1575 go_to_heaven (void *o
)
1577 scm_lock_mutex (hell_mutex
);
1578 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1579 scm_unlock_mutex (hell_mutex
);
1583 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1586 purgatory (void *args
)
1588 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1589 SCM_PACK ((scm_t_bits
) args
));
1592 /* This function calls the generic function change-class for all
1593 * instances which aren't currently undergoing class change.
1597 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1600 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1601 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1602 (void *) SCM_UNPACK (obj
));
1605 /******************************************************************************
1611 * GGG E N E R I C F U N C T I O N S
1613 * This implementation provides
1614 * - generic functions (with class specializers)
1617 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1619 ******************************************************************************/
1621 SCM_KEYWORD (k_name
, "name");
1623 SCM_SYMBOL (sym_no_method
, "no-method");
1625 static SCM list_of_no_method
;
1627 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1631 scm_apply_generic (SCM gf
, SCM args
)
1633 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1637 scm_call_generic_0 (SCM gf
)
1639 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1643 scm_call_generic_1 (SCM gf
, SCM a1
)
1645 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1649 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1651 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1655 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1657 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1660 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1662 make_dispatch_procedure (SCM gf
)
1664 static SCM var
= SCM_BOOL_F
;
1665 if (var
== SCM_BOOL_F
)
1666 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1667 sym_delayed_compile
);
1668 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1672 clear_method_cache (SCM gf
)
1674 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1675 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1678 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1681 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1683 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1684 clear_method_cache (gf
);
1685 return SCM_UNSPECIFIED
;
1689 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1692 #define FUNC_NAME s_scm_generic_capability_p
1694 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1695 proc
, SCM_ARG1
, FUNC_NAME
);
1696 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1702 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1705 #define FUNC_NAME s_scm_enable_primitive_generic_x
1707 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1708 while (!scm_is_null (subrs
))
1710 SCM subr
= SCM_CAR (subrs
);
1711 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1712 subr
, SCM_ARGn
, FUNC_NAME
);
1713 *SCM_SUBR_GENERIC (subr
)
1714 = scm_make (scm_list_3 (scm_class_generic
,
1716 SCM_SUBR_NAME (subr
)));
1717 subrs
= SCM_CDR (subrs
);
1719 return SCM_UNSPECIFIED
;
1723 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1724 (SCM subr
, SCM generic
),
1726 #define FUNC_NAME s_scm_set_primitive_generic_x
1728 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1729 subr
, SCM_ARG1
, FUNC_NAME
);
1730 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1731 *SCM_SUBR_GENERIC (subr
) = generic
;
1732 return SCM_UNSPECIFIED
;
1736 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1739 #define FUNC_NAME s_scm_primitive_generic_generic
1741 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1743 if (!*SCM_SUBR_GENERIC (subr
))
1744 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1745 return *SCM_SUBR_GENERIC (subr
);
1747 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1751 typedef struct t_extension
{
1752 struct t_extension
*next
;
1758 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1760 static const char extension_gc_hint
[] = "GOOPS extension";
1762 static t_extension
*extensions
= 0;
1765 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1770 if (!*SCM_SUBR_GENERIC (extended
))
1771 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1772 gf
= *SCM_SUBR_GENERIC (extended
);
1773 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1775 SCM_SUBR_NAME (extension
));
1776 SCM_SET_SUBR_GENERIC (extension
, gext
);
1780 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1782 t_extension
**loc
= &extensions
;
1783 /* Make sure that extensions are placed before their own
1784 * extensions in the extensions list. O(N^2) algorithm, but
1785 * extensions of primitive generics are rare.
1787 while (*loc
&& extension
!= (*loc
)->extended
)
1788 loc
= &(*loc
)->next
;
1790 e
->extended
= extended
;
1791 e
->extension
= extension
;
1797 setup_extended_primitive_generics ()
1801 t_extension
*e
= extensions
;
1802 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1803 extensions
= e
->next
;
1807 /******************************************************************************
1809 * Protocol for calling a generic fumction
1810 * This protocol is roughly equivalent to (parameter are a little bit different
1811 * for efficiency reasons):
1813 * + apply-generic (gf args)
1814 * + compute-applicable-methods (gf args ...)
1815 * + sort-applicable-methods (methods args)
1816 * + apply-methods (gf methods args)
1818 * apply-methods calls make-next-method to build the "continuation" of a a
1819 * method. Applying a next-method will call apply-next-method which in
1820 * turn will call apply again to call effectively the following method.
1822 ******************************************************************************/
1825 applicablep (SCM actual
, SCM formal
)
1827 /* We already know that the cpl is well formed. */
1828 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1832 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1834 register SCM s1
, s2
;
1838 * m1 and m2 can have != length (i.e. one can be one element longer than the
1839 * other when we have a dotted parameter list). For instance, with the call
1842 * (define-method M (a . l) ....)
1843 * (define-method M (a) ....)
1845 * we consider that the second method is more specific.
1847 * BTW, targs is an array of types. We don't need it's size since
1848 * we already know that m1 and m2 are applicable (no risk to go past
1849 * the end of this array).
1852 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1853 if (scm_is_null(s1
)) return 1;
1854 if (scm_is_null(s2
)) return 0;
1855 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1856 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1858 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1859 if (cs1
== SCM_CAR(l
))
1861 if (cs2
== SCM_CAR(l
))
1864 return 0;/* should not occur! */
1867 return 0; /* should not occur! */
1870 #define BUFFSIZE 32 /* big enough for most uses */
1873 scm_i_vector2list (SCM l
, long len
)
1876 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1878 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1879 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1885 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1888 SCM
*v
, vector
= SCM_EOL
;
1889 SCM buffer
[BUFFSIZE
];
1890 SCM save
= method_list
;
1891 scm_t_array_handle handle
;
1893 /* For reasonably sized method_lists we can try to avoid all the
1894 * consing and reorder the list in place...
1895 * This idea is due to David McClain <Dave_McClain@msn.com>
1897 if (size
<= BUFFSIZE
)
1899 for (i
= 0; i
< size
; i
++)
1901 buffer
[i
] = SCM_CAR (method_list
);
1902 method_list
= SCM_CDR (method_list
);
1908 /* Too many elements in method_list to keep everything locally */
1909 vector
= scm_i_vector2list (save
, size
);
1910 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
1913 /* Use a simple shell sort since it is generally faster than qsort on
1914 * small vectors (which is probably mostly the case when we have to
1915 * sort a list of applicable methods).
1917 for (incr
= size
/ 2; incr
; incr
/= 2)
1919 for (i
= incr
; i
< size
; i
++)
1921 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1923 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1927 SCM tmp
= v
[j
+ incr
];
1935 if (size
<= BUFFSIZE
)
1937 /* We did it in locally, so restore the original list (reordered) in-place */
1938 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1940 SCM_SETCAR (method_list
, *v
);
1941 method_list
= SCM_CDR (method_list
);
1946 /* If we are here, that's that we did it the hard way... */
1947 scm_array_handle_release (&handle
);
1948 return scm_vector_to_list (vector
);
1952 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1956 SCM l
, fl
, applicable
= SCM_EOL
;
1958 SCM buffer
[BUFFSIZE
];
1962 scm_t_array_handle handle
;
1964 /* Build the list of arguments types */
1965 if (len
>= BUFFSIZE
)
1967 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1968 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
1971 note that we don't have to work to reset the generation
1972 count. TMP is a new vector anyway, and it is found
1979 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
1980 *p
++ = scm_class_of (SCM_CAR (args
));
1982 /* Build a list of all applicable methods */
1983 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
1985 fl
= SPEC_OF (SCM_CAR (l
));
1986 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1988 if (SCM_INSTANCEP (fl
)
1989 /* We have a dotted argument list */
1990 || (i
>= len
&& scm_is_null (fl
)))
1991 { /* both list exhausted */
1992 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1998 || !applicablep (types
[i
], SCM_CAR (fl
)))
2003 if (len
>= BUFFSIZE
)
2004 scm_array_handle_release (&handle
);
2010 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2011 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2017 : sort_applicable_methods (applicable
, count
, types
));
2021 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2024 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2027 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2028 #define FUNC_NAME s_sys_compute_applicable_methods
2031 SCM_VALIDATE_GENERIC (1, gf
);
2032 n
= scm_ilength (args
);
2033 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2034 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2038 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2039 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
));
2041 /******************************************************************************
2043 * A simple make (which will be redefined later in Scheme)
2044 * This version handles only creation of gf, methods and classes (no instances)
2046 * Since this code will disappear when Goops will be fully booted,
2047 * no precaution is taken to be efficient.
2049 ******************************************************************************/
2051 SCM_KEYWORD (k_setter
, "setter");
2052 SCM_KEYWORD (k_specializers
, "specializers");
2053 SCM_KEYWORD (k_procedure
, "procedure");
2054 SCM_KEYWORD (k_formals
, "formals");
2055 SCM_KEYWORD (k_body
, "body");
2056 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2057 SCM_KEYWORD (k_dsupers
, "dsupers");
2058 SCM_KEYWORD (k_slots
, "slots");
2059 SCM_KEYWORD (k_gf
, "generic-function");
2061 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2063 "Make a new object. @var{args} must contain the class and\n"
2064 "all necessary initialization information.")
2065 #define FUNC_NAME s_scm_make
2068 long len
= scm_ilength (args
);
2070 if (len
<= 0 || (len
& 1) == 0)
2071 SCM_WRONG_NUM_ARGS ();
2073 class = SCM_CAR(args
);
2074 args
= SCM_CDR(args
);
2076 if (class == scm_class_generic
|| class == scm_class_accessor
)
2078 z
= scm_make_struct (class, SCM_INUM0
,
2079 scm_list_4 (SCM_BOOL_F
,
2083 scm_set_procedure_property_x (z
, scm_sym_name
,
2084 scm_get_keyword (k_name
,
2087 clear_method_cache (z
);
2088 if (class == scm_class_accessor
)
2090 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2091 if (scm_is_true (setter
))
2092 scm_sys_set_object_setter_x (z
, setter
);
2097 z
= scm_sys_allocate_instance (class, args
);
2099 if (class == scm_class_method
2100 || class == scm_class_accessor_method
)
2102 SCM_SET_SLOT (z
, scm_si_generic_function
,
2103 scm_i_get_keyword (k_gf
,
2108 SCM_SET_SLOT (z
, scm_si_specializers
,
2109 scm_i_get_keyword (k_specializers
,
2114 SCM_SET_SLOT (z
, scm_si_procedure
,
2115 scm_i_get_keyword (k_procedure
,
2120 SCM_SET_SLOT (z
, scm_si_formals
,
2121 scm_i_get_keyword (k_formals
,
2126 SCM_SET_SLOT (z
, scm_si_body
,
2127 scm_i_get_keyword (k_body
,
2132 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2133 scm_i_get_keyword (k_make_procedure
,
2141 /* In all the others case, make a new class .... No instance here */
2142 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2143 scm_i_get_keyword (k_name
,
2146 scm_from_locale_symbol ("???"),
2148 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2149 scm_i_get_keyword (k_dsupers
,
2154 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2155 scm_i_get_keyword (k_slots
,
2166 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2169 #define FUNC_NAME s_scm_find_method
2172 long len
= scm_ilength (l
);
2175 SCM_WRONG_NUM_ARGS ();
2177 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2178 SCM_VALIDATE_GENERIC (1, gf
);
2179 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2180 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2182 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2186 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2187 (SCM m1
, SCM m2
, SCM targs
),
2188 "Return true if method @var{m1} is more specific than @var{m2} "
2189 "given the argument types (classes) listed in @var{targs}.")
2190 #define FUNC_NAME s_scm_sys_method_more_specific_p
2194 long i
, len
, m1_specs
, m2_specs
;
2195 scm_t_array_handle handle
;
2197 SCM_VALIDATE_METHOD (1, m1
);
2198 SCM_VALIDATE_METHOD (2, m2
);
2200 len
= scm_ilength (targs
);
2201 m1_specs
= scm_ilength (SPEC_OF (m1
));
2202 m2_specs
= scm_ilength (SPEC_OF (m2
));
2203 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2204 targs
, SCM_ARG3
, FUNC_NAME
);
2206 /* Verify that all the arguments of TARGS are classes and place them
2209 v
= scm_c_make_vector (len
, SCM_EOL
);
2210 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2212 for (i
= 0, l
= targs
;
2213 i
< len
&& scm_is_pair (l
);
2214 i
++, l
= SCM_CDR (l
))
2216 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2217 v_elts
[i
] = SCM_CAR (l
);
2219 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2221 scm_array_handle_release (&handle
);
2229 /******************************************************************************
2233 ******************************************************************************/
2236 fix_cpl (SCM c
, SCM before
, SCM after
)
2238 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2239 SCM ls
= scm_c_memq (after
, cpl
);
2240 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2241 if (scm_is_false (ls
))
2242 /* if this condition occurs, fix_cpl should not be applied this way */
2244 SCM_SETCAR (ls
, before
);
2245 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2247 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2248 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2249 SCM g_n_s
= compute_getters_n_setters (slots
);
2250 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2251 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2257 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2259 SCM tmp
= scm_from_locale_symbol (name
);
2261 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2265 : scm_list_1 (super
),
2271 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2274 create_standard_classes (void)
2277 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2278 scm_from_locale_symbol ("specializers"),
2280 scm_from_locale_symbol ("formals"),
2281 scm_from_locale_symbol ("body"),
2282 scm_from_locale_symbol ("make-procedure"),
2284 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2286 k_slot_definition
));
2287 SCM gf_slots
= scm_list_4 (scm_from_locale_symbol ("methods"),
2288 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2291 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2294 scm_from_locale_symbol ("effective-methods"));
2295 SCM setter_slots
= scm_list_1 (sym_setter
);
2296 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2299 /* Foreign class slot classes */
2300 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2301 scm_class_class
, scm_class_top
, SCM_EOL
);
2302 make_stdcls (&scm_class_protected
, "<protected-slot>",
2303 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2304 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2305 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2306 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2307 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2308 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2309 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2310 make_stdcls (&scm_class_self
, "<self-slot>",
2311 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2312 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2314 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2316 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2318 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2320 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2322 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2324 make_stdcls (&scm_class_scm
, "<scm-slot>",
2325 scm_class_class
, scm_class_protected
, SCM_EOL
);
2326 make_stdcls (&scm_class_int
, "<int-slot>",
2327 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2328 make_stdcls (&scm_class_float
, "<float-slot>",
2329 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2330 make_stdcls (&scm_class_double
, "<double-slot>",
2331 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2333 /* Continue initialization of class <class> */
2335 slots
= build_class_class_slots ();
2336 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2337 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2338 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2339 compute_getters_n_setters (slots
));
2341 /* scm_class_generic functions classes */
2342 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2343 scm_class_class
, scm_class_class
, SCM_EOL
);
2344 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2345 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2346 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2347 make_stdcls (&scm_class_method
, "<method>",
2348 scm_class_class
, scm_class_object
, method_slots
);
2349 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2350 scm_class_class
, scm_class_method
, amethod_slots
);
2351 make_stdcls (&scm_class_applicable
, "<applicable>",
2352 scm_class_class
, scm_class_top
, SCM_EOL
);
2353 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2354 scm_class_applicable_struct_class
,
2355 scm_list_2 (scm_class_object
, scm_class_applicable
),
2356 scm_list_1 (sym_procedure
));
2357 make_stdcls (&scm_class_generic
, "<generic>",
2358 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2359 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2360 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2361 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2362 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2363 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2364 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2365 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2366 make_stdcls (&scm_class_accessor
, "<accessor>",
2367 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2368 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2369 make_stdcls (&scm_class_extended_generic_with_setter
,
2370 "<extended-generic-with-setter>",
2371 scm_class_applicable_struct_class
,
2372 scm_list_2 (scm_class_generic_with_setter
,
2373 scm_class_extended_generic
),
2375 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2376 SCM_CLASSF_PURE_GENERIC
);
2377 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2378 scm_class_applicable_struct_class
,
2379 scm_list_2 (scm_class_accessor
,
2380 scm_class_extended_generic_with_setter
),
2382 fix_cpl (scm_class_extended_accessor
,
2383 scm_class_extended_generic
, scm_class_generic
);
2384 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2386 /* Primitive types classes */
2387 make_stdcls (&scm_class_boolean
, "<boolean>",
2388 scm_class_class
, scm_class_top
, SCM_EOL
);
2389 make_stdcls (&scm_class_char
, "<char>",
2390 scm_class_class
, scm_class_top
, SCM_EOL
);
2391 make_stdcls (&scm_class_list
, "<list>",
2392 scm_class_class
, scm_class_top
, SCM_EOL
);
2393 make_stdcls (&scm_class_pair
, "<pair>",
2394 scm_class_class
, scm_class_list
, SCM_EOL
);
2395 make_stdcls (&scm_class_null
, "<null>",
2396 scm_class_class
, scm_class_list
, SCM_EOL
);
2397 make_stdcls (&scm_class_string
, "<string>",
2398 scm_class_class
, scm_class_top
, SCM_EOL
);
2399 make_stdcls (&scm_class_symbol
, "<symbol>",
2400 scm_class_class
, scm_class_top
, SCM_EOL
);
2401 make_stdcls (&scm_class_vector
, "<vector>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_number
, "<number>",
2404 scm_class_class
, scm_class_top
, SCM_EOL
);
2405 make_stdcls (&scm_class_complex
, "<complex>",
2406 scm_class_class
, scm_class_number
, SCM_EOL
);
2407 make_stdcls (&scm_class_real
, "<real>",
2408 scm_class_class
, scm_class_complex
, SCM_EOL
);
2409 make_stdcls (&scm_class_integer
, "<integer>",
2410 scm_class_class
, scm_class_real
, SCM_EOL
);
2411 make_stdcls (&scm_class_fraction
, "<fraction>",
2412 scm_class_class
, scm_class_real
, SCM_EOL
);
2413 make_stdcls (&scm_class_keyword
, "<keyword>",
2414 scm_class_class
, scm_class_top
, SCM_EOL
);
2415 make_stdcls (&scm_class_unknown
, "<unknown>",
2416 scm_class_class
, scm_class_top
, SCM_EOL
);
2417 make_stdcls (&scm_class_procedure
, "<procedure>",
2418 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2419 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2420 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2421 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2422 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2423 make_stdcls (&scm_class_port
, "<port>",
2424 scm_class_class
, scm_class_top
, SCM_EOL
);
2425 make_stdcls (&scm_class_input_port
, "<input-port>",
2426 scm_class_class
, scm_class_port
, SCM_EOL
);
2427 make_stdcls (&scm_class_output_port
, "<output-port>",
2428 scm_class_class
, scm_class_port
, SCM_EOL
);
2429 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2431 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2435 /**********************************************************************
2439 **********************************************************************/
2442 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2448 sprintf (buffer
, template, type_name
);
2449 name
= scm_from_locale_symbol (buffer
);
2452 name
= SCM_GOOPS_UNBOUND
;
2454 class = scm_permanent_object (scm_basic_make_class (applicablep
2455 ? scm_class_procedure_class
2461 /* Only define name if doesn't already exist. */
2462 if (!SCM_GOOPS_UNBOUNDP (name
)
2463 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2464 DEFVAR (name
, class);
2469 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2472 if (type_name_sym
!= SCM_BOOL_F
)
2474 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2475 scm_symbol_to_string (type_name_sym
),
2476 scm_from_locale_string (">")));
2477 name
= scm_string_to_symbol (name
);
2480 name
= SCM_GOOPS_UNBOUND
;
2482 class = scm_permanent_object (scm_basic_make_class (applicablep
2483 ? scm_class_procedure_class
2489 /* Only define name if doesn't already exist. */
2490 if (!SCM_GOOPS_UNBOUNDP (name
)
2491 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2492 DEFVAR (name
, class);
2497 scm_make_extended_class (char const *type_name
, int applicablep
)
2499 return make_class_from_template ("<%s>",
2501 scm_list_1 (applicablep
2502 ? scm_class_applicable
2508 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2510 return make_class_from_symbol (type_name_sym
,
2511 scm_list_1 (applicablep
2512 ? scm_class_applicable
2518 scm_i_inherit_applicable (SCM c
)
2520 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2522 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2523 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2524 /* patch scm_class_applicable into direct-supers */
2525 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2526 if (scm_is_false (top
))
2527 dsupers
= scm_append (scm_list_2 (dsupers
,
2528 scm_list_1 (scm_class_applicable
)));
2531 SCM_SETCAR (top
, scm_class_applicable
);
2532 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2534 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2535 /* patch scm_class_applicable into cpl */
2536 top
= scm_c_memq (scm_class_top
, cpl
);
2537 if (scm_is_false (top
))
2541 SCM_SETCAR (top
, scm_class_applicable
);
2542 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2544 /* add class to direct-subclasses of scm_class_applicable */
2545 SCM_SET_SLOT (scm_class_applicable
,
2546 scm_si_direct_subclasses
,
2547 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2548 scm_si_direct_subclasses
)));
2553 create_smob_classes (void)
2557 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2558 scm_smob_class
[i
] = 0;
2560 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2562 for (i
= 0; i
< scm_numsmob
; ++i
)
2563 if (!scm_smob_class
[i
])
2564 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2565 scm_smobs
[i
].apply
!= 0);
2569 scm_make_port_classes (long ptobnum
, char *type_name
)
2571 SCM c
, class = make_class_from_template ("<%s-port>",
2573 scm_list_1 (scm_class_port
),
2575 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2576 = make_class_from_template ("<%s-input-port>",
2578 scm_list_2 (class, scm_class_input_port
),
2580 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2581 = make_class_from_template ("<%s-output-port>",
2583 scm_list_2 (class, scm_class_output_port
),
2585 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2587 = make_class_from_template ("<%s-input-output-port>",
2589 scm_list_2 (class, scm_class_input_output_port
),
2591 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2592 SCM_SET_SLOT (c
, scm_si_cpl
,
2593 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2597 create_port_classes (void)
2601 for (i
= 0; i
< scm_numptob
; ++i
)
2602 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2606 make_struct_class (void *closure SCM_UNUSED
,
2607 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2609 SCM sym
= SCM_STRUCT_TABLE_NAME (data
);
2610 if (scm_is_true (sym
))
2612 int applicablep
= SCM_CLASS_FLAGS (vtable
) & SCM_VTABLE_FLAG_APPLICABLE
;
2614 SCM_SET_STRUCT_TABLE_CLASS (data
,
2615 scm_make_extended_class_from_symbol (sym
, applicablep
));
2618 scm_remember_upto_here_2 (data
, vtable
);
2619 return SCM_UNSPECIFIED
;
2623 create_struct_classes (void)
2625 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2628 /**********************************************************************
2632 **********************************************************************/
2637 if (!goops_loaded_p
)
2638 scm_c_resolve_module ("oop goops");
2642 SCM_SYMBOL (sym_o
, "o");
2643 SCM_SYMBOL (sym_x
, "x");
2645 SCM_KEYWORD (k_accessor
, "accessor");
2646 SCM_KEYWORD (k_getter
, "getter");
2649 scm_ensure_accessor (SCM name
)
2651 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2652 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2654 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2655 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2656 k_name
, name
, k_setter
, gf
));
2661 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2664 scm_add_method (SCM gf
, SCM m
)
2666 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2671 * Debugging utilities
2674 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2676 "Return @code{#t} if @var{obj} is a pure generic.")
2677 #define FUNC_NAME s_scm_pure_generic_p
2679 return scm_from_bool (SCM_PUREGENERICP (obj
));
2683 #endif /* GUILE_DEBUG */
2689 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2691 "Announce that GOOPS is loaded and perform initialization\n"
2692 "on the C level which depends on the loaded GOOPS modules.")
2693 #define FUNC_NAME s_scm_sys_goops_loaded
2696 var_compute_applicable_methods
=
2697 scm_permanent_object
2698 (scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
));
2700 scm_permanent_object
2701 (scm_module_variable (scm_module_goops
, sym_slot_unbound
));
2703 scm_permanent_object
2704 (scm_module_variable (scm_module_goops
, sym_slot_missing
));
2706 scm_permanent_object
2707 (scm_module_variable (scm_module_goops
, sym_compute_cpl
));
2708 var_no_applicable_method
=
2709 scm_permanent_object
2710 (scm_module_variable (scm_module_goops
, sym_no_applicable_method
));
2712 scm_permanent_object
2713 (scm_module_variable (scm_module_goops
, sym_change_class
));
2714 setup_extended_primitive_generics ();
2715 return SCM_UNSPECIFIED
;
2719 SCM scm_module_goops
;
2722 scm_init_goops_builtins (void)
2724 scm_module_goops
= scm_current_module ();
2726 /* Not really necessary right now, but who knows...
2728 scm_permanent_object (scm_module_goops
);
2730 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2732 #include "libguile/goops.x"
2734 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2736 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2737 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2739 create_basic_classes ();
2740 create_standard_classes ();
2741 create_smob_classes ();
2742 create_struct_classes ();
2743 create_port_classes ();
2746 SCM name
= scm_from_locale_symbol ("no-applicable-method");
2747 scm_no_applicable_method
2748 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
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
);