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 static SCM class_hashtable
;
162 static SCM class_fluid
;
163 static SCM class_dynamic_state
;
165 /* Port classes. Allocate 3 times the maximum number of port types so that
166 input ports, output ports, and in/out ports can be stored at different
167 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
168 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
171 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
173 SCM scm_no_applicable_method
;
175 SCM_SYMBOL (scm_sym_define_public
, "define-public");
177 static SCM
scm_make_unbound (void);
178 static SCM
scm_unbound_p (SCM obj
);
179 static SCM
scm_assert_bound (SCM value
, SCM obj
);
180 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
181 static SCM
scm_sys_goops_loaded (void);
182 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
185 /* This function is used for efficient type dispatch. */
186 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
188 "Return the class of @var{x}.")
189 #define FUNC_NAME s_scm_class_of
191 switch (SCM_ITAG3 (x
))
195 return scm_class_integer
;
199 return scm_class_char
;
200 else if (scm_is_bool (x
))
201 return scm_class_boolean
;
202 else if (scm_is_null (x
))
203 return scm_class_null
;
205 return scm_class_unknown
;
208 switch (SCM_TYP7 (x
))
210 case scm_tcs_cons_nimcar
:
211 return scm_class_pair
;
213 return scm_class_symbol
;
216 return scm_class_vector
;
217 case scm_tc7_hashtable
:
218 return class_hashtable
;
221 case scm_tc7_dynamic_state
:
222 return class_dynamic_state
;
224 return scm_class_string
;
226 switch SCM_TYP16 (x
) {
228 return scm_class_integer
;
230 return scm_class_real
;
231 case scm_tc16_complex
:
232 return scm_class_complex
;
233 case scm_tc16_fraction
:
234 return scm_class_fraction
;
237 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
238 return scm_class_primitive_generic
;
240 return scm_class_procedure
;
241 case scm_tc7_program
:
242 return scm_class_procedure
;
244 return scm_class_procedure_with_setter
;
248 scm_t_bits type
= SCM_TYP16 (x
);
249 if (type
!= scm_tc16_port_with_ps
)
250 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
251 x
= SCM_PORT_WITH_PS_PORT (x
);
252 /* fall through to ports */
255 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
256 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
257 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
258 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
259 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
261 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
262 return SCM_CLASS_OF (x
);
263 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
266 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
267 scm_change_object_class (x
,
268 SCM_CLASS_OF (x
), /* old */
269 SCM_OBJ_CLASS_REDEF (x
)); /* new */
270 return SCM_CLASS_OF (x
);
274 /* ordinary struct */
275 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
276 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
277 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
282 name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
283 if (!scm_is_symbol (name
))
284 name
= scm_string_to_symbol (scm_nullstr
);
287 scm_make_extended_class_from_symbol (name
,
288 SCM_STRUCT_APPLICABLE_P (x
));
289 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
295 return scm_class_pair
;
297 return scm_class_unknown
;
303 /* case scm_tc3_unused: */
307 return scm_class_unknown
;
311 /******************************************************************************
315 * This version doesn't fully handle multiple-inheritance. It serves
316 * only for booting classes and will be overloaded in Scheme
318 ******************************************************************************/
321 map (SCM (*proc
) (SCM
), SCM ls
)
323 if (scm_is_null (ls
))
327 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
330 while (!scm_is_null (ls
))
332 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
344 while (!scm_is_null (ls
))
346 SCM el
= SCM_CAR (ls
);
347 if (scm_is_false (scm_c_memq (el
, res
)))
348 res
= scm_cons (el
, res
);
355 compute_cpl (SCM
class)
358 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
361 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
362 SCM ls
= scm_append (scm_acons (class, supers
,
363 map (compute_cpl
, supers
)));
364 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
368 /******************************************************************************
372 ******************************************************************************/
375 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
383 if (!scm_is_symbol (tmp
))
384 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
386 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
387 res
= scm_cons (SCM_CAR (l
), res
);
388 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
391 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
395 build_slots_list (SCM dslots
, SCM cpl
)
397 register SCM res
= dslots
;
399 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
400 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
401 scm_si_direct_slots
),
404 /* res contains a list of slots. Remove slots which appears more than once */
405 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
412 while (!scm_is_null (ls
))
414 if (!scm_is_pair (SCM_CAR (ls
)))
415 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
422 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
424 "Return a list consisting of the names of all slots belonging to\n"
425 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
427 #define FUNC_NAME s_scm_sys_compute_slots
429 SCM_VALIDATE_CLASS (1, class);
430 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
431 SCM_SLOT (class, scm_si_cpl
));
436 /******************************************************************************
438 * compute-getters-n-setters
440 * This version doesn't handle slot options. It serves only for booting
441 * classes and will be overloaded in Scheme.
443 ******************************************************************************/
445 SCM_KEYWORD (k_init_value
, "init-value");
446 SCM_KEYWORD (k_init_thunk
, "init-thunk");
449 compute_getters_n_setters (SCM slots
)
455 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
457 SCM init
= SCM_BOOL_F
;
458 SCM options
= SCM_CDAR (slots
);
459 if (!scm_is_null (options
))
461 init
= scm_get_keyword (k_init_value
, options
, 0);
464 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
466 scm_list_2 (scm_sym_quote
,
470 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
472 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
474 scm_from_int (i
++))),
476 cdrloc
= SCM_CDRLOC (*cdrloc
);
481 /******************************************************************************
485 ******************************************************************************/
487 /*fixme* Manufacture keywords in advance */
489 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
493 for (i
= 0; i
!= len
; i
+= 2)
495 SCM obj
= SCM_CAR (l
);
497 if (!scm_is_keyword (obj
))
498 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
499 else if (scm_is_eq (obj
, key
))
505 return default_value
;
509 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
510 (SCM key
, SCM l
, SCM default_value
),
511 "Determine an associated value for the keyword @var{key} from\n"
512 "the list @var{l}. The list @var{l} has to consist of an even\n"
513 "number of elements, where, starting with the first, every\n"
514 "second element is a keyword, followed by its associated value.\n"
515 "If @var{l} does not hold a value for @var{key}, the value\n"
516 "@var{default_value} is returned.")
517 #define FUNC_NAME s_scm_get_keyword
521 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
522 len
= scm_ilength (l
);
523 if (len
< 0 || len
% 2 == 1)
524 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
526 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
531 SCM_KEYWORD (k_init_keyword
, "init-keyword");
533 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
534 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
536 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
537 (SCM obj
, SCM initargs
),
538 "Initialize the object @var{obj} with the given arguments\n"
540 #define FUNC_NAME s_scm_sys_initialize_object
542 SCM tmp
, get_n_set
, slots
;
543 SCM
class = SCM_CLASS_OF (obj
);
546 SCM_VALIDATE_INSTANCE (1, obj
);
547 n_initargs
= scm_ilength (initargs
);
548 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
550 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
551 slots
= SCM_SLOT (class, scm_si_slots
);
553 /* See for each slot how it must be initialized */
555 !scm_is_null (slots
);
556 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
558 SCM slot_name
= SCM_CAR (slots
);
561 if (!scm_is_null (SCM_CDR (slot_name
)))
563 /* This slot admits (perhaps) to be initialized at creation time */
564 long n
= scm_ilength (SCM_CDR (slot_name
));
565 if (n
& 1) /* odd or -1 */
566 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
567 scm_list_1 (slot_name
));
568 tmp
= scm_i_get_keyword (k_init_keyword
,
573 slot_name
= SCM_CAR (slot_name
);
576 /* an initarg was provided for this slot */
577 if (!scm_is_keyword (tmp
))
578 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
580 slot_value
= scm_i_get_keyword (tmp
,
589 /* set slot to provided value */
590 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
593 /* set slot to its :init-form if it exists */
594 tmp
= SCM_CADAR (get_n_set
);
595 if (scm_is_true (tmp
))
597 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
598 if (SCM_GOOPS_UNBOUNDP (slot_value
))
599 set_slot_value (class,
611 /* NOTE: The following macros are interdependent with code
612 * in goops.scm:compute-getters-n-setters
614 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
615 (SCM_I_INUMP (SCM_CDDR (gns)) \
616 || (scm_is_pair (SCM_CDDR (gns)) \
617 && scm_is_pair (SCM_CDDDR (gns)) \
618 && scm_is_pair (SCM_CDDDDR (gns))))
619 #define SCM_GNS_INDEX(gns) \
620 (SCM_I_INUMP (SCM_CDDR (gns)) \
621 ? SCM_I_INUM (SCM_CDDR (gns)) \
622 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
623 #define SCM_GNS_SIZE(gns) \
624 (SCM_I_INUMP (SCM_CDDR (gns)) \
626 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
628 SCM_KEYWORD (k_class
, "class");
629 SCM_KEYWORD (k_allocation
, "allocation");
630 SCM_KEYWORD (k_instance
, "instance");
632 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
635 #define FUNC_NAME s_scm_sys_prep_layout_x
637 SCM slots
, getters_n_setters
, nfields
;
638 unsigned long int n
, i
;
642 SCM_VALIDATE_INSTANCE (1, class);
643 slots
= SCM_SLOT (class, scm_si_slots
);
644 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
645 nfields
= SCM_SLOT (class, scm_si_nfields
);
646 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
647 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
648 scm_list_1 (nfields
));
649 n
= 2 * SCM_I_INUM (nfields
);
650 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
651 && SCM_SUBCLASSP (class, scm_class_class
))
652 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
653 scm_list_1 (nfields
));
655 layout
= scm_i_make_string (n
, &s
);
657 while (scm_is_pair (getters_n_setters
))
659 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
662 int len
, index
, size
;
665 if (i
>= n
|| !scm_is_pair (slots
))
668 /* extract slot type */
669 len
= scm_ilength (SCM_CDAR (slots
));
670 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
671 len
, SCM_BOOL_F
, FUNC_NAME
);
672 /* determine slot GC protection and access mode */
673 if (scm_is_false (type
))
680 if (!SCM_CLASSP (type
))
681 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
682 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
684 if (SCM_SUBCLASSP (type
, scm_class_self
))
686 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
691 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
693 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
695 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
707 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
708 if (index
!= (i
>> 1))
710 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
718 slots
= SCM_CDR (slots
);
719 getters_n_setters
= SCM_CDR (getters_n_setters
);
721 if (!scm_is_null (slots
))
724 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
726 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
727 return SCM_UNSPECIFIED
;
731 static void prep_hashsets (SCM
);
733 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
734 (SCM
class, SCM dsupers
),
736 #define FUNC_NAME s_scm_sys_inherit_magic_x
738 SCM_VALIDATE_INSTANCE (1, class);
739 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
740 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
742 prep_hashsets (class);
744 return SCM_UNSPECIFIED
;
749 prep_hashsets (SCM
class)
753 for (i
= 0; i
< 8; ++i
)
754 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
757 /******************************************************************************/
760 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
762 SCM z
, cpl
, slots
, nfields
, g_n_s
;
764 /* Allocate one instance */
765 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
767 /* Initialize its slots */
768 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
769 cpl
= compute_cpl (z
);
770 slots
= build_slots_list (maplist (dslots
), cpl
);
771 nfields
= scm_from_int (scm_ilength (slots
));
772 g_n_s
= compute_getters_n_setters (slots
);
774 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
775 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
776 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
777 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
778 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
779 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
780 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
781 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
782 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
784 /* Add this class in the direct-subclasses slot of dsupers */
787 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
788 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
789 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
790 scm_si_direct_subclasses
)));
797 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
799 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
800 scm_sys_prep_layout_x (z
);
801 scm_sys_inherit_magic_x (z
, dsupers
);
805 /******************************************************************************/
807 SCM_SYMBOL (sym_layout
, "layout");
808 SCM_SYMBOL (sym_flags
, "flags");
809 SCM_SYMBOL (sym_self
, "%self");
810 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
811 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
812 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
813 SCM_SYMBOL (sym_print
, "print");
814 SCM_SYMBOL (sym_procedure
, "procedure");
815 SCM_SYMBOL (sym_setter
, "setter");
816 SCM_SYMBOL (sym_redefined
, "redefined");
817 SCM_SYMBOL (sym_h0
, "h0");
818 SCM_SYMBOL (sym_h1
, "h1");
819 SCM_SYMBOL (sym_h2
, "h2");
820 SCM_SYMBOL (sym_h3
, "h3");
821 SCM_SYMBOL (sym_h4
, "h4");
822 SCM_SYMBOL (sym_h5
, "h5");
823 SCM_SYMBOL (sym_h6
, "h6");
824 SCM_SYMBOL (sym_h7
, "h7");
825 SCM_SYMBOL (sym_name
, "name");
826 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
827 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
828 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
829 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
830 SCM_SYMBOL (sym_cpl
, "cpl");
831 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
832 SCM_SYMBOL (sym_slots
, "slots");
833 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
834 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
835 SCM_SYMBOL (sym_nfields
, "nfields");
839 build_class_class_slots ()
841 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
842 SCM_CLASS_CLASS_LAYOUT */
844 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
845 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
846 scm_list_3 (sym_self
, k_class
, scm_class_self
),
847 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
848 scm_list_1 (sym_print
),
849 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
850 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
851 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
852 scm_list_1 (sym_redefined
),
853 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
854 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
855 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
856 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
857 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
858 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
859 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
860 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
861 scm_list_1 (sym_direct_supers
),
862 scm_list_1 (sym_direct_slots
),
863 scm_list_1 (sym_direct_subclasses
),
864 scm_list_1 (sym_direct_methods
),
865 scm_list_1 (sym_cpl
),
866 scm_list_1 (sym_default_slot_definition_class
),
867 scm_list_1 (sym_slots
),
868 scm_list_1 (sym_getters_n_setters
),
869 scm_list_1 (sym_keyword_access
),
870 scm_list_1 (sym_nfields
),
875 create_basic_classes (void)
877 /* SCM slots_of_class = build_class_class_slots (); */
880 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
881 SCM name
= scm_from_locale_symbol ("<class>");
882 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
885 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
886 | SCM_CLASSF_METACLASS
));
888 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
889 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
890 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
891 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
892 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
893 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
894 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
895 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
896 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
897 compute_getters_n_setters (slots_of_class)); */
898 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
900 prep_hashsets (scm_class_class
);
902 DEFVAR(name
, scm_class_class
);
905 name
= scm_from_locale_symbol ("<top>");
906 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
911 DEFVAR(name
, scm_class_top
);
914 name
= scm_from_locale_symbol ("<object>");
915 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
917 scm_list_1 (scm_class_top
),
920 DEFVAR (name
, scm_class_object
);
922 /* <top> <object> and <class> were partially initialized. Correct them here */
923 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
925 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
926 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
929 /******************************************************************************/
931 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
933 "Return @code{#t} if @var{obj} is an instance.")
934 #define FUNC_NAME s_scm_instance_p
936 return scm_from_bool (SCM_INSTANCEP (obj
));
941 /******************************************************************************
943 * Meta object accessors
945 ******************************************************************************/
946 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
948 "Return the class name of @var{obj}.")
949 #define FUNC_NAME s_scm_class_name
951 SCM_VALIDATE_CLASS (1, obj
);
952 return scm_slot_ref (obj
, sym_name
);
956 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
958 "Return the direct superclasses of the class @var{obj}.")
959 #define FUNC_NAME s_scm_class_direct_supers
961 SCM_VALIDATE_CLASS (1, obj
);
962 return scm_slot_ref (obj
, sym_direct_supers
);
966 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
968 "Return the direct slots of the class @var{obj}.")
969 #define FUNC_NAME s_scm_class_direct_slots
971 SCM_VALIDATE_CLASS (1, obj
);
972 return scm_slot_ref (obj
, sym_direct_slots
);
976 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
978 "Return the direct subclasses of the class @var{obj}.")
979 #define FUNC_NAME s_scm_class_direct_subclasses
981 SCM_VALIDATE_CLASS (1, obj
);
982 return scm_slot_ref(obj
, sym_direct_subclasses
);
986 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
988 "Return the direct methods of the class @var{obj}")
989 #define FUNC_NAME s_scm_class_direct_methods
991 SCM_VALIDATE_CLASS (1, obj
);
992 return scm_slot_ref (obj
, sym_direct_methods
);
996 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
998 "Return the class precedence list of the class @var{obj}.")
999 #define FUNC_NAME s_scm_class_precedence_list
1001 SCM_VALIDATE_CLASS (1, obj
);
1002 return scm_slot_ref (obj
, sym_cpl
);
1006 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1008 "Return the slot list of the class @var{obj}.")
1009 #define FUNC_NAME s_scm_class_slots
1011 SCM_VALIDATE_CLASS (1, obj
);
1012 return scm_slot_ref (obj
, sym_slots
);
1016 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1018 "Return the name of the generic function @var{obj}.")
1019 #define FUNC_NAME s_scm_generic_function_name
1021 SCM_VALIDATE_GENERIC (1, obj
);
1022 return scm_procedure_property (obj
, scm_sym_name
);
1026 SCM_SYMBOL (sym_methods
, "methods");
1027 SCM_SYMBOL (sym_extended_by
, "extended-by");
1028 SCM_SYMBOL (sym_extends
, "extends");
1031 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1033 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1034 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1035 while (!scm_is_null (gfs
))
1037 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1038 gfs
= SCM_CDR (gfs
);
1040 return method_lists
;
1044 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1046 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1048 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1049 while (!scm_is_null (gfs
))
1051 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1052 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1055 gfs
= SCM_CDR (gfs
);
1058 return method_lists
;
1061 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1063 "Return the methods of the generic function @var{obj}.")
1064 #define FUNC_NAME s_scm_generic_function_methods
1067 SCM_VALIDATE_GENERIC (1, obj
);
1068 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1069 methods
= fold_downward_gf_methods (methods
, obj
);
1070 return scm_append (methods
);
1074 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1076 "Return the generic function for the method @var{obj}.")
1077 #define FUNC_NAME s_scm_method_generic_function
1079 SCM_VALIDATE_METHOD (1, obj
);
1080 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1084 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1086 "Return specializers of the method @var{obj}.")
1087 #define FUNC_NAME s_scm_method_specializers
1089 SCM_VALIDATE_METHOD (1, obj
);
1090 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1094 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1096 "Return the procedure of the method @var{obj}.")
1097 #define FUNC_NAME s_scm_method_procedure
1099 SCM_VALIDATE_METHOD (1, obj
);
1100 return scm_slot_ref (obj
, sym_procedure
);
1104 /******************************************************************************
1106 * S l o t a c c e s s
1108 ******************************************************************************/
1110 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1112 "Return the unbound value.")
1113 #define FUNC_NAME s_scm_make_unbound
1115 return SCM_GOOPS_UNBOUND
;
1119 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1121 "Return @code{#t} if @var{obj} is unbound.")
1122 #define FUNC_NAME s_scm_unbound_p
1124 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1128 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1129 (SCM value
, SCM obj
),
1130 "Return @var{value} if it is bound, and invoke the\n"
1131 "@var{slot-unbound} method of @var{obj} if it is not.")
1132 #define FUNC_NAME s_scm_assert_bound
1134 if (SCM_GOOPS_UNBOUNDP (value
))
1135 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1140 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1141 (SCM obj
, SCM index
),
1142 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1143 "the value from @var{obj}.")
1144 #define FUNC_NAME s_scm_at_assert_bound_ref
1146 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1147 if (SCM_GOOPS_UNBOUNDP (value
))
1148 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1153 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1154 (SCM obj
, SCM index
),
1155 "Return the slot value with index @var{index} from @var{obj}.")
1156 #define FUNC_NAME s_scm_sys_fast_slot_ref
1158 unsigned long int i
;
1160 SCM_VALIDATE_INSTANCE (1, obj
);
1161 i
= scm_to_unsigned_integer (index
, 0,
1162 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1165 return SCM_SLOT (obj
, i
);
1169 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1170 (SCM obj
, SCM index
, SCM value
),
1171 "Set the slot with index @var{index} in @var{obj} to\n"
1173 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1175 unsigned long int i
;
1177 SCM_VALIDATE_INSTANCE (1, obj
);
1178 i
= scm_to_unsigned_integer (index
, 0,
1179 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1183 SCM_SET_SLOT (obj
, i
, value
);
1185 return SCM_UNSPECIFIED
;
1193 /* In the future, this function will return the effective slot
1194 * definition associated with SLOT_NAME. Now it just returns some of
1195 * the information which will be stored in the effective slot
1200 slot_definition_using_name (SCM
class, SCM slot_name
)
1202 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1203 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1204 if (SCM_CAAR (slots
) == slot_name
)
1205 return SCM_CAR (slots
);
1210 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1211 #define FUNC_NAME "%get-slot-value"
1213 SCM access
= SCM_CDDR (slotdef
);
1215 * - access is an integer (the offset of this slot in the slots vector)
1216 * - otherwise (car access) is the getter function to apply
1218 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1219 * we can just assume fixnums here.
1221 if (SCM_I_INUMP (access
))
1222 /* Don't poke at the slots directly, because scm_struct_ref handles the
1223 access bits for us. */
1224 return scm_struct_ref (obj
, access
);
1226 return scm_call_1 (SCM_CAR (access
), obj
);
1231 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1233 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1234 if (scm_is_true (slotdef
))
1235 return get_slot_value (class, obj
, slotdef
);
1237 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1241 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1242 #define FUNC_NAME "%set-slot-value"
1244 SCM access
= SCM_CDDR (slotdef
);
1246 * - access is an integer (the offset of this slot in the slots vector)
1247 * - otherwise (cadr access) is the setter function to apply
1249 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1250 * we can just assume fixnums here.
1252 if (SCM_I_INUMP (access
))
1253 /* obey permissions bits via going through struct-set! */
1254 scm_struct_set_x (obj
, access
, value
);
1256 /* ((cadr l) obj value) */
1257 scm_call_2 (SCM_CADR (access
), obj
, value
);
1258 return SCM_UNSPECIFIED
;
1263 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1265 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1266 if (scm_is_true (slotdef
))
1267 return set_slot_value (class, obj
, slotdef
, value
);
1269 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1273 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1277 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1278 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1284 /* ======================================== */
1286 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1287 (SCM
class, SCM obj
, SCM slot_name
),
1289 #define FUNC_NAME s_scm_slot_ref_using_class
1293 SCM_VALIDATE_CLASS (1, class);
1294 SCM_VALIDATE_INSTANCE (2, obj
);
1295 SCM_VALIDATE_SYMBOL (3, slot_name
);
1297 res
= get_slot_value_using_name (class, obj
, slot_name
);
1298 if (SCM_GOOPS_UNBOUNDP (res
))
1299 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1305 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1306 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1308 #define FUNC_NAME s_scm_slot_set_using_class_x
1310 SCM_VALIDATE_CLASS (1, class);
1311 SCM_VALIDATE_INSTANCE (2, obj
);
1312 SCM_VALIDATE_SYMBOL (3, slot_name
);
1314 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1319 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1320 (SCM
class, SCM obj
, SCM slot_name
),
1322 #define FUNC_NAME s_scm_slot_bound_using_class_p
1324 SCM_VALIDATE_CLASS (1, class);
1325 SCM_VALIDATE_INSTANCE (2, obj
);
1326 SCM_VALIDATE_SYMBOL (3, slot_name
);
1328 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1334 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1335 (SCM
class, SCM obj
, SCM slot_name
),
1337 #define FUNC_NAME s_scm_slot_exists_using_class_p
1339 SCM_VALIDATE_CLASS (1, class);
1340 SCM_VALIDATE_INSTANCE (2, obj
);
1341 SCM_VALIDATE_SYMBOL (3, slot_name
);
1342 return test_slot_existence (class, obj
, slot_name
);
1347 /* ======================================== */
1349 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1350 (SCM obj
, SCM slot_name
),
1351 "Return the value from @var{obj}'s slot with the name\n"
1353 #define FUNC_NAME s_scm_slot_ref
1357 SCM_VALIDATE_INSTANCE (1, obj
);
1358 TEST_CHANGE_CLASS (obj
, class);
1360 res
= get_slot_value_using_name (class, obj
, slot_name
);
1361 if (SCM_GOOPS_UNBOUNDP (res
))
1362 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1367 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1368 (SCM obj
, SCM slot_name
, SCM value
),
1369 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1370 #define FUNC_NAME s_scm_slot_set_x
1374 SCM_VALIDATE_INSTANCE (1, obj
);
1375 TEST_CHANGE_CLASS(obj
, class);
1377 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1381 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1383 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1384 (SCM obj
, SCM slot_name
),
1385 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1387 #define FUNC_NAME s_scm_slot_bound_p
1391 SCM_VALIDATE_INSTANCE (1, obj
);
1392 TEST_CHANGE_CLASS(obj
, class);
1394 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1402 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1403 (SCM obj
, SCM slot_name
),
1404 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1405 #define FUNC_NAME s_scm_slot_exists_p
1409 SCM_VALIDATE_INSTANCE (1, obj
);
1410 SCM_VALIDATE_SYMBOL (2, slot_name
);
1411 TEST_CHANGE_CLASS (obj
, class);
1413 return test_slot_existence (class, obj
, slot_name
);
1418 /******************************************************************************
1420 * %allocate-instance (the low level instance allocation primitive)
1422 ******************************************************************************/
1424 static void clear_method_cache (SCM
);
1426 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1427 (SCM
class, SCM initargs
),
1428 "Create a new instance of class @var{class} and initialize it\n"
1429 "from the arguments @var{initargs}.")
1430 #define FUNC_NAME s_scm_sys_allocate_instance
1437 SCM_VALIDATE_CLASS (1, class);
1439 /* FIXME: duplicates some of scm_make_struct. */
1441 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1442 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
, "struct");
1444 layout
= SCM_VTABLE_LAYOUT (class);
1446 /* Set all SCM-holding slots to unbound */
1447 for (i
= 0; i
< n
; i
++)
1449 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1451 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1453 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1455 SCM_STRUCT_DATA (obj
)[i
] = 0;
1458 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1459 clear_method_cache (obj
);
1465 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1466 (SCM obj
, SCM setter
),
1468 #define FUNC_NAME s_scm_sys_set_object_setter_x
1470 SCM_ASSERT (SCM_STRUCTP (obj
)
1471 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1475 SCM_SET_GENERIC_SETTER (obj
, setter
);
1476 return SCM_UNSPECIFIED
;
1480 /******************************************************************************
1482 * %modify-instance (used by change-class to modify in place)
1484 ******************************************************************************/
1486 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1489 #define FUNC_NAME s_scm_sys_modify_instance
1491 SCM_VALIDATE_INSTANCE (1, old
);
1492 SCM_VALIDATE_INSTANCE (2, new);
1494 /* Exchange the data contained in old and new. We exchange rather than
1495 * scratch the old value with new to be correct with GC.
1496 * See "Class redefinition protocol above".
1498 SCM_CRITICAL_SECTION_START
;
1500 scm_t_bits word0
, word1
;
1501 word0
= SCM_CELL_WORD_0 (old
);
1502 word1
= SCM_CELL_WORD_1 (old
);
1503 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1504 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1505 SCM_SET_CELL_WORD_0 (new, word0
);
1506 SCM_SET_CELL_WORD_1 (new, word1
);
1508 SCM_CRITICAL_SECTION_END
;
1509 return SCM_UNSPECIFIED
;
1513 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1516 #define FUNC_NAME s_scm_sys_modify_class
1518 SCM_VALIDATE_CLASS (1, old
);
1519 SCM_VALIDATE_CLASS (2, new);
1521 SCM_CRITICAL_SECTION_START
;
1523 scm_t_bits word0
, word1
;
1524 word0
= SCM_CELL_WORD_0 (old
);
1525 word1
= SCM_CELL_WORD_1 (old
);
1526 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1527 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1528 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1529 SCM_SET_CELL_WORD_0 (new, word0
);
1530 SCM_SET_CELL_WORD_1 (new, word1
);
1531 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1533 SCM_CRITICAL_SECTION_END
;
1534 return SCM_UNSPECIFIED
;
1538 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1541 #define FUNC_NAME s_scm_sys_invalidate_class
1543 SCM_VALIDATE_CLASS (1, class);
1544 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1545 return SCM_UNSPECIFIED
;
1549 /* When instances change class, they finally get a new body, but
1550 * before that, they go through purgatory in hell. Odd as it may
1551 * seem, this data structure saves us from eternal suffering in
1552 * infinite recursions.
1555 static scm_t_bits
**hell
;
1556 static long n_hell
= 1; /* one place for the evil one himself */
1557 static long hell_size
= 4;
1558 static SCM hell_mutex
;
1564 for (i
= 1; i
< n_hell
; ++i
)
1565 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1571 go_to_hell (void *o
)
1573 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1574 scm_lock_mutex (hell_mutex
);
1575 if (n_hell
>= hell_size
)
1578 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1580 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1581 scm_unlock_mutex (hell_mutex
);
1585 go_to_heaven (void *o
)
1587 scm_lock_mutex (hell_mutex
);
1588 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1589 scm_unlock_mutex (hell_mutex
);
1593 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1596 purgatory (void *args
)
1598 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1599 SCM_PACK ((scm_t_bits
) args
));
1602 /* This function calls the generic function change-class for all
1603 * instances which aren't currently undergoing class change.
1607 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1610 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1611 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1612 (void *) SCM_UNPACK (obj
));
1615 /******************************************************************************
1621 * GGG E N E R I C F U N C T I O N S
1623 * This implementation provides
1624 * - generic functions (with class specializers)
1627 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1629 ******************************************************************************/
1631 SCM_KEYWORD (k_name
, "name");
1633 SCM_SYMBOL (sym_no_method
, "no-method");
1635 static SCM list_of_no_method
;
1637 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1641 scm_apply_generic (SCM gf
, SCM args
)
1643 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1647 scm_call_generic_0 (SCM gf
)
1649 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1653 scm_call_generic_1 (SCM gf
, SCM a1
)
1655 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1659 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1661 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1665 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1667 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1670 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1672 make_dispatch_procedure (SCM gf
)
1674 static SCM var
= SCM_BOOL_F
;
1675 if (var
== SCM_BOOL_F
)
1676 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1677 sym_delayed_compile
);
1678 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1682 clear_method_cache (SCM gf
)
1684 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1685 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1688 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1691 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1693 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1694 clear_method_cache (gf
);
1695 return SCM_UNSPECIFIED
;
1699 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1702 #define FUNC_NAME s_scm_generic_capability_p
1704 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1705 proc
, SCM_ARG1
, FUNC_NAME
);
1706 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1712 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1715 #define FUNC_NAME s_scm_enable_primitive_generic_x
1717 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1718 while (!scm_is_null (subrs
))
1720 SCM subr
= SCM_CAR (subrs
);
1721 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1722 subr
, SCM_ARGn
, FUNC_NAME
);
1723 *SCM_SUBR_GENERIC (subr
)
1724 = scm_make (scm_list_3 (scm_class_generic
,
1726 SCM_SUBR_NAME (subr
)));
1727 subrs
= SCM_CDR (subrs
);
1729 return SCM_UNSPECIFIED
;
1733 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1734 (SCM subr
, SCM generic
),
1736 #define FUNC_NAME s_scm_set_primitive_generic_x
1738 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1739 subr
, SCM_ARG1
, FUNC_NAME
);
1740 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1741 *SCM_SUBR_GENERIC (subr
) = generic
;
1742 return SCM_UNSPECIFIED
;
1746 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1749 #define FUNC_NAME s_scm_primitive_generic_generic
1751 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1753 if (!*SCM_SUBR_GENERIC (subr
))
1754 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1755 return *SCM_SUBR_GENERIC (subr
);
1757 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1761 typedef struct t_extension
{
1762 struct t_extension
*next
;
1768 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1770 static const char extension_gc_hint
[] = "GOOPS extension";
1772 static t_extension
*extensions
= 0;
1775 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1780 if (!*SCM_SUBR_GENERIC (extended
))
1781 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1782 gf
= *SCM_SUBR_GENERIC (extended
);
1783 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1785 SCM_SUBR_NAME (extension
));
1786 SCM_SET_SUBR_GENERIC (extension
, gext
);
1790 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1792 t_extension
**loc
= &extensions
;
1793 /* Make sure that extensions are placed before their own
1794 * extensions in the extensions list. O(N^2) algorithm, but
1795 * extensions of primitive generics are rare.
1797 while (*loc
&& extension
!= (*loc
)->extended
)
1798 loc
= &(*loc
)->next
;
1800 e
->extended
= extended
;
1801 e
->extension
= extension
;
1807 setup_extended_primitive_generics ()
1811 t_extension
*e
= extensions
;
1812 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1813 extensions
= e
->next
;
1817 /******************************************************************************
1819 * Protocol for calling a generic fumction
1820 * This protocol is roughly equivalent to (parameter are a little bit different
1821 * for efficiency reasons):
1823 * + apply-generic (gf args)
1824 * + compute-applicable-methods (gf args ...)
1825 * + sort-applicable-methods (methods args)
1826 * + apply-methods (gf methods args)
1828 * apply-methods calls make-next-method to build the "continuation" of a a
1829 * method. Applying a next-method will call apply-next-method which in
1830 * turn will call apply again to call effectively the following method.
1832 ******************************************************************************/
1835 applicablep (SCM actual
, SCM formal
)
1837 /* We already know that the cpl is well formed. */
1838 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1842 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1844 register SCM s1
, s2
;
1848 * m1 and m2 can have != length (i.e. one can be one element longer than the
1849 * other when we have a dotted parameter list). For instance, with the call
1852 * (define-method M (a . l) ....)
1853 * (define-method M (a) ....)
1855 * we consider that the second method is more specific.
1857 * BTW, targs is an array of types. We don't need it's size since
1858 * we already know that m1 and m2 are applicable (no risk to go past
1859 * the end of this array).
1862 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1863 if (scm_is_null(s1
)) return 1;
1864 if (scm_is_null(s2
)) return 0;
1865 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1866 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1868 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1869 if (cs1
== SCM_CAR(l
))
1871 if (cs2
== SCM_CAR(l
))
1874 return 0;/* should not occur! */
1877 return 0; /* should not occur! */
1880 #define BUFFSIZE 32 /* big enough for most uses */
1883 scm_i_vector2list (SCM l
, long len
)
1886 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1888 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1889 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1895 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1898 SCM
*v
, vector
= SCM_EOL
;
1899 SCM buffer
[BUFFSIZE
];
1900 SCM save
= method_list
;
1901 scm_t_array_handle handle
;
1903 /* For reasonably sized method_lists we can try to avoid all the
1904 * consing and reorder the list in place...
1905 * This idea is due to David McClain <Dave_McClain@msn.com>
1907 if (size
<= BUFFSIZE
)
1909 for (i
= 0; i
< size
; i
++)
1911 buffer
[i
] = SCM_CAR (method_list
);
1912 method_list
= SCM_CDR (method_list
);
1918 /* Too many elements in method_list to keep everything locally */
1919 vector
= scm_i_vector2list (save
, size
);
1920 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
1923 /* Use a simple shell sort since it is generally faster than qsort on
1924 * small vectors (which is probably mostly the case when we have to
1925 * sort a list of applicable methods).
1927 for (incr
= size
/ 2; incr
; incr
/= 2)
1929 for (i
= incr
; i
< size
; i
++)
1931 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1933 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1937 SCM tmp
= v
[j
+ incr
];
1945 if (size
<= BUFFSIZE
)
1947 /* We did it in locally, so restore the original list (reordered) in-place */
1948 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1950 SCM_SETCAR (method_list
, *v
);
1951 method_list
= SCM_CDR (method_list
);
1956 /* If we are here, that's that we did it the hard way... */
1957 scm_array_handle_release (&handle
);
1958 return scm_vector_to_list (vector
);
1962 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1966 SCM l
, fl
, applicable
= SCM_EOL
;
1968 SCM buffer
[BUFFSIZE
];
1972 scm_t_array_handle handle
;
1974 /* Build the list of arguments types */
1975 if (len
>= BUFFSIZE
)
1977 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1978 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
1981 note that we don't have to work to reset the generation
1982 count. TMP is a new vector anyway, and it is found
1989 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
1990 *p
++ = scm_class_of (SCM_CAR (args
));
1992 /* Build a list of all applicable methods */
1993 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
1995 fl
= SPEC_OF (SCM_CAR (l
));
1996 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1998 if (SCM_INSTANCEP (fl
)
1999 /* We have a dotted argument list */
2000 || (i
>= len
&& scm_is_null (fl
)))
2001 { /* both list exhausted */
2002 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2008 || !applicablep (types
[i
], SCM_CAR (fl
)))
2013 if (len
>= BUFFSIZE
)
2014 scm_array_handle_release (&handle
);
2020 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2021 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2027 : sort_applicable_methods (applicable
, count
, types
));
2031 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2034 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2037 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2038 #define FUNC_NAME s_sys_compute_applicable_methods
2041 SCM_VALIDATE_GENERIC (1, gf
);
2042 n
= scm_ilength (args
);
2043 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2044 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2048 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2049 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
));
2051 /******************************************************************************
2053 * A simple make (which will be redefined later in Scheme)
2054 * This version handles only creation of gf, methods and classes (no instances)
2056 * Since this code will disappear when Goops will be fully booted,
2057 * no precaution is taken to be efficient.
2059 ******************************************************************************/
2061 SCM_KEYWORD (k_setter
, "setter");
2062 SCM_KEYWORD (k_specializers
, "specializers");
2063 SCM_KEYWORD (k_procedure
, "procedure");
2064 SCM_KEYWORD (k_formals
, "formals");
2065 SCM_KEYWORD (k_body
, "body");
2066 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2067 SCM_KEYWORD (k_dsupers
, "dsupers");
2068 SCM_KEYWORD (k_slots
, "slots");
2069 SCM_KEYWORD (k_gf
, "generic-function");
2071 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2073 "Make a new object. @var{args} must contain the class and\n"
2074 "all necessary initialization information.")
2075 #define FUNC_NAME s_scm_make
2078 long len
= scm_ilength (args
);
2080 if (len
<= 0 || (len
& 1) == 0)
2081 SCM_WRONG_NUM_ARGS ();
2083 class = SCM_CAR(args
);
2084 args
= SCM_CDR(args
);
2086 if (class == scm_class_generic
|| class == scm_class_accessor
)
2088 z
= scm_make_struct (class, SCM_INUM0
,
2089 scm_list_4 (SCM_BOOL_F
,
2093 scm_set_procedure_property_x (z
, scm_sym_name
,
2094 scm_get_keyword (k_name
,
2097 clear_method_cache (z
);
2098 if (class == scm_class_accessor
)
2100 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2101 if (scm_is_true (setter
))
2102 scm_sys_set_object_setter_x (z
, setter
);
2107 z
= scm_sys_allocate_instance (class, args
);
2109 if (class == scm_class_method
2110 || class == scm_class_accessor_method
)
2112 SCM_SET_SLOT (z
, scm_si_generic_function
,
2113 scm_i_get_keyword (k_gf
,
2118 SCM_SET_SLOT (z
, scm_si_specializers
,
2119 scm_i_get_keyword (k_specializers
,
2124 SCM_SET_SLOT (z
, scm_si_procedure
,
2125 scm_i_get_keyword (k_procedure
,
2130 SCM_SET_SLOT (z
, scm_si_formals
,
2131 scm_i_get_keyword (k_formals
,
2136 SCM_SET_SLOT (z
, scm_si_body
,
2137 scm_i_get_keyword (k_body
,
2142 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2143 scm_i_get_keyword (k_make_procedure
,
2151 /* In all the others case, make a new class .... No instance here */
2152 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2153 scm_i_get_keyword (k_name
,
2156 scm_from_locale_symbol ("???"),
2158 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2159 scm_i_get_keyword (k_dsupers
,
2164 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2165 scm_i_get_keyword (k_slots
,
2176 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2179 #define FUNC_NAME s_scm_find_method
2182 long len
= scm_ilength (l
);
2185 SCM_WRONG_NUM_ARGS ();
2187 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2188 SCM_VALIDATE_GENERIC (1, gf
);
2189 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2190 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2192 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2196 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2197 (SCM m1
, SCM m2
, SCM targs
),
2198 "Return true if method @var{m1} is more specific than @var{m2} "
2199 "given the argument types (classes) listed in @var{targs}.")
2200 #define FUNC_NAME s_scm_sys_method_more_specific_p
2204 long i
, len
, m1_specs
, m2_specs
;
2205 scm_t_array_handle handle
;
2207 SCM_VALIDATE_METHOD (1, m1
);
2208 SCM_VALIDATE_METHOD (2, m2
);
2210 len
= scm_ilength (targs
);
2211 m1_specs
= scm_ilength (SPEC_OF (m1
));
2212 m2_specs
= scm_ilength (SPEC_OF (m2
));
2213 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2214 targs
, SCM_ARG3
, FUNC_NAME
);
2216 /* Verify that all the arguments of TARGS are classes and place them
2219 v
= scm_c_make_vector (len
, SCM_EOL
);
2220 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2222 for (i
= 0, l
= targs
;
2223 i
< len
&& scm_is_pair (l
);
2224 i
++, l
= SCM_CDR (l
))
2226 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2227 v_elts
[i
] = SCM_CAR (l
);
2229 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2231 scm_array_handle_release (&handle
);
2239 /******************************************************************************
2243 ******************************************************************************/
2246 fix_cpl (SCM c
, SCM before
, SCM after
)
2248 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2249 SCM ls
= scm_c_memq (after
, cpl
);
2250 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2251 if (scm_is_false (ls
))
2252 /* if this condition occurs, fix_cpl should not be applied this way */
2254 SCM_SETCAR (ls
, before
);
2255 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2257 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2258 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2259 SCM g_n_s
= compute_getters_n_setters (slots
);
2260 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2261 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2267 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2269 SCM tmp
= scm_from_locale_symbol (name
);
2271 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2275 : scm_list_1 (super
),
2281 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2284 create_standard_classes (void)
2287 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2288 scm_from_locale_symbol ("specializers"),
2290 scm_from_locale_symbol ("formals"),
2291 scm_from_locale_symbol ("body"),
2292 scm_from_locale_symbol ("make-procedure"),
2294 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2296 k_slot_definition
));
2297 SCM gf_slots
= scm_list_4 (scm_from_locale_symbol ("methods"),
2298 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2301 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2304 scm_from_locale_symbol ("effective-methods"));
2305 SCM setter_slots
= scm_list_1 (sym_setter
);
2306 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2309 /* Foreign class slot classes */
2310 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2311 scm_class_class
, scm_class_top
, SCM_EOL
);
2312 make_stdcls (&scm_class_protected
, "<protected-slot>",
2313 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2314 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2315 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2316 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2317 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2318 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2319 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2320 make_stdcls (&scm_class_self
, "<self-slot>",
2321 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2322 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2324 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2326 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2328 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2330 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2332 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2334 make_stdcls (&scm_class_scm
, "<scm-slot>",
2335 scm_class_class
, scm_class_protected
, SCM_EOL
);
2336 make_stdcls (&scm_class_int
, "<int-slot>",
2337 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2338 make_stdcls (&scm_class_float
, "<float-slot>",
2339 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2340 make_stdcls (&scm_class_double
, "<double-slot>",
2341 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2343 /* Continue initialization of class <class> */
2345 slots
= build_class_class_slots ();
2346 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2347 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2348 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2349 compute_getters_n_setters (slots
));
2351 /* scm_class_generic functions classes */
2352 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2353 scm_class_class
, scm_class_class
, SCM_EOL
);
2354 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2355 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2356 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2357 make_stdcls (&scm_class_method
, "<method>",
2358 scm_class_class
, scm_class_object
, method_slots
);
2359 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2360 scm_class_class
, scm_class_method
, amethod_slots
);
2361 make_stdcls (&scm_class_applicable
, "<applicable>",
2362 scm_class_class
, scm_class_top
, SCM_EOL
);
2363 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2364 scm_class_applicable_struct_class
,
2365 scm_list_2 (scm_class_object
, scm_class_applicable
),
2366 scm_list_1 (sym_procedure
));
2367 make_stdcls (&scm_class_generic
, "<generic>",
2368 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2369 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2370 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2371 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2372 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2373 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2374 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2375 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2376 make_stdcls (&scm_class_accessor
, "<accessor>",
2377 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2378 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2379 make_stdcls (&scm_class_extended_generic_with_setter
,
2380 "<extended-generic-with-setter>",
2381 scm_class_applicable_struct_class
,
2382 scm_list_2 (scm_class_generic_with_setter
,
2383 scm_class_extended_generic
),
2385 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2386 SCM_CLASSF_PURE_GENERIC
);
2387 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2388 scm_class_applicable_struct_class
,
2389 scm_list_2 (scm_class_accessor
,
2390 scm_class_extended_generic_with_setter
),
2392 fix_cpl (scm_class_extended_accessor
,
2393 scm_class_extended_generic
, scm_class_generic
);
2394 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2396 /* Primitive types classes */
2397 make_stdcls (&scm_class_boolean
, "<boolean>",
2398 scm_class_class
, scm_class_top
, SCM_EOL
);
2399 make_stdcls (&scm_class_char
, "<char>",
2400 scm_class_class
, scm_class_top
, SCM_EOL
);
2401 make_stdcls (&scm_class_list
, "<list>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_pair
, "<pair>",
2404 scm_class_class
, scm_class_list
, SCM_EOL
);
2405 make_stdcls (&scm_class_null
, "<null>",
2406 scm_class_class
, scm_class_list
, SCM_EOL
);
2407 make_stdcls (&scm_class_string
, "<string>",
2408 scm_class_class
, scm_class_top
, SCM_EOL
);
2409 make_stdcls (&scm_class_symbol
, "<symbol>",
2410 scm_class_class
, scm_class_top
, SCM_EOL
);
2411 make_stdcls (&scm_class_vector
, "<vector>",
2412 scm_class_class
, scm_class_top
, SCM_EOL
);
2413 make_stdcls (&class_hashtable
, "<hashtable>",
2414 scm_class_class
, scm_class_top
, SCM_EOL
);
2415 make_stdcls (&class_fluid
, "<fluid>",
2416 scm_class_class
, scm_class_top
, SCM_EOL
);
2417 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2418 scm_class_class
, scm_class_top
, SCM_EOL
);
2419 make_stdcls (&scm_class_number
, "<number>",
2420 scm_class_class
, scm_class_top
, SCM_EOL
);
2421 make_stdcls (&scm_class_complex
, "<complex>",
2422 scm_class_class
, scm_class_number
, SCM_EOL
);
2423 make_stdcls (&scm_class_real
, "<real>",
2424 scm_class_class
, scm_class_complex
, SCM_EOL
);
2425 make_stdcls (&scm_class_integer
, "<integer>",
2426 scm_class_class
, scm_class_real
, SCM_EOL
);
2427 make_stdcls (&scm_class_fraction
, "<fraction>",
2428 scm_class_class
, scm_class_real
, SCM_EOL
);
2429 make_stdcls (&scm_class_keyword
, "<keyword>",
2430 scm_class_class
, scm_class_top
, SCM_EOL
);
2431 make_stdcls (&scm_class_unknown
, "<unknown>",
2432 scm_class_class
, scm_class_top
, SCM_EOL
);
2433 make_stdcls (&scm_class_procedure
, "<procedure>",
2434 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2435 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2436 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2437 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2438 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2439 make_stdcls (&scm_class_port
, "<port>",
2440 scm_class_class
, scm_class_top
, SCM_EOL
);
2441 make_stdcls (&scm_class_input_port
, "<input-port>",
2442 scm_class_class
, scm_class_port
, SCM_EOL
);
2443 make_stdcls (&scm_class_output_port
, "<output-port>",
2444 scm_class_class
, scm_class_port
, SCM_EOL
);
2445 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2447 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2451 /**********************************************************************
2455 **********************************************************************/
2458 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2464 sprintf (buffer
, template, type_name
);
2465 name
= scm_from_locale_symbol (buffer
);
2468 name
= SCM_GOOPS_UNBOUND
;
2470 class = scm_permanent_object (scm_basic_make_class (applicablep
2471 ? scm_class_procedure_class
2477 /* Only define name if doesn't already exist. */
2478 if (!SCM_GOOPS_UNBOUNDP (name
)
2479 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2480 DEFVAR (name
, class);
2485 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2488 if (type_name_sym
!= SCM_BOOL_F
)
2490 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2491 scm_symbol_to_string (type_name_sym
),
2492 scm_from_locale_string (">")));
2493 name
= scm_string_to_symbol (name
);
2496 name
= SCM_GOOPS_UNBOUND
;
2498 class = scm_permanent_object (scm_basic_make_class (applicablep
2499 ? scm_class_procedure_class
2505 /* Only define name if doesn't already exist. */
2506 if (!SCM_GOOPS_UNBOUNDP (name
)
2507 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2508 DEFVAR (name
, class);
2513 scm_make_extended_class (char const *type_name
, int applicablep
)
2515 return make_class_from_template ("<%s>",
2517 scm_list_1 (applicablep
2518 ? scm_class_applicable
2524 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2526 return make_class_from_symbol (type_name_sym
,
2527 scm_list_1 (applicablep
2528 ? scm_class_applicable
2534 scm_i_inherit_applicable (SCM c
)
2536 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2538 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2539 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2540 /* patch scm_class_applicable into direct-supers */
2541 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2542 if (scm_is_false (top
))
2543 dsupers
= scm_append (scm_list_2 (dsupers
,
2544 scm_list_1 (scm_class_applicable
)));
2547 SCM_SETCAR (top
, scm_class_applicable
);
2548 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2550 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2551 /* patch scm_class_applicable into cpl */
2552 top
= scm_c_memq (scm_class_top
, cpl
);
2553 if (scm_is_false (top
))
2557 SCM_SETCAR (top
, scm_class_applicable
);
2558 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2560 /* add class to direct-subclasses of scm_class_applicable */
2561 SCM_SET_SLOT (scm_class_applicable
,
2562 scm_si_direct_subclasses
,
2563 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2564 scm_si_direct_subclasses
)));
2569 create_smob_classes (void)
2573 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2574 scm_smob_class
[i
] = 0;
2576 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2578 for (i
= 0; i
< scm_numsmob
; ++i
)
2579 if (!scm_smob_class
[i
])
2580 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2581 scm_smobs
[i
].apply
!= 0);
2585 scm_make_port_classes (long ptobnum
, char *type_name
)
2587 SCM c
, class = make_class_from_template ("<%s-port>",
2589 scm_list_1 (scm_class_port
),
2591 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2592 = make_class_from_template ("<%s-input-port>",
2594 scm_list_2 (class, scm_class_input_port
),
2596 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2597 = make_class_from_template ("<%s-output-port>",
2599 scm_list_2 (class, scm_class_output_port
),
2601 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2603 = make_class_from_template ("<%s-input-output-port>",
2605 scm_list_2 (class, scm_class_input_output_port
),
2607 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2608 SCM_SET_SLOT (c
, scm_si_cpl
,
2609 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2613 create_port_classes (void)
2617 for (i
= 0; i
< scm_numptob
; ++i
)
2618 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2622 make_struct_class (void *closure SCM_UNUSED
,
2623 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2625 SCM sym
= SCM_STRUCT_TABLE_NAME (data
);
2626 if (scm_is_true (sym
))
2628 int applicablep
= SCM_CLASS_FLAGS (vtable
) & SCM_VTABLE_FLAG_APPLICABLE
;
2630 SCM_SET_STRUCT_TABLE_CLASS (data
,
2631 scm_make_extended_class_from_symbol (sym
, applicablep
));
2634 scm_remember_upto_here_2 (data
, vtable
);
2635 return SCM_UNSPECIFIED
;
2639 create_struct_classes (void)
2641 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2644 /**********************************************************************
2648 **********************************************************************/
2653 if (!goops_loaded_p
)
2654 scm_c_resolve_module ("oop goops");
2658 SCM_SYMBOL (sym_o
, "o");
2659 SCM_SYMBOL (sym_x
, "x");
2661 SCM_KEYWORD (k_accessor
, "accessor");
2662 SCM_KEYWORD (k_getter
, "getter");
2665 scm_ensure_accessor (SCM name
)
2667 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2668 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2670 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2671 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2672 k_name
, name
, k_setter
, gf
));
2677 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2680 scm_add_method (SCM gf
, SCM m
)
2682 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2687 * Debugging utilities
2690 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2692 "Return @code{#t} if @var{obj} is a pure generic.")
2693 #define FUNC_NAME s_scm_pure_generic_p
2695 return scm_from_bool (SCM_PUREGENERICP (obj
));
2699 #endif /* GUILE_DEBUG */
2705 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2707 "Announce that GOOPS is loaded and perform initialization\n"
2708 "on the C level which depends on the loaded GOOPS modules.")
2709 #define FUNC_NAME s_scm_sys_goops_loaded
2712 var_compute_applicable_methods
=
2713 scm_permanent_object
2714 (scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
));
2716 scm_permanent_object
2717 (scm_module_variable (scm_module_goops
, sym_slot_unbound
));
2719 scm_permanent_object
2720 (scm_module_variable (scm_module_goops
, sym_slot_missing
));
2722 scm_permanent_object
2723 (scm_module_variable (scm_module_goops
, sym_compute_cpl
));
2724 var_no_applicable_method
=
2725 scm_permanent_object
2726 (scm_module_variable (scm_module_goops
, sym_no_applicable_method
));
2728 scm_permanent_object
2729 (scm_module_variable (scm_module_goops
, sym_change_class
));
2730 setup_extended_primitive_generics ();
2731 return SCM_UNSPECIFIED
;
2735 SCM scm_module_goops
;
2738 scm_init_goops_builtins (void)
2740 scm_module_goops
= scm_current_module ();
2742 /* Not really necessary right now, but who knows...
2744 scm_permanent_object (scm_module_goops
);
2746 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2748 #include "libguile/goops.x"
2750 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2752 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2753 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2755 create_basic_classes ();
2756 create_standard_classes ();
2757 create_smob_classes ();
2758 create_struct_classes ();
2759 create_port_classes ();
2762 SCM name
= scm_from_locale_symbol ("no-applicable-method");
2763 scm_no_applicable_method
2764 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2767 DEFVAR (name
, scm_no_applicable_method
);
2770 return SCM_UNSPECIFIED
;
2776 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2777 scm_init_goops_builtins
);