1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/chars.h"
38 #include "libguile/debug.h"
39 #include "libguile/dynl.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eval.h"
42 #include "libguile/gsubr.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
57 #include "libguile/vm.h"
59 #include "libguile/validate.h"
60 #include "libguile/goops.h"
62 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
65 #define SCM_IN_PCLASS_INDEX 0
66 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
67 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
69 /* this file is a mess. in theory, though, we shouldn't have many SCM references
70 -- most of the references should be to vars. */
72 static SCM var_slot_unbound
= SCM_BOOL_F
;
73 static SCM var_slot_missing
= SCM_BOOL_F
;
74 static SCM var_compute_cpl
= SCM_BOOL_F
;
75 static SCM var_no_applicable_method
= SCM_BOOL_F
;
76 static SCM var_change_class
= SCM_BOOL_F
;
78 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
79 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
80 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
81 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
82 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
83 SCM_SYMBOL (sym_change_class
, "change-class");
85 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
88 /* FIXME, exports should come from the scm file only */
89 #define DEFVAR(v, val) \
90 { scm_module_define (scm_module_goops, (v), (val)); \
91 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
95 /* Class redefinition protocol:
97 A class is represented by a heap header h1 which points to a
98 malloc:ed memory block m1.
100 When a new version of a class is created, a new header h2 and
101 memory block m2 are allocated. The headers h1 and h2 then switch
102 pointers so that h1 refers to m2 and h2 to m1. In this way, names
103 bound to h1 will point to the new class at the same time as h2 will
104 be a handle which the GC will use to free m1.
106 The `redefined' slot of m1 will be set to point to h1. An old
107 instance will have its class pointer (the CAR of the heap header)
108 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
109 the class modification and the new class pointer can be found via
113 #define TEST_CHANGE_CLASS(obj, class) \
115 class = SCM_CLASS_OF (obj); \
116 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
118 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
119 class = SCM_CLASS_OF (obj); \
123 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
124 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
126 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
127 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
129 static int goops_loaded_p
= 0;
130 static scm_t_rstate
*goops_rstate
;
132 /* These variables are filled in by the object system when loaded. */
133 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
134 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
135 SCM scm_class_primitive_generic
;
136 SCM scm_class_vector
, scm_class_null
;
137 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
138 SCM scm_class_unknown
;
139 SCM scm_class_top
, scm_class_object
, scm_class_class
;
140 SCM scm_class_applicable
;
141 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
142 SCM scm_class_generic
, scm_class_generic_with_setter
;
143 SCM scm_class_accessor
;
144 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
145 SCM scm_class_extended_accessor
;
146 SCM scm_class_method
;
147 SCM scm_class_accessor_method
;
148 SCM scm_class_procedure_class
;
149 SCM scm_class_applicable_struct_class
;
150 SCM scm_class_number
, scm_class_list
;
151 SCM scm_class_keyword
;
152 SCM scm_class_port
, scm_class_input_output_port
;
153 SCM scm_class_input_port
, scm_class_output_port
;
154 SCM scm_class_foreign_slot
;
155 SCM scm_class_self
, scm_class_protected
;
156 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
157 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
159 SCM scm_class_int
, scm_class_float
, scm_class_double
;
161 static SCM class_foreign
;
162 static SCM class_hashtable
;
163 static SCM class_fluid
;
164 static SCM class_dynamic_state
;
165 static SCM class_frame
;
166 static SCM class_objcode
;
168 static SCM class_vm_cont
;
169 static SCM class_bytevector
;
170 static SCM class_uvec
;
172 static SCM vtable_class_map
= SCM_BOOL_F
;
174 /* Port classes. Allocate 3 times the maximum number of port types so that
175 input ports, output ports, and in/out ports can be stored at different
176 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
177 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
180 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
182 SCM scm_no_applicable_method
;
184 SCM_SYMBOL (scm_sym_define_public
, "define-public");
186 static SCM
scm_make_unbound (void);
187 static SCM
scm_unbound_p (SCM obj
);
188 static SCM
scm_assert_bound (SCM value
, SCM obj
);
189 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
190 static SCM
scm_sys_goops_loaded (void);
191 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
196 scm_i_define_class_for_vtable (SCM vtable
)
200 if (scm_is_false (vtable_class_map
))
201 vtable_class_map
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);
203 if (scm_is_false (scm_struct_vtable_p (vtable
)))
206 class = scm_hashq_ref (vtable_class_map
, vtable
, SCM_BOOL_F
);
208 if (scm_is_false (class))
210 if (SCM_UNPACK (scm_class_class
))
212 SCM name
= SCM_VTABLE_NAME (vtable
);
213 if (!scm_is_symbol (name
))
214 name
= scm_string_to_symbol (scm_nullstr
);
216 class = scm_make_extended_class_from_symbol
217 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
220 /* `create_struct_classes' will fill this in later. */
223 scm_hashq_set_x (vtable_class_map
, vtable
, class);
229 /* This function is used for efficient type dispatch. */
230 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
232 "Return the class of @var{x}.")
233 #define FUNC_NAME s_scm_class_of
235 switch (SCM_ITAG3 (x
))
239 return scm_class_integer
;
243 return scm_class_char
;
244 else if (scm_is_bool (x
))
245 return scm_class_boolean
;
246 else if (scm_is_null (x
))
247 return scm_class_null
;
249 return scm_class_unknown
;
252 switch (SCM_TYP7 (x
))
254 case scm_tcs_cons_nimcar
:
255 return scm_class_pair
;
257 return scm_class_symbol
;
260 return scm_class_vector
;
261 case scm_tc7_pointer
:
262 return class_foreign
;
263 case scm_tc7_hashtable
:
264 return class_hashtable
;
267 case scm_tc7_dynamic_state
:
268 return class_dynamic_state
;
271 case scm_tc7_objcode
:
272 return class_objcode
;
275 case scm_tc7_vm_cont
:
276 return class_vm_cont
;
277 case scm_tc7_bytevector
:
278 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
279 return class_bytevector
;
283 return scm_class_string
;
285 switch SCM_TYP16 (x
) {
287 return scm_class_integer
;
289 return scm_class_real
;
290 case scm_tc16_complex
:
291 return scm_class_complex
;
292 case scm_tc16_fraction
:
293 return scm_class_fraction
;
295 case scm_tc7_program
:
296 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
297 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
298 return scm_class_primitive_generic
;
300 return scm_class_procedure
;
304 scm_t_bits type
= SCM_TYP16 (x
);
305 if (type
!= scm_tc16_port_with_ps
)
306 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
307 x
= SCM_PORT_WITH_PS_PORT (x
);
308 /* fall through to ports */
311 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
312 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
313 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
314 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
315 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
317 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
318 return SCM_CLASS_OF (x
);
319 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
322 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
323 scm_change_object_class (x
,
324 SCM_CLASS_OF (x
), /* old */
325 SCM_OBJ_CLASS_REDEF (x
)); /* new */
326 return SCM_CLASS_OF (x
);
329 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
332 return scm_class_pair
;
334 return scm_class_unknown
;
340 /* case scm_tc3_unused: */
344 return scm_class_unknown
;
348 /******************************************************************************
352 * This version doesn't fully handle multiple-inheritance. It serves
353 * only for booting classes and will be overloaded in Scheme
355 ******************************************************************************/
358 map (SCM (*proc
) (SCM
), SCM ls
)
360 if (scm_is_null (ls
))
364 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
367 while (!scm_is_null (ls
))
369 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
381 while (!scm_is_null (ls
))
383 SCM el
= SCM_CAR (ls
);
384 if (scm_is_false (scm_c_memq (el
, res
)))
385 res
= scm_cons (el
, res
);
392 compute_cpl (SCM
class)
395 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
398 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
399 SCM ls
= scm_append (scm_acons (class, supers
,
400 map (compute_cpl
, supers
)));
401 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
405 /******************************************************************************
409 ******************************************************************************/
412 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
420 if (!scm_is_symbol (tmp
))
421 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
423 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
424 res
= scm_cons (SCM_CAR (l
), res
);
425 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
428 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
432 build_slots_list (SCM dslots
, SCM cpl
)
434 register SCM res
= dslots
;
436 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
437 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
438 scm_si_direct_slots
),
441 /* res contains a list of slots. Remove slots which appears more than once */
442 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
449 while (!scm_is_null (ls
))
451 if (!scm_is_pair (SCM_CAR (ls
)))
452 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
459 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
461 "Return a list consisting of the names of all slots belonging to\n"
462 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
464 #define FUNC_NAME s_scm_sys_compute_slots
466 SCM_VALIDATE_CLASS (1, class);
467 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
468 SCM_SLOT (class, scm_si_cpl
));
473 /******************************************************************************
475 * compute-getters-n-setters
477 * This version doesn't handle slot options. It serves only for booting
478 * classes and will be overloaded in Scheme.
480 ******************************************************************************/
482 SCM_KEYWORD (k_init_value
, "init-value");
483 SCM_KEYWORD (k_init_thunk
, "init-thunk");
486 compute_getters_n_setters (SCM slots
)
492 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
494 SCM init
= SCM_BOOL_F
;
495 SCM options
= SCM_CDAR (slots
);
496 if (!scm_is_null (options
))
498 init
= scm_get_keyword (k_init_value
, options
, SCM_PACK (0));
499 if (SCM_UNPACK (init
))
501 init
= scm_primitive_eval (scm_list_3 (scm_sym_lambda
,
503 scm_list_2 (scm_sym_quote
,
507 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
509 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
511 scm_from_int (i
++))),
513 cdrloc
= SCM_CDRLOC (*cdrloc
);
518 /******************************************************************************
522 ******************************************************************************/
524 /*fixme* Manufacture keywords in advance */
526 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
530 for (i
= 0; i
!= len
; i
+= 2)
532 SCM obj
= SCM_CAR (l
);
534 if (!scm_is_keyword (obj
))
535 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
536 else if (scm_is_eq (obj
, key
))
542 return default_value
;
546 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
547 (SCM key
, SCM l
, SCM default_value
),
548 "Determine an associated value for the keyword @var{key} from\n"
549 "the list @var{l}. The list @var{l} has to consist of an even\n"
550 "number of elements, where, starting with the first, every\n"
551 "second element is a keyword, followed by its associated value.\n"
552 "If @var{l} does not hold a value for @var{key}, the value\n"
553 "@var{default_value} is returned.")
554 #define FUNC_NAME s_scm_get_keyword
558 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
559 len
= scm_ilength (l
);
560 if (len
< 0 || len
% 2 == 1)
561 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
563 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
568 SCM_KEYWORD (k_init_keyword
, "init-keyword");
570 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
571 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
573 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
574 (SCM obj
, SCM initargs
),
575 "Initialize the object @var{obj} with the given arguments\n"
577 #define FUNC_NAME s_scm_sys_initialize_object
579 SCM tmp
, get_n_set
, slots
;
580 SCM
class = SCM_CLASS_OF (obj
);
583 SCM_VALIDATE_INSTANCE (1, obj
);
584 n_initargs
= scm_ilength (initargs
);
585 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
587 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
588 slots
= SCM_SLOT (class, scm_si_slots
);
590 /* See for each slot how it must be initialized */
592 !scm_is_null (slots
);
593 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
595 SCM slot_name
= SCM_CAR (slots
);
596 SCM slot_value
= SCM_PACK (0);
598 if (!scm_is_null (SCM_CDR (slot_name
)))
600 /* This slot admits (perhaps) to be initialized at creation time */
601 long n
= scm_ilength (SCM_CDR (slot_name
));
602 if (n
& 1) /* odd or -1 */
603 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
604 scm_list_1 (slot_name
));
605 tmp
= scm_i_get_keyword (k_init_keyword
,
610 slot_name
= SCM_CAR (slot_name
);
611 if (SCM_UNPACK (tmp
))
613 /* an initarg was provided for this slot */
614 if (!scm_is_keyword (tmp
))
615 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
617 slot_value
= scm_i_get_keyword (tmp
,
625 if (SCM_UNPACK (slot_value
))
626 /* set slot to provided value */
627 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
630 /* set slot to its :init-form if it exists */
631 tmp
= SCM_CADAR (get_n_set
);
632 if (scm_is_true (tmp
))
634 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
635 if (SCM_GOOPS_UNBOUNDP (slot_value
))
636 set_slot_value (class,
648 /* NOTE: The following macros are interdependent with code
649 * in goops.scm:compute-getters-n-setters
651 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
652 (SCM_I_INUMP (SCM_CDDR (gns)) \
653 || (scm_is_pair (SCM_CDDR (gns)) \
654 && scm_is_pair (SCM_CDDDR (gns)) \
655 && scm_is_pair (SCM_CDDDDR (gns))))
656 #define SCM_GNS_INDEX(gns) \
657 (SCM_I_INUMP (SCM_CDDR (gns)) \
658 ? SCM_I_INUM (SCM_CDDR (gns)) \
659 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
660 #define SCM_GNS_SIZE(gns) \
661 (SCM_I_INUMP (SCM_CDDR (gns)) \
663 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
665 SCM_KEYWORD (k_class
, "class");
666 SCM_KEYWORD (k_allocation
, "allocation");
667 SCM_KEYWORD (k_instance
, "instance");
669 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
672 #define FUNC_NAME s_scm_sys_prep_layout_x
674 SCM slots
, getters_n_setters
, nfields
;
675 unsigned long int n
, i
;
679 SCM_VALIDATE_INSTANCE (1, class);
680 slots
= SCM_SLOT (class, scm_si_slots
);
681 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
682 nfields
= SCM_SLOT (class, scm_si_nfields
);
683 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
684 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
685 scm_list_1 (nfields
));
686 n
= 2 * SCM_I_INUM (nfields
);
687 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
688 && SCM_SUBCLASSP (class, scm_class_class
))
689 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
690 scm_list_1 (nfields
));
692 layout
= scm_i_make_string (n
, &s
, 0);
694 while (scm_is_pair (getters_n_setters
))
696 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
699 int len
, index
, size
;
702 if (i
>= n
|| !scm_is_pair (slots
))
705 /* extract slot type */
706 len
= scm_ilength (SCM_CDAR (slots
));
707 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
708 len
, SCM_BOOL_F
, FUNC_NAME
);
709 /* determine slot GC protection and access mode */
710 if (scm_is_false (type
))
717 if (!SCM_CLASSP (type
))
718 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
719 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
721 if (SCM_SUBCLASSP (type
, scm_class_self
))
723 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
728 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
730 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
732 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
744 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
745 if (index
!= (i
>> 1))
747 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
755 slots
= SCM_CDR (slots
);
756 getters_n_setters
= SCM_CDR (getters_n_setters
);
758 if (!scm_is_null (slots
))
761 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
763 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
764 return SCM_UNSPECIFIED
;
768 static void prep_hashsets (SCM
);
770 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
771 (SCM
class, SCM dsupers
),
773 #define FUNC_NAME s_scm_sys_inherit_magic_x
775 SCM_VALIDATE_INSTANCE (1, class);
776 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
777 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
779 prep_hashsets (class);
781 return SCM_UNSPECIFIED
;
786 prep_hashsets (SCM
class)
790 for (i
= 0; i
< 8; ++i
)
791 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
794 /******************************************************************************/
797 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
799 SCM z
, cpl
, slots
, nfields
, g_n_s
;
801 /* Allocate one instance */
802 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
804 /* Initialize its slots */
805 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
806 cpl
= compute_cpl (z
);
807 slots
= build_slots_list (maplist (dslots
), cpl
);
808 nfields
= scm_from_int (scm_ilength (slots
));
809 g_n_s
= compute_getters_n_setters (slots
);
811 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
812 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
813 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
814 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
815 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
816 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
817 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
818 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
819 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
821 /* Add this class in the direct-subclasses slot of dsupers */
824 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
825 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
826 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
827 scm_si_direct_subclasses
)));
834 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
836 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
837 scm_sys_prep_layout_x (z
);
838 scm_sys_inherit_magic_x (z
, dsupers
);
842 /******************************************************************************/
844 SCM_SYMBOL (sym_layout
, "layout");
845 SCM_SYMBOL (sym_flags
, "flags");
846 SCM_SYMBOL (sym_self
, "%self");
847 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
848 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
849 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
850 SCM_SYMBOL (sym_print
, "print");
851 SCM_SYMBOL (sym_procedure
, "procedure");
852 SCM_SYMBOL (sym_setter
, "setter");
853 SCM_SYMBOL (sym_redefined
, "redefined");
854 SCM_SYMBOL (sym_h0
, "h0");
855 SCM_SYMBOL (sym_h1
, "h1");
856 SCM_SYMBOL (sym_h2
, "h2");
857 SCM_SYMBOL (sym_h3
, "h3");
858 SCM_SYMBOL (sym_h4
, "h4");
859 SCM_SYMBOL (sym_h5
, "h5");
860 SCM_SYMBOL (sym_h6
, "h6");
861 SCM_SYMBOL (sym_h7
, "h7");
862 SCM_SYMBOL (sym_name
, "name");
863 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
864 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
865 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
866 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
867 SCM_SYMBOL (sym_cpl
, "cpl");
868 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
869 SCM_SYMBOL (sym_slots
, "slots");
870 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
871 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
872 SCM_SYMBOL (sym_nfields
, "nfields");
876 build_class_class_slots ()
878 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
879 SCM_CLASS_CLASS_LAYOUT */
881 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
882 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
883 scm_list_3 (sym_self
, k_class
, scm_class_self
),
884 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
885 scm_list_1 (sym_print
),
886 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
887 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
888 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
889 scm_list_1 (sym_redefined
),
890 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
891 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
892 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
893 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
894 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
895 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
896 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
897 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
898 scm_list_1 (sym_direct_supers
),
899 scm_list_1 (sym_direct_slots
),
900 scm_list_1 (sym_direct_subclasses
),
901 scm_list_1 (sym_direct_methods
),
902 scm_list_1 (sym_cpl
),
903 scm_list_1 (sym_default_slot_definition_class
),
904 scm_list_1 (sym_slots
),
905 scm_list_1 (sym_getters_n_setters
),
906 scm_list_1 (sym_keyword_access
),
907 scm_list_1 (sym_nfields
),
912 create_basic_classes (void)
914 /* SCM slots_of_class = build_class_class_slots (); */
917 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
918 SCM name
= scm_from_latin1_symbol ("<class>");
919 scm_class_class
= scm_make_vtable_vtable (cs
, SCM_INUM0
, SCM_EOL
);
920 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
921 | SCM_CLASSF_METACLASS
));
923 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
924 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
925 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
926 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
927 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
928 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
929 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
930 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
931 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
932 compute_getters_n_setters (slots_of_class)); */
933 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
935 prep_hashsets (scm_class_class
);
937 DEFVAR(name
, scm_class_class
);
940 name
= scm_from_latin1_symbol ("<top>");
941 scm_class_top
= scm_basic_make_class (scm_class_class
, name
,
944 DEFVAR(name
, scm_class_top
);
947 name
= scm_from_latin1_symbol ("<object>");
948 scm_class_object
= scm_basic_make_class (scm_class_class
, name
,
949 scm_list_1 (scm_class_top
), SCM_EOL
);
951 DEFVAR (name
, scm_class_object
);
953 /* <top> <object> and <class> were partially initialized. Correct them here */
954 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
956 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
957 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
960 /******************************************************************************/
962 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
964 "Return @code{#t} if @var{obj} is an instance.")
965 #define FUNC_NAME s_scm_instance_p
967 return scm_from_bool (SCM_INSTANCEP (obj
));
972 /******************************************************************************
974 * Meta object accessors
976 ******************************************************************************/
977 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
979 "Return the class name of @var{obj}.")
980 #define FUNC_NAME s_scm_class_name
982 SCM_VALIDATE_CLASS (1, obj
);
983 return scm_slot_ref (obj
, sym_name
);
987 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
989 "Return the direct superclasses of the class @var{obj}.")
990 #define FUNC_NAME s_scm_class_direct_supers
992 SCM_VALIDATE_CLASS (1, obj
);
993 return scm_slot_ref (obj
, sym_direct_supers
);
997 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
999 "Return the direct slots of the class @var{obj}.")
1000 #define FUNC_NAME s_scm_class_direct_slots
1002 SCM_VALIDATE_CLASS (1, obj
);
1003 return scm_slot_ref (obj
, sym_direct_slots
);
1007 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1009 "Return the direct subclasses of the class @var{obj}.")
1010 #define FUNC_NAME s_scm_class_direct_subclasses
1012 SCM_VALIDATE_CLASS (1, obj
);
1013 return scm_slot_ref(obj
, sym_direct_subclasses
);
1017 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1019 "Return the direct methods of the class @var{obj}")
1020 #define FUNC_NAME s_scm_class_direct_methods
1022 SCM_VALIDATE_CLASS (1, obj
);
1023 return scm_slot_ref (obj
, sym_direct_methods
);
1027 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1029 "Return the class precedence list of the class @var{obj}.")
1030 #define FUNC_NAME s_scm_class_precedence_list
1032 SCM_VALIDATE_CLASS (1, obj
);
1033 return scm_slot_ref (obj
, sym_cpl
);
1037 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1039 "Return the slot list of the class @var{obj}.")
1040 #define FUNC_NAME s_scm_class_slots
1042 SCM_VALIDATE_CLASS (1, obj
);
1043 return scm_slot_ref (obj
, sym_slots
);
1047 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1049 "Return the name of the generic function @var{obj}.")
1050 #define FUNC_NAME s_scm_generic_function_name
1052 SCM_VALIDATE_GENERIC (1, obj
);
1053 return scm_procedure_property (obj
, scm_sym_name
);
1057 SCM_SYMBOL (sym_methods
, "methods");
1058 SCM_SYMBOL (sym_extended_by
, "extended-by");
1059 SCM_SYMBOL (sym_extends
, "extends");
1062 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1064 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1065 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1066 while (!scm_is_null (gfs
))
1068 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1069 gfs
= SCM_CDR (gfs
);
1071 return method_lists
;
1075 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1077 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1079 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1080 while (!scm_is_null (gfs
))
1082 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1083 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1086 gfs
= SCM_CDR (gfs
);
1089 return method_lists
;
1092 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1094 "Return the methods of the generic function @var{obj}.")
1095 #define FUNC_NAME s_scm_generic_function_methods
1098 SCM_VALIDATE_GENERIC (1, obj
);
1099 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1100 methods
= fold_downward_gf_methods (methods
, obj
);
1101 return scm_append (methods
);
1105 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1107 "Return the generic function for the method @var{obj}.")
1108 #define FUNC_NAME s_scm_method_generic_function
1110 SCM_VALIDATE_METHOD (1, obj
);
1111 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
1115 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1117 "Return specializers of the method @var{obj}.")
1118 #define FUNC_NAME s_scm_method_specializers
1120 SCM_VALIDATE_METHOD (1, obj
);
1121 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
1125 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1127 "Return the procedure of the method @var{obj}.")
1128 #define FUNC_NAME s_scm_method_procedure
1130 SCM_VALIDATE_METHOD (1, obj
);
1131 return scm_slot_ref (obj
, sym_procedure
);
1135 /******************************************************************************
1137 * S l o t a c c e s s
1139 ******************************************************************************/
1141 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1143 "Return the unbound value.")
1144 #define FUNC_NAME s_scm_make_unbound
1146 return SCM_GOOPS_UNBOUND
;
1150 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1152 "Return @code{#t} if @var{obj} is unbound.")
1153 #define FUNC_NAME s_scm_unbound_p
1155 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1159 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1160 (SCM value
, SCM obj
),
1161 "Return @var{value} if it is bound, and invoke the\n"
1162 "@var{slot-unbound} method of @var{obj} if it is not.")
1163 #define FUNC_NAME s_scm_assert_bound
1165 if (SCM_GOOPS_UNBOUNDP (value
))
1166 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1171 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1172 (SCM obj
, SCM index
),
1173 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1174 "the value from @var{obj}.")
1175 #define FUNC_NAME s_scm_at_assert_bound_ref
1177 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1178 if (SCM_GOOPS_UNBOUNDP (value
))
1179 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1184 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1185 (SCM obj
, SCM index
),
1186 "Return the slot value with index @var{index} from @var{obj}.")
1187 #define FUNC_NAME s_scm_sys_fast_slot_ref
1191 SCM_VALIDATE_INSTANCE (1, obj
);
1192 i
= scm_to_unsigned_integer (index
, 0,
1193 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1196 return SCM_SLOT (obj
, i
);
1200 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1201 (SCM obj
, SCM index
, SCM value
),
1202 "Set the slot with index @var{index} in @var{obj} to\n"
1204 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1208 SCM_VALIDATE_INSTANCE (1, obj
);
1209 i
= scm_to_unsigned_integer (index
, 0,
1210 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1214 SCM_SET_SLOT (obj
, i
, value
);
1216 return SCM_UNSPECIFIED
;
1224 /* In the future, this function will return the effective slot
1225 * definition associated with SLOT_NAME. Now it just returns some of
1226 * the information which will be stored in the effective slot
1231 slot_definition_using_name (SCM
class, SCM slot_name
)
1233 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1234 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1235 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
1236 return SCM_CAR (slots
);
1241 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1242 #define FUNC_NAME "%get-slot-value"
1244 SCM access
= SCM_CDDR (slotdef
);
1246 * - access is an integer (the offset of this slot in the slots vector)
1247 * - otherwise (car access) is the getter 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 /* Don't poke at the slots directly, because scm_struct_ref handles the
1254 access bits for us. */
1255 return scm_struct_ref (obj
, access
);
1257 return scm_call_1 (SCM_CAR (access
), obj
);
1262 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1264 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1265 if (scm_is_true (slotdef
))
1266 return get_slot_value (class, obj
, slotdef
);
1268 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1272 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1273 #define FUNC_NAME "%set-slot-value"
1275 SCM access
= SCM_CDDR (slotdef
);
1277 * - access is an integer (the offset of this slot in the slots vector)
1278 * - otherwise (cadr access) is the setter function to apply
1280 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1281 * we can just assume fixnums here.
1283 if (SCM_I_INUMP (access
))
1284 /* obey permissions bits via going through struct-set! */
1285 scm_struct_set_x (obj
, access
, value
);
1287 /* ((cadr l) obj value) */
1288 scm_call_2 (SCM_CADR (access
), obj
, value
);
1289 return SCM_UNSPECIFIED
;
1294 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1296 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1297 if (scm_is_true (slotdef
))
1298 return set_slot_value (class, obj
, slotdef
, value
);
1300 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1304 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1308 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1309 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1315 /* ======================================== */
1317 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1318 (SCM
class, SCM obj
, SCM slot_name
),
1320 #define FUNC_NAME s_scm_slot_ref_using_class
1324 SCM_VALIDATE_CLASS (1, class);
1325 SCM_VALIDATE_INSTANCE (2, obj
);
1326 SCM_VALIDATE_SYMBOL (3, slot_name
);
1328 res
= get_slot_value_using_name (class, obj
, slot_name
);
1329 if (SCM_GOOPS_UNBOUNDP (res
))
1330 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1336 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1337 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1339 #define FUNC_NAME s_scm_slot_set_using_class_x
1341 SCM_VALIDATE_CLASS (1, class);
1342 SCM_VALIDATE_INSTANCE (2, obj
);
1343 SCM_VALIDATE_SYMBOL (3, slot_name
);
1345 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1350 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1351 (SCM
class, SCM obj
, SCM slot_name
),
1353 #define FUNC_NAME s_scm_slot_bound_using_class_p
1355 SCM_VALIDATE_CLASS (1, class);
1356 SCM_VALIDATE_INSTANCE (2, obj
);
1357 SCM_VALIDATE_SYMBOL (3, slot_name
);
1359 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1365 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1366 (SCM
class, SCM obj
, SCM slot_name
),
1368 #define FUNC_NAME s_scm_slot_exists_using_class_p
1370 SCM_VALIDATE_CLASS (1, class);
1371 SCM_VALIDATE_INSTANCE (2, obj
);
1372 SCM_VALIDATE_SYMBOL (3, slot_name
);
1373 return test_slot_existence (class, obj
, slot_name
);
1378 /* ======================================== */
1380 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1381 (SCM obj
, SCM slot_name
),
1382 "Return the value from @var{obj}'s slot with the name\n"
1384 #define FUNC_NAME s_scm_slot_ref
1388 SCM_VALIDATE_INSTANCE (1, obj
);
1389 TEST_CHANGE_CLASS (obj
, class);
1391 res
= get_slot_value_using_name (class, obj
, slot_name
);
1392 if (SCM_GOOPS_UNBOUNDP (res
))
1393 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1398 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1399 (SCM obj
, SCM slot_name
, SCM value
),
1400 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1401 #define FUNC_NAME s_scm_slot_set_x
1405 SCM_VALIDATE_INSTANCE (1, obj
);
1406 TEST_CHANGE_CLASS(obj
, class);
1408 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1412 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1414 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1415 (SCM obj
, SCM slot_name
),
1416 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1418 #define FUNC_NAME s_scm_slot_bound_p
1422 SCM_VALIDATE_INSTANCE (1, obj
);
1423 TEST_CHANGE_CLASS(obj
, class);
1425 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1433 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1434 (SCM obj
, SCM slot_name
),
1435 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1436 #define FUNC_NAME s_scm_slot_exists_p
1440 SCM_VALIDATE_INSTANCE (1, obj
);
1441 SCM_VALIDATE_SYMBOL (2, slot_name
);
1442 TEST_CHANGE_CLASS (obj
, class);
1444 return test_slot_existence (class, obj
, slot_name
);
1449 /******************************************************************************
1451 * %allocate-instance (the low level instance allocation primitive)
1453 ******************************************************************************/
1455 static void clear_method_cache (SCM
);
1457 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1458 (SCM
class, SCM initargs
),
1459 "Create a new instance of class @var{class} and initialize it\n"
1460 "from the arguments @var{initargs}.")
1461 #define FUNC_NAME s_scm_sys_allocate_instance
1464 scm_t_signed_bits n
, i
;
1467 SCM_VALIDATE_CLASS (1, class);
1469 /* FIXME: duplicates some of scm_make_struct. */
1471 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1472 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1474 layout
= SCM_VTABLE_LAYOUT (class);
1476 /* Set all SCM-holding slots to unbound */
1477 for (i
= 0; i
< n
; i
++)
1479 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1481 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1483 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1485 SCM_STRUCT_DATA (obj
)[i
] = 0;
1488 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1489 clear_method_cache (obj
);
1495 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1496 (SCM obj
, SCM setter
),
1498 #define FUNC_NAME s_scm_sys_set_object_setter_x
1500 SCM_ASSERT (SCM_STRUCTP (obj
)
1501 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1505 SCM_SET_GENERIC_SETTER (obj
, setter
);
1506 return SCM_UNSPECIFIED
;
1510 /******************************************************************************
1512 * %modify-instance (used by change-class to modify in place)
1514 ******************************************************************************/
1516 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1519 #define FUNC_NAME s_scm_sys_modify_instance
1521 SCM_VALIDATE_INSTANCE (1, old
);
1522 SCM_VALIDATE_INSTANCE (2, new);
1524 /* Exchange the data contained in old and new. We exchange rather than
1525 * scratch the old value with new to be correct with GC.
1526 * See "Class redefinition protocol above".
1528 SCM_CRITICAL_SECTION_START
;
1530 scm_t_bits word0
, word1
;
1531 word0
= SCM_CELL_WORD_0 (old
);
1532 word1
= SCM_CELL_WORD_1 (old
);
1533 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1534 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1535 SCM_SET_CELL_WORD_0 (new, word0
);
1536 SCM_SET_CELL_WORD_1 (new, word1
);
1538 SCM_CRITICAL_SECTION_END
;
1539 return SCM_UNSPECIFIED
;
1543 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1546 #define FUNC_NAME s_scm_sys_modify_class
1548 SCM_VALIDATE_CLASS (1, old
);
1549 SCM_VALIDATE_CLASS (2, new);
1551 SCM_CRITICAL_SECTION_START
;
1553 scm_t_bits word0
, word1
;
1554 word0
= SCM_CELL_WORD_0 (old
);
1555 word1
= SCM_CELL_WORD_1 (old
);
1556 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1557 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1558 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1559 SCM_SET_CELL_WORD_0 (new, word0
);
1560 SCM_SET_CELL_WORD_1 (new, word1
);
1561 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1563 SCM_CRITICAL_SECTION_END
;
1564 return SCM_UNSPECIFIED
;
1568 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1571 #define FUNC_NAME s_scm_sys_invalidate_class
1573 SCM_VALIDATE_CLASS (1, class);
1574 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1575 return SCM_UNSPECIFIED
;
1579 /* When instances change class, they finally get a new body, but
1580 * before that, they go through purgatory in hell. Odd as it may
1581 * seem, this data structure saves us from eternal suffering in
1582 * infinite recursions.
1585 static scm_t_bits
**hell
;
1586 static long n_hell
= 1; /* one place for the evil one himself */
1587 static long hell_size
= 4;
1588 static SCM hell_mutex
;
1594 for (i
= 1; i
< n_hell
; ++i
)
1595 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1601 go_to_hell (void *o
)
1604 scm_lock_mutex (hell_mutex
);
1605 if (n_hell
>= hell_size
)
1608 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1610 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1611 scm_unlock_mutex (hell_mutex
);
1615 go_to_heaven (void *o
)
1618 scm_lock_mutex (hell_mutex
);
1619 hell
[burnin (obj
)] = hell
[--n_hell
];
1620 scm_unlock_mutex (hell_mutex
);
1624 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1627 purgatory (SCM obj
, SCM new_class
)
1629 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1632 /* This function calls the generic function change-class for all
1633 * instances which aren't currently undergoing class change.
1637 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1641 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1642 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1643 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1644 purgatory (obj
, new_class
);
1649 /******************************************************************************
1655 * GGG E N E R I C F U N C T I O N S
1657 * This implementation provides
1658 * - generic functions (with class specializers)
1661 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1663 ******************************************************************************/
1665 SCM_KEYWORD (k_name
, "name");
1667 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1671 scm_apply_generic (SCM gf
, SCM args
)
1673 return scm_apply (SCM_STRUCT_PROCEDURE (gf
), args
, SCM_EOL
);
1677 scm_call_generic_0 (SCM gf
)
1679 return scm_call_0 (SCM_STRUCT_PROCEDURE (gf
));
1683 scm_call_generic_1 (SCM gf
, SCM a1
)
1685 return scm_call_1 (SCM_STRUCT_PROCEDURE (gf
), a1
);
1689 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1691 return scm_call_2 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
);
1695 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1697 return scm_call_3 (SCM_STRUCT_PROCEDURE (gf
), a1
, a2
, a3
);
1700 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1702 make_dispatch_procedure (SCM gf
)
1704 static SCM var
= SCM_BOOL_F
;
1705 if (scm_is_false (var
))
1706 var
= scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
1707 sym_delayed_compile
);
1708 return scm_call_1 (SCM_VARIABLE_REF (var
), gf
);
1712 clear_method_cache (SCM gf
)
1714 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1715 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1718 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1721 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1723 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1724 clear_method_cache (gf
);
1725 return SCM_UNSPECIFIED
;
1729 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1732 #define FUNC_NAME s_scm_generic_capability_p
1734 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1735 proc
, SCM_ARG1
, FUNC_NAME
);
1736 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1740 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1743 #define FUNC_NAME s_scm_enable_primitive_generic_x
1745 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1746 while (!scm_is_null (subrs
))
1748 SCM subr
= SCM_CAR (subrs
);
1749 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1750 SCM_SET_SUBR_GENERIC (subr
,
1751 scm_make (scm_list_3 (scm_class_generic
,
1753 SCM_SUBR_NAME (subr
))));
1754 subrs
= SCM_CDR (subrs
);
1756 return SCM_UNSPECIFIED
;
1760 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1761 (SCM subr
, SCM generic
),
1763 #define FUNC_NAME s_scm_set_primitive_generic_x
1765 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1766 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1767 SCM_SET_SUBR_GENERIC (subr
, generic
);
1768 return SCM_UNSPECIFIED
;
1772 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1775 #define FUNC_NAME s_scm_primitive_generic_generic
1777 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1779 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1780 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1781 return *SCM_SUBR_GENERIC (subr
);
1783 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1787 typedef struct t_extension
{
1788 struct t_extension
*next
;
1794 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1796 static const char extension_gc_hint
[] = "GOOPS extension";
1798 static t_extension
*extensions
= 0;
1801 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1806 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1807 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1808 gf
= *SCM_SUBR_GENERIC (extended
);
1809 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1811 SCM_SUBR_NAME (extension
));
1812 SCM_SET_SUBR_GENERIC (extension
, gext
);
1816 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1818 t_extension
**loc
= &extensions
;
1819 /* Make sure that extensions are placed before their own
1820 * extensions in the extensions list. O(N^2) algorithm, but
1821 * extensions of primitive generics are rare.
1823 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1824 loc
= &(*loc
)->next
;
1826 e
->extended
= extended
;
1827 e
->extension
= extension
;
1833 setup_extended_primitive_generics ()
1837 t_extension
*e
= extensions
;
1838 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1839 extensions
= e
->next
;
1843 /******************************************************************************
1845 * Protocol for calling a generic fumction
1846 * This protocol is roughly equivalent to (parameter are a little bit different
1847 * for efficiency reasons):
1849 * + apply-generic (gf args)
1850 * + compute-applicable-methods (gf args ...)
1851 * + sort-applicable-methods (methods args)
1852 * + apply-methods (gf methods args)
1854 * apply-methods calls make-next-method to build the "continuation" of a a
1855 * method. Applying a next-method will call apply-next-method which in
1856 * turn will call apply again to call effectively the following method.
1858 ******************************************************************************/
1861 applicablep (SCM actual
, SCM formal
)
1863 /* We already know that the cpl is well formed. */
1864 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1868 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1870 register SCM s1
, s2
;
1874 * m1 and m2 can have != length (i.e. one can be one element longer than the
1875 * other when we have a dotted parameter list). For instance, with the call
1878 * (define-method M (a . l) ....)
1879 * (define-method M (a) ....)
1881 * we consider that the second method is more specific.
1883 * BTW, targs is an array of types. We don't need it's size since
1884 * we already know that m1 and m2 are applicable (no risk to go past
1885 * the end of this array).
1888 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1889 if (scm_is_null(s1
)) return 1;
1890 if (scm_is_null(s2
)) return 0;
1891 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
1892 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1894 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1895 if (scm_is_eq (cs1
, SCM_CAR (l
)))
1897 if (scm_is_eq (cs2
, SCM_CAR (l
)))
1900 return 0;/* should not occur! */
1903 return 0; /* should not occur! */
1906 #define BUFFSIZE 32 /* big enough for most uses */
1909 scm_i_vector2list (SCM l
, long len
)
1912 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1914 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1915 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1921 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1924 SCM
*v
, vector
= SCM_EOL
;
1925 SCM buffer
[BUFFSIZE
];
1926 SCM save
= method_list
;
1927 scm_t_array_handle handle
;
1929 /* For reasonably sized method_lists we can try to avoid all the
1930 * consing and reorder the list in place...
1931 * This idea is due to David McClain <Dave_McClain@msn.com>
1933 if (size
<= BUFFSIZE
)
1935 for (i
= 0; i
< size
; i
++)
1937 buffer
[i
] = SCM_CAR (method_list
);
1938 method_list
= SCM_CDR (method_list
);
1944 /* Too many elements in method_list to keep everything locally */
1945 vector
= scm_i_vector2list (save
, size
);
1946 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
1949 /* Use a simple shell sort since it is generally faster than qsort on
1950 * small vectors (which is probably mostly the case when we have to
1951 * sort a list of applicable methods).
1953 for (incr
= size
/ 2; incr
; incr
/= 2)
1955 for (i
= incr
; i
< size
; i
++)
1957 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1959 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1963 SCM tmp
= v
[j
+ incr
];
1971 if (size
<= BUFFSIZE
)
1973 /* We did it in locally, so restore the original list (reordered) in-place */
1974 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1976 SCM_SETCAR (method_list
, *v
);
1977 method_list
= SCM_CDR (method_list
);
1982 /* If we are here, that's that we did it the hard way... */
1983 scm_array_handle_release (&handle
);
1984 return scm_vector_to_list (vector
);
1988 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1992 SCM l
, fl
, applicable
= SCM_EOL
;
1994 SCM buffer
[BUFFSIZE
];
1998 scm_t_array_handle handle
;
2000 /* Build the list of arguments types */
2001 if (len
>= BUFFSIZE
)
2003 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2004 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2007 note that we don't have to work to reset the generation
2008 count. TMP is a new vector anyway, and it is found
2015 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2016 *p
++ = scm_class_of (SCM_CAR (args
));
2018 /* Build a list of all applicable methods */
2019 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2021 fl
= SPEC_OF (SCM_CAR (l
));
2022 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2024 if (SCM_INSTANCEP (fl
)
2025 /* We have a dotted argument list */
2026 || (i
>= len
&& scm_is_null (fl
)))
2027 { /* both list exhausted */
2028 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2034 || !applicablep (types
[i
], SCM_CAR (fl
)))
2039 if (len
>= BUFFSIZE
)
2040 scm_array_handle_release (&handle
);
2046 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2047 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2053 : sort_applicable_methods (applicable
, count
, types
));
2057 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2060 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2063 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2064 #define FUNC_NAME s_sys_compute_applicable_methods
2067 SCM_VALIDATE_GENERIC (1, gf
);
2068 n
= scm_ilength (args
);
2069 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2070 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2074 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2075 SCM_VARIABLE_INIT (var_compute_applicable_methods
, "compute-applicable-methods",
2076 scm_c_define_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0,
2077 scm_sys_compute_applicable_methods
));
2079 /******************************************************************************
2081 * A simple make (which will be redefined later in Scheme)
2082 * This version handles only creation of gf, methods and classes (no instances)
2084 * Since this code will disappear when Goops will be fully booted,
2085 * no precaution is taken to be efficient.
2087 ******************************************************************************/
2089 SCM_KEYWORD (k_setter
, "setter");
2090 SCM_KEYWORD (k_specializers
, "specializers");
2091 SCM_KEYWORD (k_procedure
, "procedure");
2092 SCM_KEYWORD (k_formals
, "formals");
2093 SCM_KEYWORD (k_body
, "body");
2094 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2095 SCM_KEYWORD (k_dsupers
, "dsupers");
2096 SCM_KEYWORD (k_slots
, "slots");
2097 SCM_KEYWORD (k_gf
, "generic-function");
2099 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2101 "Make a new object. @var{args} must contain the class and\n"
2102 "all necessary initialization information.")
2103 #define FUNC_NAME s_scm_make
2106 long len
= scm_ilength (args
);
2108 if (len
<= 0 || (len
& 1) == 0)
2109 SCM_WRONG_NUM_ARGS ();
2111 class = SCM_CAR(args
);
2112 args
= SCM_CDR(args
);
2114 if (scm_is_eq (class, scm_class_generic
)
2115 || scm_is_eq (class, scm_class_accessor
))
2117 z
= scm_make_struct (class, SCM_INUM0
,
2118 scm_list_4 (SCM_BOOL_F
,
2122 scm_set_procedure_property_x (z
, scm_sym_name
,
2123 scm_get_keyword (k_name
,
2126 clear_method_cache (z
);
2127 if (scm_is_eq (class, scm_class_accessor
))
2129 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2130 if (scm_is_true (setter
))
2131 scm_sys_set_object_setter_x (z
, setter
);
2136 z
= scm_sys_allocate_instance (class, args
);
2138 if (scm_is_eq (class, scm_class_method
)
2139 || scm_is_eq (class, scm_class_accessor_method
))
2141 SCM_SET_SLOT (z
, scm_si_generic_function
,
2142 scm_i_get_keyword (k_gf
,
2147 SCM_SET_SLOT (z
, scm_si_specializers
,
2148 scm_i_get_keyword (k_specializers
,
2153 SCM_SET_SLOT (z
, scm_si_procedure
,
2154 scm_i_get_keyword (k_procedure
,
2159 SCM_SET_SLOT (z
, scm_si_formals
,
2160 scm_i_get_keyword (k_formals
,
2165 SCM_SET_SLOT (z
, scm_si_body
,
2166 scm_i_get_keyword (k_body
,
2171 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2172 scm_i_get_keyword (k_make_procedure
,
2180 /* In all the others case, make a new class .... No instance here */
2181 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2182 scm_i_get_keyword (k_name
,
2185 scm_from_latin1_symbol ("???"),
2187 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2188 scm_i_get_keyword (k_dsupers
,
2193 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2194 scm_i_get_keyword (k_slots
,
2205 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2208 #define FUNC_NAME s_scm_find_method
2211 long len
= scm_ilength (l
);
2214 SCM_WRONG_NUM_ARGS ();
2216 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2217 SCM_VALIDATE_GENERIC (1, gf
);
2218 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2219 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2221 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2225 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2226 (SCM m1
, SCM m2
, SCM targs
),
2227 "Return true if method @var{m1} is more specific than @var{m2} "
2228 "given the argument types (classes) listed in @var{targs}.")
2229 #define FUNC_NAME s_scm_sys_method_more_specific_p
2233 long i
, len
, m1_specs
, m2_specs
;
2234 scm_t_array_handle handle
;
2236 SCM_VALIDATE_METHOD (1, m1
);
2237 SCM_VALIDATE_METHOD (2, m2
);
2239 len
= scm_ilength (targs
);
2240 m1_specs
= scm_ilength (SPEC_OF (m1
));
2241 m2_specs
= scm_ilength (SPEC_OF (m2
));
2242 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2243 targs
, SCM_ARG3
, FUNC_NAME
);
2245 /* Verify that all the arguments of TARGS are classes and place them
2248 v
= scm_c_make_vector (len
, SCM_EOL
);
2249 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2251 for (i
= 0, l
= targs
;
2252 i
< len
&& scm_is_pair (l
);
2253 i
++, l
= SCM_CDR (l
))
2255 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2256 v_elts
[i
] = SCM_CAR (l
);
2258 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2260 scm_array_handle_release (&handle
);
2268 /******************************************************************************
2272 ******************************************************************************/
2275 fix_cpl (SCM c
, SCM before
, SCM after
)
2277 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2278 SCM ls
= scm_c_memq (after
, cpl
);
2279 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2280 if (scm_is_false (ls
))
2281 /* if this condition occurs, fix_cpl should not be applied this way */
2283 SCM_SETCAR (ls
, before
);
2284 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2286 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2287 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2288 SCM g_n_s
= compute_getters_n_setters (slots
);
2289 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2290 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2296 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2298 SCM tmp
= scm_from_locale_symbol (name
);
2300 *var
= scm_basic_make_class (meta
, tmp
,
2301 scm_is_pair (super
) ? super
: scm_list_1 (super
),
2307 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2310 create_standard_classes (void)
2313 SCM method_slots
= scm_list_n (scm_from_latin1_symbol ("generic-function"),
2314 scm_from_latin1_symbol ("specializers"),
2316 scm_from_latin1_symbol ("formals"),
2317 scm_from_latin1_symbol ("body"),
2318 scm_from_latin1_symbol ("make-procedure"),
2320 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("slot-definition"),
2322 k_slot_definition
));
2323 SCM gf_slots
= scm_list_4 (scm_from_latin1_symbol ("methods"),
2324 scm_list_3 (scm_from_latin1_symbol ("n-specialized"),
2327 scm_list_3 (scm_from_latin1_symbol ("extended-by"),
2330 scm_from_latin1_symbol ("effective-methods"));
2331 SCM setter_slots
= scm_list_1 (sym_setter
);
2332 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_latin1_symbol ("extends"),
2335 /* Foreign class slot classes */
2336 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2337 scm_class_class
, scm_class_top
, SCM_EOL
);
2338 make_stdcls (&scm_class_protected
, "<protected-slot>",
2339 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2340 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2341 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2342 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2343 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2344 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2345 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2346 make_stdcls (&scm_class_self
, "<self-slot>",
2347 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2348 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2350 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2352 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2354 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2356 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2358 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2360 make_stdcls (&scm_class_scm
, "<scm-slot>",
2361 scm_class_class
, scm_class_protected
, SCM_EOL
);
2362 make_stdcls (&scm_class_int
, "<int-slot>",
2363 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2364 make_stdcls (&scm_class_float
, "<float-slot>",
2365 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2366 make_stdcls (&scm_class_double
, "<double-slot>",
2367 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2369 /* Continue initialization of class <class> */
2371 slots
= build_class_class_slots ();
2372 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2373 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2374 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2375 compute_getters_n_setters (slots
));
2377 /* scm_class_generic functions classes */
2378 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2379 scm_class_class
, scm_class_class
, SCM_EOL
);
2380 make_stdcls (&scm_class_applicable_struct_class
, "<applicable-struct-class>",
2381 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2382 SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
2383 make_stdcls (&scm_class_method
, "<method>",
2384 scm_class_class
, scm_class_object
, method_slots
);
2385 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2386 scm_class_class
, scm_class_method
, amethod_slots
);
2387 make_stdcls (&scm_class_applicable
, "<applicable>",
2388 scm_class_class
, scm_class_top
, SCM_EOL
);
2389 make_stdcls (&scm_class_applicable_struct
, "<applicable-struct>",
2390 scm_class_applicable_struct_class
,
2391 scm_list_2 (scm_class_object
, scm_class_applicable
),
2392 scm_list_1 (sym_procedure
));
2393 make_stdcls (&scm_class_generic
, "<generic>",
2394 scm_class_applicable_struct_class
, scm_class_applicable_struct
, gf_slots
);
2395 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2396 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2397 scm_class_applicable_struct_class
, scm_class_generic
, egf_slots
);
2398 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2399 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2400 scm_class_applicable_struct_class
, scm_class_generic
, setter_slots
);
2401 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2402 make_stdcls (&scm_class_accessor
, "<accessor>",
2403 scm_class_applicable_struct_class
, scm_class_generic_with_setter
, SCM_EOL
);
2404 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2405 make_stdcls (&scm_class_extended_generic_with_setter
,
2406 "<extended-generic-with-setter>",
2407 scm_class_applicable_struct_class
,
2408 scm_list_2 (scm_class_generic_with_setter
,
2409 scm_class_extended_generic
),
2411 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2412 SCM_CLASSF_PURE_GENERIC
);
2413 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2414 scm_class_applicable_struct_class
,
2415 scm_list_2 (scm_class_accessor
,
2416 scm_class_extended_generic_with_setter
),
2418 fix_cpl (scm_class_extended_accessor
,
2419 scm_class_extended_generic
, scm_class_generic
);
2420 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2422 /* Primitive types classes */
2423 make_stdcls (&scm_class_boolean
, "<boolean>",
2424 scm_class_class
, scm_class_top
, SCM_EOL
);
2425 make_stdcls (&scm_class_char
, "<char>",
2426 scm_class_class
, scm_class_top
, SCM_EOL
);
2427 make_stdcls (&scm_class_list
, "<list>",
2428 scm_class_class
, scm_class_top
, SCM_EOL
);
2429 make_stdcls (&scm_class_pair
, "<pair>",
2430 scm_class_class
, scm_class_list
, SCM_EOL
);
2431 make_stdcls (&scm_class_null
, "<null>",
2432 scm_class_class
, scm_class_list
, SCM_EOL
);
2433 make_stdcls (&scm_class_string
, "<string>",
2434 scm_class_class
, scm_class_top
, SCM_EOL
);
2435 make_stdcls (&scm_class_symbol
, "<symbol>",
2436 scm_class_class
, scm_class_top
, SCM_EOL
);
2437 make_stdcls (&scm_class_vector
, "<vector>",
2438 scm_class_class
, scm_class_top
, SCM_EOL
);
2439 make_stdcls (&class_foreign
, "<foreign>",
2440 scm_class_class
, scm_class_top
, SCM_EOL
);
2441 make_stdcls (&class_hashtable
, "<hashtable>",
2442 scm_class_class
, scm_class_top
, SCM_EOL
);
2443 make_stdcls (&class_fluid
, "<fluid>",
2444 scm_class_class
, scm_class_top
, SCM_EOL
);
2445 make_stdcls (&class_dynamic_state
, "<dynamic-state>",
2446 scm_class_class
, scm_class_top
, SCM_EOL
);
2447 make_stdcls (&class_frame
, "<frame>",
2448 scm_class_class
, scm_class_top
, SCM_EOL
);
2449 make_stdcls (&class_objcode
, "<objcode>",
2450 scm_class_class
, scm_class_top
, SCM_EOL
);
2451 make_stdcls (&class_vm
, "<vm>",
2452 scm_class_class
, scm_class_top
, SCM_EOL
);
2453 make_stdcls (&class_vm_cont
, "<vm-continuation>",
2454 scm_class_class
, scm_class_top
, SCM_EOL
);
2455 make_stdcls (&class_bytevector
, "<bytevector>",
2456 scm_class_class
, scm_class_top
, SCM_EOL
);
2457 make_stdcls (&class_uvec
, "<uvec>",
2458 scm_class_class
, class_bytevector
, SCM_EOL
);
2459 make_stdcls (&scm_class_number
, "<number>",
2460 scm_class_class
, scm_class_top
, SCM_EOL
);
2461 make_stdcls (&scm_class_complex
, "<complex>",
2462 scm_class_class
, scm_class_number
, SCM_EOL
);
2463 make_stdcls (&scm_class_real
, "<real>",
2464 scm_class_class
, scm_class_complex
, SCM_EOL
);
2465 make_stdcls (&scm_class_integer
, "<integer>",
2466 scm_class_class
, scm_class_real
, SCM_EOL
);
2467 make_stdcls (&scm_class_fraction
, "<fraction>",
2468 scm_class_class
, scm_class_real
, SCM_EOL
);
2469 make_stdcls (&scm_class_keyword
, "<keyword>",
2470 scm_class_class
, scm_class_top
, SCM_EOL
);
2471 make_stdcls (&scm_class_unknown
, "<unknown>",
2472 scm_class_class
, scm_class_top
, SCM_EOL
);
2473 make_stdcls (&scm_class_procedure
, "<procedure>",
2474 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2475 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2476 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2477 make_stdcls (&scm_class_port
, "<port>",
2478 scm_class_class
, scm_class_top
, SCM_EOL
);
2479 make_stdcls (&scm_class_input_port
, "<input-port>",
2480 scm_class_class
, scm_class_port
, SCM_EOL
);
2481 make_stdcls (&scm_class_output_port
, "<output-port>",
2482 scm_class_class
, scm_class_port
, SCM_EOL
);
2483 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2485 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2489 /**********************************************************************
2493 **********************************************************************/
2496 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2502 sprintf (buffer
, template, type_name
);
2503 name
= scm_from_locale_symbol (buffer
);
2506 name
= SCM_GOOPS_UNBOUND
;
2508 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2509 name
, supers
, SCM_EOL
);
2511 /* Only define name if doesn't already exist. */
2512 if (!SCM_GOOPS_UNBOUNDP (name
)
2513 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2514 DEFVAR (name
, class);
2519 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2522 if (scm_is_true (type_name_sym
))
2524 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2525 scm_symbol_to_string (type_name_sym
),
2526 scm_from_locale_string (">")));
2527 name
= scm_string_to_symbol (name
);
2530 name
= SCM_GOOPS_UNBOUND
;
2532 class = scm_basic_make_class (applicablep
? scm_class_procedure_class
: scm_class_class
,
2533 name
, supers
, SCM_EOL
);
2535 /* Only define name if doesn't already exist. */
2536 if (!SCM_GOOPS_UNBOUNDP (name
)
2537 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2538 DEFVAR (name
, class);
2543 scm_make_extended_class (char const *type_name
, int applicablep
)
2545 return make_class_from_template ("<%s>",
2547 scm_list_1 (applicablep
2548 ? scm_class_applicable
2554 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2556 return make_class_from_symbol (type_name_sym
,
2557 scm_list_1 (applicablep
2558 ? scm_class_applicable
2564 scm_i_inherit_applicable (SCM c
)
2566 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2568 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2569 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2570 /* patch scm_class_applicable into direct-supers */
2571 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2572 if (scm_is_false (top
))
2573 dsupers
= scm_append (scm_list_2 (dsupers
,
2574 scm_list_1 (scm_class_applicable
)));
2577 SCM_SETCAR (top
, scm_class_applicable
);
2578 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2580 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2581 /* patch scm_class_applicable into cpl */
2582 top
= scm_c_memq (scm_class_top
, cpl
);
2583 if (scm_is_false (top
))
2587 SCM_SETCAR (top
, scm_class_applicable
);
2588 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2590 /* add class to direct-subclasses of scm_class_applicable */
2591 SCM_SET_SLOT (scm_class_applicable
,
2592 scm_si_direct_subclasses
,
2593 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2594 scm_si_direct_subclasses
)));
2599 create_smob_classes (void)
2603 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2604 scm_smob_class
[i
] = SCM_BOOL_F
;
2606 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2608 for (i
= 0; i
< scm_numsmob
; ++i
)
2609 if (scm_is_false (scm_smob_class
[i
]))
2610 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2611 scm_smobs
[i
].apply
!= 0);
2615 scm_make_port_classes (long ptobnum
, char *type_name
)
2617 SCM c
, class = make_class_from_template ("<%s-port>",
2619 scm_list_1 (scm_class_port
),
2621 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2622 = make_class_from_template ("<%s-input-port>",
2624 scm_list_2 (class, scm_class_input_port
),
2626 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2627 = make_class_from_template ("<%s-output-port>",
2629 scm_list_2 (class, scm_class_output_port
),
2631 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2633 = make_class_from_template ("<%s-input-output-port>",
2635 scm_list_2 (class, scm_class_input_output_port
),
2637 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2638 SCM_SET_SLOT (c
, scm_si_cpl
,
2639 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2643 create_port_classes (void)
2647 for (i
= 0; i
< scm_numptob
; ++i
)
2648 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2652 make_struct_class (void *closure SCM_UNUSED
,
2653 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2655 if (scm_is_false (data
))
2656 scm_i_define_class_for_vtable (vtable
);
2657 return SCM_UNSPECIFIED
;
2661 create_struct_classes (void)
2663 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
2667 /**********************************************************************
2671 **********************************************************************/
2676 if (!goops_loaded_p
)
2677 scm_c_resolve_module ("oop goops");
2681 SCM_SYMBOL (sym_o
, "o");
2682 SCM_SYMBOL (sym_x
, "x");
2684 SCM_KEYWORD (k_accessor
, "accessor");
2685 SCM_KEYWORD (k_getter
, "getter");
2688 scm_ensure_accessor (SCM name
)
2690 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2691 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2693 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2694 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2695 k_name
, name
, k_setter
, gf
));
2702 * Debugging utilities
2705 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2707 "Return @code{#t} if @var{obj} is a pure generic.")
2708 #define FUNC_NAME s_scm_pure_generic_p
2710 return scm_from_bool (SCM_PUREGENERICP (obj
));
2714 #endif /* GUILE_DEBUG */
2720 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2722 "Announce that GOOPS is loaded and perform initialization\n"
2723 "on the C level which depends on the loaded GOOPS modules.")
2724 #define FUNC_NAME s_scm_sys_goops_loaded
2727 var_compute_applicable_methods
=
2728 scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
);
2730 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
2732 scm_module_variable (scm_module_goops
, sym_slot_missing
);
2734 scm_module_variable (scm_module_goops
, sym_compute_cpl
);
2735 var_no_applicable_method
=
2736 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
2738 scm_module_variable (scm_module_goops
, sym_change_class
);
2739 setup_extended_primitive_generics ();
2740 return SCM_UNSPECIFIED
;
2744 SCM scm_module_goops
;
2747 scm_init_goops_builtins (void)
2749 scm_module_goops
= scm_current_module ();
2751 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2753 #include "libguile/goops.x"
2755 hell
= scm_calloc (hell_size
* sizeof (*hell
));
2756 hell_mutex
= scm_make_mutex ();
2758 create_basic_classes ();
2759 create_standard_classes ();
2760 create_smob_classes ();
2761 create_struct_classes ();
2762 create_port_classes ();
2765 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
2766 scm_no_applicable_method
=
2767 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2768 DEFVAR (name
, scm_no_applicable_method
);
2771 return SCM_UNSPECIFIED
;
2777 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2778 scm_init_goops_builtins
);