1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
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
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but 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 02110-1301 USA
20 /* This software is a derivative work of other copyrighted softwares; the
21 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 * This file is based upon stklos.c from the STk distribution by
24 * 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/hashtab.h"
43 #include "libguile/keywords.h"
44 #include "libguile/macros.h"
45 #include "libguile/modules.h"
46 #include "libguile/objects.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/random.h"
50 #include "libguile/root.h"
51 #include "libguile/smob.h"
52 #include "libguile/strings.h"
53 #include "libguile/strports.h"
54 #include "libguile/vectors.h"
55 #include "libguile/weaks.h"
57 #include "libguile/validate.h"
58 #include "libguile/goops.h"
60 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
62 /* this file is a mess. in theory, though, we shouldn't have many SCM references
63 -- most of the references should be to vars. */
65 static SCM var_slot_unbound
= SCM_BOOL_F
;
66 static SCM var_slot_missing
= SCM_BOOL_F
;
67 static SCM var_compute_cpl
= SCM_BOOL_F
;
68 static SCM var_no_applicable_method
= SCM_BOOL_F
;
69 static SCM var_memoize_method_x
= SCM_BOOL_F
;
70 static SCM var_change_class
= SCM_BOOL_F
;
72 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
73 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
74 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
75 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
76 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
77 SCM_SYMBOL (sym_change_class
, "change-class");
79 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
82 /* FIXME, exports should come from the scm file only */
83 #define DEFVAR(v, val) \
84 { scm_module_define (scm_module_goops, (v), (val)); \
85 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
89 /* Class redefinition protocol:
91 A class is represented by a heap header h1 which points to a
92 malloc:ed memory block m1.
94 When a new version of a class is created, a new header h2 and
95 memory block m2 are allocated. The headers h1 and h2 then switch
96 pointers so that h1 refers to m2 and h2 to m1. In this way, names
97 bound to h1 will point to the new class at the same time as h2 will
98 be a handle which the GC will use to free m1.
100 The `redefined' slot of m1 will be set to point to h1. An old
101 instance will have its class pointer (the CAR of the heap header)
102 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
103 the class modification and the new class pointer can be found via
107 /* The following definition is located in libguile/objects.h:
108 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
111 #define TEST_CHANGE_CLASS(obj, class) \
113 class = SCM_CLASS_OF (obj); \
114 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
116 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
117 class = SCM_CLASS_OF (obj); \
121 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
122 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
124 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
125 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
127 static int goops_loaded_p
= 0;
128 static scm_t_rstate
*goops_rstate
;
130 /* These variables are filled in by the object system when loaded. */
131 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
132 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
133 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
134 SCM scm_class_vector
, scm_class_null
;
135 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
136 SCM scm_class_unknown
;
137 SCM scm_class_top
, scm_class_object
, scm_class_class
;
138 SCM scm_class_applicable
;
139 SCM scm_class_entity
, scm_class_entity_with_setter
;
140 SCM scm_class_generic
, scm_class_generic_with_setter
;
141 SCM scm_class_accessor
;
142 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
143 SCM scm_class_extended_accessor
;
144 SCM scm_class_method
;
145 SCM scm_class_simple_method
, scm_class_accessor_method
;
146 SCM scm_class_procedure_class
;
147 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
148 SCM scm_class_entity_class
;
149 SCM scm_class_number
, scm_class_list
;
150 SCM scm_class_keyword
;
151 SCM scm_class_port
, scm_class_input_output_port
;
152 SCM scm_class_input_port
, scm_class_output_port
;
153 SCM scm_class_foreign_class
, scm_class_foreign_object
;
154 SCM scm_class_foreign_slot
;
155 SCM scm_class_self
, scm_class_protected
;
156 SCM scm_class_opaque
, scm_class_read_only
;
157 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
159 SCM scm_class_int
, scm_class_float
, scm_class_double
;
161 SCM
*scm_port_class
= 0;
162 SCM
*scm_smob_class
= 0;
164 SCM scm_no_applicable_method
;
166 SCM_SYMBOL (scm_sym_define_public
, "define-public");
168 static SCM
scm_make_unbound (void);
169 static SCM
scm_unbound_p (SCM obj
);
170 static SCM
scm_assert_bound (SCM value
, SCM obj
);
171 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
172 static SCM
scm_sys_goops_loaded (void);
174 /* This function is used for efficient type dispatch. */
175 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
177 "Return the class of @var{x}.")
178 #define FUNC_NAME s_scm_class_of
180 switch (SCM_ITAG3 (x
))
184 return scm_class_integer
;
188 return scm_class_char
;
189 else if (scm_is_bool (x
))
190 return scm_class_boolean
;
191 else if (scm_is_null (x
))
192 return scm_class_null
;
194 return scm_class_unknown
;
197 switch (SCM_TYP7 (x
))
199 case scm_tcs_cons_nimcar
:
200 return scm_class_pair
;
201 case scm_tcs_closures
:
202 return scm_class_procedure
;
204 return scm_class_symbol
;
207 return scm_class_vector
;
209 return scm_class_string
;
211 switch SCM_TYP16 (x
) {
213 return scm_class_integer
;
215 return scm_class_real
;
216 case scm_tc16_complex
:
217 return scm_class_complex
;
218 case scm_tc16_fraction
:
219 return scm_class_fraction
;
229 case scm_tc7_subr_1o
:
230 case scm_tc7_subr_2o
:
231 case scm_tc7_lsubr_2
:
233 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
234 return scm_class_primitive_generic
;
236 return scm_class_procedure
;
238 return scm_class_procedure
;
240 return scm_class_procedure_with_setter
;
244 scm_t_bits type
= SCM_TYP16 (x
);
245 if (type
!= scm_tc16_port_with_ps
)
246 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
247 x
= SCM_PORT_WITH_PS_PORT (x
);
248 /* fall through to ports */
251 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
252 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
253 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
254 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
255 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
257 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
258 return SCM_CLASS_OF (x
);
259 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
262 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
263 scm_change_object_class (x
,
264 SCM_CLASS_OF (x
), /* old */
265 SCM_OBJ_CLASS_REDEF (x
)); /* new */
266 return SCM_CLASS_OF (x
);
270 /* ordinary struct */
271 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
272 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
273 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
276 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
277 SCM
class = scm_make_extended_class (scm_is_true (name
)
278 ? scm_i_symbol_chars (name
)
280 SCM_I_OPERATORP (x
));
281 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
287 return scm_class_pair
;
289 return scm_class_unknown
;
295 case scm_tc3_closure
:
299 return scm_class_unknown
;
303 /******************************************************************************
307 * This version doesn't fully handle multiple-inheritance. It serves
308 * only for booting classes and will be overloaded in Scheme
310 ******************************************************************************/
313 map (SCM (*proc
) (SCM
), SCM ls
)
315 if (scm_is_null (ls
))
319 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
322 while (!scm_is_null (ls
))
324 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
336 while (!scm_is_null (ls
))
338 SCM el
= SCM_CAR (ls
);
339 if (scm_is_false (scm_c_memq (el
, res
)))
340 res
= scm_cons (el
, res
);
347 compute_cpl (SCM
class)
350 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
353 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
354 SCM ls
= scm_append (scm_acons (class, supers
,
355 map (compute_cpl
, supers
)));
356 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
360 /******************************************************************************
364 ******************************************************************************/
367 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
375 if (!scm_is_symbol (tmp
))
376 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
378 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
379 res
= scm_cons (SCM_CAR (l
), res
);
380 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
383 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
387 build_slots_list (SCM dslots
, SCM cpl
)
389 register SCM res
= dslots
;
391 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
392 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
393 scm_si_direct_slots
),
396 /* res contains a list of slots. Remove slots which appears more than once */
397 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
404 while (!scm_is_null (ls
))
406 if (!scm_is_pair (SCM_CAR (ls
)))
407 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
414 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
416 "Return a list consisting of the names of all slots belonging to\n"
417 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
419 #define FUNC_NAME s_scm_sys_compute_slots
421 SCM_VALIDATE_CLASS (1, class);
422 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
423 SCM_SLOT (class, scm_si_cpl
));
428 /******************************************************************************
430 * compute-getters-n-setters
432 * This version doesn't handle slot options. It serves only for booting
433 * classes and will be overloaded in Scheme.
435 ******************************************************************************/
437 SCM_KEYWORD (k_init_value
, "init-value");
438 SCM_KEYWORD (k_init_thunk
, "init-thunk");
441 compute_getters_n_setters (SCM slots
)
447 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
449 SCM init
= SCM_BOOL_F
;
450 SCM options
= SCM_CDAR (slots
);
451 if (!scm_is_null (options
))
453 init
= scm_get_keyword (k_init_value
, options
, 0);
456 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
458 scm_list_2 (scm_sym_quote
,
463 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
465 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
467 scm_from_int (i
++))),
469 cdrloc
= SCM_CDRLOC (*cdrloc
);
474 /******************************************************************************
478 ******************************************************************************/
480 /*fixme* Manufacture keywords in advance */
482 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
486 for (i
= 0; i
!= len
; i
+= 2)
488 SCM obj
= SCM_CAR (l
);
490 if (!scm_is_keyword (obj
))
491 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
492 else if (scm_is_eq (obj
, key
))
498 return default_value
;
502 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
503 (SCM key
, SCM l
, SCM default_value
),
504 "Determine an associated value for the keyword @var{key} from\n"
505 "the list @var{l}. The list @var{l} has to consist of an even\n"
506 "number of elements, where, starting with the first, every\n"
507 "second element is a keyword, followed by its associated value.\n"
508 "If @var{l} does not hold a value for @var{key}, the value\n"
509 "@var{default_value} is returned.")
510 #define FUNC_NAME s_scm_get_keyword
514 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
515 len
= scm_ilength (l
);
516 if (len
< 0 || len
% 2 == 1)
517 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
519 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
524 SCM_KEYWORD (k_init_keyword
, "init-keyword");
526 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
527 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
529 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
530 (SCM obj
, SCM initargs
),
531 "Initialize the object @var{obj} with the given arguments\n"
533 #define FUNC_NAME s_scm_sys_initialize_object
535 SCM tmp
, get_n_set
, slots
;
536 SCM
class = SCM_CLASS_OF (obj
);
539 SCM_VALIDATE_INSTANCE (1, obj
);
540 n_initargs
= scm_ilength (initargs
);
541 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
543 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
544 slots
= SCM_SLOT (class, scm_si_slots
);
546 /* See for each slot how it must be initialized */
548 !scm_is_null (slots
);
549 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
551 SCM slot_name
= SCM_CAR (slots
);
554 if (!scm_is_null (SCM_CDR (slot_name
)))
556 /* This slot admits (perhaps) to be initialized at creation time */
557 long n
= scm_ilength (SCM_CDR (slot_name
));
558 if (n
& 1) /* odd or -1 */
559 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
560 scm_list_1 (slot_name
));
561 tmp
= scm_i_get_keyword (k_init_keyword
,
566 slot_name
= SCM_CAR (slot_name
);
569 /* an initarg was provided for this slot */
570 if (!scm_is_keyword (tmp
))
571 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
573 slot_value
= scm_i_get_keyword (tmp
,
582 /* set slot to provided value */
583 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
586 /* set slot to its :init-form if it exists */
587 tmp
= SCM_CADAR (get_n_set
);
588 if (scm_is_true (tmp
))
590 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
591 if (SCM_GOOPS_UNBOUNDP (slot_value
))
592 set_slot_value (class,
604 /* NOTE: The following macros are interdependent with code
605 * in goops.scm:compute-getters-n-setters
607 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
608 (SCM_I_INUMP (SCM_CDDR (gns)) \
609 || (scm_is_pair (SCM_CDDR (gns)) \
610 && scm_is_pair (SCM_CDDDR (gns)) \
611 && scm_is_pair (SCM_CDDDDR (gns))))
612 #define SCM_GNS_INDEX(gns) \
613 (SCM_I_INUMP (SCM_CDDR (gns)) \
614 ? SCM_I_INUM (SCM_CDDR (gns)) \
615 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
616 #define SCM_GNS_SIZE(gns) \
617 (SCM_I_INUMP (SCM_CDDR (gns)) \
619 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
621 SCM_KEYWORD (k_class
, "class");
622 SCM_KEYWORD (k_allocation
, "allocation");
623 SCM_KEYWORD (k_instance
, "instance");
625 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
628 #define FUNC_NAME s_scm_sys_prep_layout_x
630 SCM slots
, getters_n_setters
, nfields
;
631 unsigned long int n
, i
;
635 SCM_VALIDATE_INSTANCE (1, class);
636 slots
= SCM_SLOT (class, scm_si_slots
);
637 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
638 nfields
= SCM_SLOT (class, scm_si_nfields
);
639 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
640 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
641 scm_list_1 (nfields
));
642 n
= 2 * SCM_I_INUM (nfields
);
643 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
644 && SCM_SUBCLASSP (class, scm_class_class
))
645 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
646 scm_list_1 (nfields
));
648 layout
= scm_i_make_string (n
, &s
);
650 while (scm_is_pair (getters_n_setters
))
652 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
655 int len
, index
, size
;
658 if (i
>= n
|| !scm_is_pair (slots
))
661 /* extract slot type */
662 len
= scm_ilength (SCM_CDAR (slots
));
663 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
664 len
, SCM_BOOL_F
, FUNC_NAME
);
665 /* determine slot GC protection and access mode */
666 if (scm_is_false (type
))
673 if (!SCM_CLASSP (type
))
674 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
675 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
677 if (SCM_SUBCLASSP (type
, scm_class_self
))
679 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
684 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
686 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
698 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
699 if (index
!= (i
>> 1))
701 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
709 slots
= SCM_CDR (slots
);
710 getters_n_setters
= SCM_CDR (getters_n_setters
);
712 if (!scm_is_null (slots
))
715 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
717 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
718 return SCM_UNSPECIFIED
;
722 static void prep_hashsets (SCM
);
724 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
725 (SCM
class, SCM dsupers
),
727 #define FUNC_NAME s_scm_sys_inherit_magic_x
731 SCM_VALIDATE_INSTANCE (1, class);
732 while (!scm_is_null (ls
))
734 SCM_ASSERT (scm_is_pair (ls
)
735 && SCM_INSTANCEP (SCM_CAR (ls
)),
739 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
742 flags
&= SCM_CLASSF_INHERIT
;
743 if (flags
& SCM_CLASSF_ENTITY
)
744 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
747 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
750 * We could avoid calling scm_gc_malloc in the allocation code
751 * (in which case the following two lines are needed). Instead
752 * we make 0-slot instances non-light, so that the light case
753 * can be handled without special cases.
756 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
758 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
760 /* NOTE: The following depends on scm_struct_i_size. */
761 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
762 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
765 SCM_SET_CLASS_FLAGS (class, flags
);
767 prep_hashsets (class);
769 return SCM_UNSPECIFIED
;
774 prep_hashsets (SCM
class)
778 for (i
= 0; i
< 7; ++i
)
779 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
782 /******************************************************************************/
785 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
787 SCM z
, cpl
, slots
, nfields
, g_n_s
;
789 /* Allocate one instance */
790 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
792 /* Initialize its slots */
793 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
794 cpl
= compute_cpl (z
);
795 slots
= build_slots_list (maplist (dslots
), cpl
);
796 nfields
= scm_from_int (scm_ilength (slots
));
797 g_n_s
= compute_getters_n_setters (slots
);
799 SCM_SET_SLOT (z
, scm_si_name
, name
);
800 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
801 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
802 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
803 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
804 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
805 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
806 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
807 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
808 SCM_SET_SLOT (z
, scm_si_environment
,
809 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
811 /* Add this class in the direct-subclasses slot of dsupers */
814 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
815 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
816 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
817 scm_si_direct_subclasses
)));
820 /* Support for the underlying structs: */
821 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
822 ? (SCM_CLASSF_GOOPS_OR_VALID
823 | SCM_CLASSF_OPERATOR
825 : class == scm_class_operator_class
826 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
827 : SCM_CLASSF_GOOPS_OR_VALID
));
832 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
834 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
835 scm_sys_inherit_magic_x (z
, dsupers
);
836 scm_sys_prep_layout_x (z
);
840 /******************************************************************************/
842 SCM_SYMBOL (sym_layout
, "layout");
843 SCM_SYMBOL (sym_vcell
, "vcell");
844 SCM_SYMBOL (sym_vtable
, "vtable");
845 SCM_SYMBOL (sym_print
, "print");
846 SCM_SYMBOL (sym_procedure
, "procedure");
847 SCM_SYMBOL (sym_setter
, "setter");
848 SCM_SYMBOL (sym_redefined
, "redefined");
849 SCM_SYMBOL (sym_h0
, "h0");
850 SCM_SYMBOL (sym_h1
, "h1");
851 SCM_SYMBOL (sym_h2
, "h2");
852 SCM_SYMBOL (sym_h3
, "h3");
853 SCM_SYMBOL (sym_h4
, "h4");
854 SCM_SYMBOL (sym_h5
, "h5");
855 SCM_SYMBOL (sym_h6
, "h6");
856 SCM_SYMBOL (sym_h7
, "h7");
857 SCM_SYMBOL (sym_name
, "name");
858 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
859 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
860 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
861 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
862 SCM_SYMBOL (sym_cpl
, "cpl");
863 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
864 SCM_SYMBOL (sym_slots
, "slots");
865 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
866 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
867 SCM_SYMBOL (sym_nfields
, "nfields");
868 SCM_SYMBOL (sym_environment
, "environment");
872 build_class_class_slots ()
875 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
876 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
877 scm_list_1 (sym_print
),
878 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
879 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
880 scm_list_1 (sym_redefined
),
881 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
882 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
883 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
884 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
885 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
886 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
887 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
888 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
889 scm_list_1 (sym_name
),
890 scm_list_1 (sym_direct_supers
),
891 scm_list_1 (sym_direct_slots
),
892 scm_list_1 (sym_direct_subclasses
),
893 scm_list_1 (sym_direct_methods
),
894 scm_list_1 (sym_cpl
),
895 scm_list_1 (sym_default_slot_definition_class
),
896 scm_list_1 (sym_slots
),
897 scm_list_1 (sym_getters_n_setters
),
898 scm_list_1 (sym_keyword_access
),
899 scm_list_1 (sym_nfields
),
900 scm_list_1 (sym_environment
),
905 create_basic_classes (void)
907 /* SCM slots_of_class = build_class_class_slots (); */
909 /**** <scm_class_class> ****/
910 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
911 + 2 * scm_vtable_offset_user
);
912 SCM name
= scm_from_locale_symbol ("<class>");
913 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
916 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
917 | SCM_CLASSF_METACLASS
));
919 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
920 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
921 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
922 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
923 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
924 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
925 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
926 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
927 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
928 compute_getters_n_setters (slots_of_class)); */
929 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
930 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
931 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
933 prep_hashsets (scm_class_class
);
935 DEFVAR(name
, scm_class_class
);
937 /**** <scm_class_top> ****/
938 name
= scm_from_locale_symbol ("<top>");
939 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
944 DEFVAR(name
, scm_class_top
);
946 /**** <scm_class_object> ****/
947 name
= scm_from_locale_symbol ("<object>");
948 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
950 scm_list_1 (scm_class_top
),
953 DEFVAR (name
, scm_class_object
);
955 /* <top> <object> and <class> were partially initialized. Correct them here */
956 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
958 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
959 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
962 /******************************************************************************/
964 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
966 "Return @code{#t} if @var{obj} is an instance.")
967 #define FUNC_NAME s_scm_instance_p
969 return scm_from_bool (SCM_INSTANCEP (obj
));
974 /******************************************************************************
976 * Meta object accessors
978 ******************************************************************************/
979 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
981 "Return the class name of @var{obj}.")
982 #define FUNC_NAME s_scm_class_name
984 SCM_VALIDATE_CLASS (1, obj
);
985 return scm_slot_ref (obj
, sym_name
);
989 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
991 "Return the direct superclasses of the class @var{obj}.")
992 #define FUNC_NAME s_scm_class_direct_supers
994 SCM_VALIDATE_CLASS (1, obj
);
995 return scm_slot_ref (obj
, sym_direct_supers
);
999 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1001 "Return the direct slots of the class @var{obj}.")
1002 #define FUNC_NAME s_scm_class_direct_slots
1004 SCM_VALIDATE_CLASS (1, obj
);
1005 return scm_slot_ref (obj
, sym_direct_slots
);
1009 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1011 "Return the direct subclasses of the class @var{obj}.")
1012 #define FUNC_NAME s_scm_class_direct_subclasses
1014 SCM_VALIDATE_CLASS (1, obj
);
1015 return scm_slot_ref(obj
, sym_direct_subclasses
);
1019 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1021 "Return the direct methods of the class @var{obj}")
1022 #define FUNC_NAME s_scm_class_direct_methods
1024 SCM_VALIDATE_CLASS (1, obj
);
1025 return scm_slot_ref (obj
, sym_direct_methods
);
1029 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1031 "Return the class precedence list of the class @var{obj}.")
1032 #define FUNC_NAME s_scm_class_precedence_list
1034 SCM_VALIDATE_CLASS (1, obj
);
1035 return scm_slot_ref (obj
, sym_cpl
);
1039 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1041 "Return the slot list of the class @var{obj}.")
1042 #define FUNC_NAME s_scm_class_slots
1044 SCM_VALIDATE_CLASS (1, obj
);
1045 return scm_slot_ref (obj
, sym_slots
);
1049 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1051 "Return the environment of the class @var{obj}.")
1052 #define FUNC_NAME s_scm_class_environment
1054 SCM_VALIDATE_CLASS (1, obj
);
1055 return scm_slot_ref(obj
, sym_environment
);
1060 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1062 "Return the name of the generic function @var{obj}.")
1063 #define FUNC_NAME s_scm_generic_function_name
1065 SCM_VALIDATE_GENERIC (1, obj
);
1066 return scm_procedure_property (obj
, scm_sym_name
);
1070 SCM_SYMBOL (sym_methods
, "methods");
1071 SCM_SYMBOL (sym_extended_by
, "extended-by");
1072 SCM_SYMBOL (sym_extends
, "extends");
1075 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1077 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1078 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1079 while (!scm_is_null (gfs
))
1081 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1082 gfs
= SCM_CDR (gfs
);
1084 return method_lists
;
1088 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1090 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1092 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1093 while (!scm_is_null (gfs
))
1095 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1096 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1099 gfs
= SCM_CDR (gfs
);
1102 return method_lists
;
1105 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1107 "Return the methods of the generic function @var{obj}.")
1108 #define FUNC_NAME s_scm_generic_function_methods
1111 SCM_VALIDATE_GENERIC (1, obj
);
1112 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1113 methods
= fold_downward_gf_methods (methods
, obj
);
1114 return scm_append (methods
);
1118 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1120 "Return the generic function for the method @var{obj}.")
1121 #define FUNC_NAME s_scm_method_generic_function
1123 SCM_VALIDATE_METHOD (1, obj
);
1124 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1128 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1130 "Return specializers of the method @var{obj}.")
1131 #define FUNC_NAME s_scm_method_specializers
1133 SCM_VALIDATE_METHOD (1, obj
);
1134 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1138 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1140 "Return the procedure of the method @var{obj}.")
1141 #define FUNC_NAME s_scm_method_procedure
1143 SCM_VALIDATE_METHOD (1, obj
);
1144 return scm_slot_ref (obj
, sym_procedure
);
1148 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1150 "Return the slot definition of the accessor @var{obj}.")
1151 #define FUNC_NAME s_scm_accessor_method_slot_definition
1153 SCM_VALIDATE_ACCESSOR (1, obj
);
1154 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1158 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1160 "Internal GOOPS magic---don't use this function!")
1161 #define FUNC_NAME s_scm_sys_tag_body
1163 return scm_cons (SCM_IM_LAMBDA
, body
);
1167 /******************************************************************************
1169 * S l o t a c c e s s
1171 ******************************************************************************/
1173 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1175 "Return the unbound value.")
1176 #define FUNC_NAME s_scm_make_unbound
1178 return SCM_GOOPS_UNBOUND
;
1182 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1184 "Return @code{#t} if @var{obj} is unbound.")
1185 #define FUNC_NAME s_scm_unbound_p
1187 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1191 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1192 (SCM value
, SCM obj
),
1193 "Return @var{value} if it is bound, and invoke the\n"
1194 "@var{slot-unbound} method of @var{obj} if it is not.")
1195 #define FUNC_NAME s_scm_assert_bound
1197 if (SCM_GOOPS_UNBOUNDP (value
))
1198 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1203 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1204 (SCM obj
, SCM index
),
1205 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1206 "the value from @var{obj}.")
1207 #define FUNC_NAME s_scm_at_assert_bound_ref
1209 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1210 if (SCM_GOOPS_UNBOUNDP (value
))
1211 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1216 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1217 (SCM obj
, SCM index
),
1218 "Return the slot value with index @var{index} from @var{obj}.")
1219 #define FUNC_NAME s_scm_sys_fast_slot_ref
1221 unsigned long int i
;
1223 SCM_VALIDATE_INSTANCE (1, obj
);
1224 i
= scm_to_unsigned_integer (index
, 0,
1225 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1228 return SCM_SLOT (obj
, i
);
1232 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1233 (SCM obj
, SCM index
, SCM value
),
1234 "Set the slot with index @var{index} in @var{obj} to\n"
1236 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1238 unsigned long int i
;
1240 SCM_VALIDATE_INSTANCE (1, obj
);
1241 i
= scm_to_unsigned_integer (index
, 0,
1242 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1246 SCM_SET_SLOT (obj
, i
, value
);
1248 return SCM_UNSPECIFIED
;
1253 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1254 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1259 /* In the future, this function will return the effective slot
1260 * definition associated with SLOT_NAME. Now it just returns some of
1261 * the information which will be stored in the effective slot
1266 slot_definition_using_name (SCM
class, SCM slot_name
)
1268 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1269 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1270 if (SCM_CAAR (slots
) == slot_name
)
1271 return SCM_CAR (slots
);
1276 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1277 #define FUNC_NAME "%get-slot-value"
1279 SCM access
= SCM_CDDR (slotdef
);
1281 * - access is an integer (the offset of this slot in the slots vector)
1282 * - otherwise (car access) is the getter function to apply
1284 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1285 * we can just assume fixnums here.
1287 if (SCM_I_INUMP (access
))
1288 /* Don't poke at the slots directly, because scm_struct_ref handles the
1289 access bits for us. */
1290 return scm_struct_ref (obj
, access
);
1293 /* We must evaluate (apply (car access) (list obj))
1294 * where (car access) is known to be a closure of arity 1 */
1295 register SCM code
, env
;
1297 code
= SCM_CAR (access
);
1298 if (!SCM_CLOSUREP (code
))
1299 return scm_call_1 (code
, obj
);
1300 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1303 /* Evaluate the closure body */
1304 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1310 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1312 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1313 if (scm_is_true (slotdef
))
1314 return get_slot_value (class, obj
, slotdef
);
1316 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1320 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1321 #define FUNC_NAME "%set-slot-value"
1323 SCM access
= SCM_CDDR (slotdef
);
1325 * - access is an integer (the offset of this slot in the slots vector)
1326 * - otherwise (cadr access) is the setter function to apply
1328 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1329 * we can just assume fixnums here.
1331 if (SCM_I_INUMP (access
))
1332 /* obey permissions bits via going through struct-set! */
1333 scm_struct_set_x (obj
, access
, value
);
1336 /* We must evaluate (apply (cadr l) (list obj value))
1337 * where (cadr l) is known to be a closure of arity 2 */
1338 register SCM code
, env
;
1340 code
= SCM_CADR (access
);
1341 if (!SCM_CLOSUREP (code
))
1342 scm_call_2 (code
, obj
, value
);
1345 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1346 scm_list_2 (obj
, value
),
1348 /* Evaluate the closure body */
1349 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1352 return SCM_UNSPECIFIED
;
1357 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1359 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1360 if (scm_is_true (slotdef
))
1361 return set_slot_value (class, obj
, slotdef
, value
);
1363 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1367 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1371 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1372 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1378 /* ======================================== */
1380 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1381 (SCM
class, SCM obj
, SCM slot_name
),
1383 #define FUNC_NAME s_scm_slot_ref_using_class
1387 SCM_VALIDATE_CLASS (1, class);
1388 SCM_VALIDATE_INSTANCE (2, obj
);
1389 SCM_VALIDATE_SYMBOL (3, slot_name
);
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
);
1399 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1400 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1402 #define FUNC_NAME s_scm_slot_set_using_class_x
1404 SCM_VALIDATE_CLASS (1, class);
1405 SCM_VALIDATE_INSTANCE (2, obj
);
1406 SCM_VALIDATE_SYMBOL (3, slot_name
);
1408 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1413 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1414 (SCM
class, SCM obj
, SCM slot_name
),
1416 #define FUNC_NAME s_scm_slot_bound_using_class_p
1418 SCM_VALIDATE_CLASS (1, class);
1419 SCM_VALIDATE_INSTANCE (2, obj
);
1420 SCM_VALIDATE_SYMBOL (3, slot_name
);
1422 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1428 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1429 (SCM
class, SCM obj
, SCM slot_name
),
1431 #define FUNC_NAME s_scm_slot_exists_using_class_p
1433 SCM_VALIDATE_CLASS (1, class);
1434 SCM_VALIDATE_INSTANCE (2, obj
);
1435 SCM_VALIDATE_SYMBOL (3, slot_name
);
1436 return test_slot_existence (class, obj
, slot_name
);
1441 /* ======================================== */
1443 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1444 (SCM obj
, SCM slot_name
),
1445 "Return the value from @var{obj}'s slot with the name\n"
1447 #define FUNC_NAME s_scm_slot_ref
1451 SCM_VALIDATE_INSTANCE (1, obj
);
1452 TEST_CHANGE_CLASS (obj
, class);
1454 res
= get_slot_value_using_name (class, obj
, slot_name
);
1455 if (SCM_GOOPS_UNBOUNDP (res
))
1456 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1461 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1462 (SCM obj
, SCM slot_name
, SCM value
),
1463 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1464 #define FUNC_NAME s_scm_slot_set_x
1468 SCM_VALIDATE_INSTANCE (1, obj
);
1469 TEST_CHANGE_CLASS(obj
, class);
1471 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1475 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1477 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1478 (SCM obj
, SCM slot_name
),
1479 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1481 #define FUNC_NAME s_scm_slot_bound_p
1485 SCM_VALIDATE_INSTANCE (1, obj
);
1486 TEST_CHANGE_CLASS(obj
, class);
1488 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1496 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1497 (SCM obj
, SCM slot_name
),
1498 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1499 #define FUNC_NAME s_scm_slot_exists_p
1503 SCM_VALIDATE_INSTANCE (1, obj
);
1504 SCM_VALIDATE_SYMBOL (2, slot_name
);
1505 TEST_CHANGE_CLASS (obj
, class);
1507 return test_slot_existence (class, obj
, slot_name
);
1512 /******************************************************************************
1514 * %allocate-instance (the low level instance allocation primitive)
1516 ******************************************************************************/
1518 static void clear_method_cache (SCM
);
1521 wrap_init (SCM
class, SCM
*m
, long n
)
1524 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1525 const char *layout
= scm_i_symbol_chars (SCM_PACK (slayout
));
1527 /* Set all SCM-holding slots to unbound */
1528 for (i
= 0; i
< n
; i
++)
1529 if (layout
[i
*2] == 'p')
1530 m
[i
] = SCM_GOOPS_UNBOUND
;
1534 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1536 (scm_t_bits
) m
, 0, 0);
1539 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1540 (SCM
class, SCM initargs
),
1541 "Create a new instance of class @var{class} and initialize it\n"
1542 "from the arguments @var{initargs}.")
1543 #define FUNC_NAME s_scm_sys_allocate_instance
1548 SCM_VALIDATE_CLASS (1, class);
1550 /* Most instances */
1551 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1553 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1554 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1555 return wrap_init (class, m
, n
);
1558 /* Foreign objects */
1559 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1560 return scm_make_foreign_object (class, initargs
);
1562 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1565 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1567 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1569 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1570 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1571 /* Generic functions */
1572 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1574 SCM gf
= wrap_init (class, m
, n
);
1575 clear_method_cache (gf
);
1579 return wrap_init (class, m
, n
);
1583 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1587 /* allocate class object */
1588 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1590 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1591 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1592 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1594 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1595 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1596 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1597 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1602 /* Non-light instances */
1604 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1605 return wrap_init (class, m
, n
);
1610 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1611 (SCM obj
, SCM setter
),
1613 #define FUNC_NAME s_scm_sys_set_object_setter_x
1615 SCM_ASSERT (SCM_STRUCTP (obj
)
1616 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1617 || SCM_I_ENTITYP (obj
)),
1621 if (SCM_I_ENTITYP (obj
))
1622 SCM_SET_ENTITY_SETTER (obj
, setter
);
1624 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1625 return SCM_UNSPECIFIED
;
1629 /******************************************************************************
1631 * %modify-instance (used by change-class to modify in place)
1633 ******************************************************************************/
1635 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1638 #define FUNC_NAME s_scm_sys_modify_instance
1640 SCM_VALIDATE_INSTANCE (1, old
);
1641 SCM_VALIDATE_INSTANCE (2, new);
1643 /* Exchange the data contained in old and new. We exchange rather than
1644 * scratch the old value with new to be correct with GC.
1645 * See "Class redefinition protocol above".
1647 SCM_CRITICAL_SECTION_START
;
1649 SCM car
= SCM_CAR (old
);
1650 SCM cdr
= SCM_CDR (old
);
1651 SCM_SETCAR (old
, SCM_CAR (new));
1652 SCM_SETCDR (old
, SCM_CDR (new));
1653 SCM_SETCAR (new, car
);
1654 SCM_SETCDR (new, cdr
);
1656 SCM_CRITICAL_SECTION_END
;
1657 return SCM_UNSPECIFIED
;
1661 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1664 #define FUNC_NAME s_scm_sys_modify_class
1666 SCM_VALIDATE_CLASS (1, old
);
1667 SCM_VALIDATE_CLASS (2, new);
1669 SCM_CRITICAL_SECTION_START
;
1671 SCM car
= SCM_CAR (old
);
1672 SCM cdr
= SCM_CDR (old
);
1673 SCM_SETCAR (old
, SCM_CAR (new));
1674 SCM_SETCDR (old
, SCM_CDR (new));
1675 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1676 SCM_SETCAR (new, car
);
1677 SCM_SETCDR (new, cdr
);
1678 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1680 SCM_CRITICAL_SECTION_END
;
1681 return SCM_UNSPECIFIED
;
1685 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1688 #define FUNC_NAME s_scm_sys_invalidate_class
1690 SCM_VALIDATE_CLASS (1, class);
1691 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1692 return SCM_UNSPECIFIED
;
1696 /* When instances change class, they finally get a new body, but
1697 * before that, they go through purgatory in hell. Odd as it may
1698 * seem, this data structure saves us from eternal suffering in
1699 * infinite recursions.
1702 static scm_t_bits
**hell
;
1703 static long n_hell
= 1; /* one place for the evil one himself */
1704 static long hell_size
= 4;
1705 static SCM hell_mutex
;
1711 for (i
= 1; i
< n_hell
; ++i
)
1712 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1718 go_to_hell (void *o
)
1720 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1721 scm_lock_mutex (hell_mutex
);
1722 if (n_hell
>= hell_size
)
1725 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1727 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1728 scm_unlock_mutex (hell_mutex
);
1732 go_to_heaven (void *o
)
1734 scm_lock_mutex (hell_mutex
);
1735 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1736 scm_unlock_mutex (hell_mutex
);
1740 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1743 purgatory (void *args
)
1745 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1746 SCM_PACK ((scm_t_bits
) args
));
1749 /* This function calls the generic function change-class for all
1750 * instances which aren't currently undergoing class change.
1754 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1757 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1758 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1759 (void *) SCM_UNPACK (obj
));
1762 /******************************************************************************
1768 * GGG E N E R I C F U N C T I O N S
1770 * This implementation provides
1771 * - generic functions (with class specializers)
1774 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1776 ******************************************************************************/
1778 SCM_KEYWORD (k_name
, "name");
1780 SCM_SYMBOL (sym_no_method
, "no-method");
1782 static SCM list_of_no_method
;
1784 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1788 scm_make_method_cache (SCM gf
)
1790 return scm_list_5 (SCM_IM_DISPATCH
,
1793 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1799 clear_method_cache (SCM gf
)
1801 SCM cache
= scm_make_method_cache (gf
);
1802 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1803 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1806 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1809 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1812 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1813 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1814 if (scm_is_true (used_by
))
1816 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1817 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1818 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1819 clear_method_cache (gf
);
1820 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1821 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1824 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1825 /* The sign of n is a flag indicating rest args. */
1826 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1828 return SCM_UNSPECIFIED
;
1832 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1835 #define FUNC_NAME s_scm_generic_capability_p
1837 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1838 proc
, SCM_ARG1
, FUNC_NAME
);
1839 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1845 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1848 #define FUNC_NAME s_scm_enable_primitive_generic_x
1850 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1851 while (!scm_is_null (subrs
))
1853 SCM subr
= SCM_CAR (subrs
);
1854 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1855 subr
, SCM_ARGn
, FUNC_NAME
);
1856 *SCM_SUBR_GENERIC (subr
)
1857 = scm_make (scm_list_3 (scm_class_generic
,
1860 subrs
= SCM_CDR (subrs
);
1862 return SCM_UNSPECIFIED
;
1866 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1869 #define FUNC_NAME s_scm_primitive_generic_generic
1871 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1873 if (!*SCM_SUBR_GENERIC (subr
))
1874 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1875 return *SCM_SUBR_GENERIC (subr
);
1877 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1881 typedef struct t_extension
{
1882 struct t_extension
*next
;
1887 static t_extension
*extensions
= 0;
1889 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1892 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1897 if (!*SCM_SUBR_GENERIC (extended
))
1898 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1899 gf
= *SCM_SUBR_GENERIC (extended
);
1900 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1902 SCM_SNAME (extension
));
1903 *SCM_SUBR_GENERIC (extension
) = gext
;
1907 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1908 t_extension
**loc
= &extensions
;
1909 /* Make sure that extensions are placed before their own
1910 * extensions in the extensions list. O(N^2) algorithm, but
1911 * extensions of primitive generics are rare.
1913 while (*loc
&& extension
!= (*loc
)->extended
)
1914 loc
= &(*loc
)->next
;
1916 e
->extended
= extended
;
1917 e
->extension
= extension
;
1923 setup_extended_primitive_generics ()
1927 t_extension
*e
= extensions
;
1928 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1929 extensions
= e
->next
;
1934 /******************************************************************************
1936 * Protocol for calling a generic fumction
1937 * This protocol is roughly equivalent to (parameter are a little bit different
1938 * for efficiency reasons):
1940 * + apply-generic (gf args)
1941 * + compute-applicable-methods (gf args ...)
1942 * + sort-applicable-methods (methods args)
1943 * + apply-methods (gf methods args)
1945 * apply-methods calls make-next-method to build the "continuation" of a a
1946 * method. Applying a next-method will call apply-next-method which in
1947 * turn will call apply again to call effectively the following method.
1949 ******************************************************************************/
1952 applicablep (SCM actual
, SCM formal
)
1954 /* We already know that the cpl is well formed. */
1955 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1959 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1961 register SCM s1
, s2
;
1965 * m1 and m2 can have != length (i.e. one can be one element longer than the
1966 * other when we have a dotted parameter list). For instance, with the call
1969 * (define-method M (a . l) ....)
1970 * (define-method M (a) ....)
1972 * we consider that the second method is more specific.
1974 * BTW, targs is an array of types. We don't need it's size since
1975 * we already know that m1 and m2 are applicable (no risk to go past
1976 * the end of this array).
1979 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1980 if (scm_is_null(s1
)) return 1;
1981 if (scm_is_null(s2
)) return 0;
1982 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1983 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1985 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1986 if (cs1
== SCM_CAR(l
))
1988 if (cs2
== SCM_CAR(l
))
1991 return 0;/* should not occur! */
1994 return 0; /* should not occur! */
1997 #define BUFFSIZE 32 /* big enough for most uses */
2000 scm_i_vector2list (SCM l
, long len
)
2003 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2005 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
2006 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2012 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2015 SCM
*v
, vector
= SCM_EOL
;
2016 SCM buffer
[BUFFSIZE
];
2017 SCM save
= method_list
;
2018 scm_t_array_handle handle
;
2020 /* For reasonably sized method_lists we can try to avoid all the
2021 * consing and reorder the list in place...
2022 * This idea is due to David McClain <Dave_McClain@msn.com>
2024 if (size
<= BUFFSIZE
)
2026 for (i
= 0; i
< size
; i
++)
2028 buffer
[i
] = SCM_CAR (method_list
);
2029 method_list
= SCM_CDR (method_list
);
2035 /* Too many elements in method_list to keep everything locally */
2036 vector
= scm_i_vector2list (save
, size
);
2037 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2040 /* Use a simple shell sort since it is generally faster than qsort on
2041 * small vectors (which is probably mostly the case when we have to
2042 * sort a list of applicable methods).
2044 for (incr
= size
/ 2; incr
; incr
/= 2)
2046 for (i
= incr
; i
< size
; i
++)
2048 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2050 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2054 SCM tmp
= v
[j
+ incr
];
2062 if (size
<= BUFFSIZE
)
2064 /* We did it in locally, so restore the original list (reordered) in-place */
2065 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2067 SCM_SETCAR (method_list
, *v
);
2068 method_list
= SCM_CDR (method_list
);
2073 /* If we are here, that's that we did it the hard way... */
2074 scm_array_handle_release (&handle
);
2075 return scm_vector_to_list (vector
);
2079 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2083 SCM l
, fl
, applicable
= SCM_EOL
;
2085 SCM buffer
[BUFFSIZE
];
2089 scm_t_array_handle handle
;
2091 /* Build the list of arguments types */
2092 if (len
>= BUFFSIZE
)
2094 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2095 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2098 note that we don't have to work to reset the generation
2099 count. TMP is a new vector anyway, and it is found
2106 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2107 *p
++ = scm_class_of (SCM_CAR (args
));
2109 /* Build a list of all applicable methods */
2110 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2112 fl
= SPEC_OF (SCM_CAR (l
));
2113 /* Only accept accessors which match exactly in first arg. */
2114 if (SCM_ACCESSORP (SCM_CAR (l
))
2115 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2117 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2119 if (SCM_INSTANCEP (fl
)
2120 /* We have a dotted argument list */
2121 || (i
>= len
&& scm_is_null (fl
)))
2122 { /* both list exhausted */
2123 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2129 || !applicablep (types
[i
], SCM_CAR (fl
)))
2134 if (len
>= BUFFSIZE
)
2135 scm_array_handle_release (&handle
);
2141 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2142 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2148 : sort_applicable_methods (applicable
, count
, types
));
2152 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2155 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2158 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2159 #define FUNC_NAME s_sys_compute_applicable_methods
2162 SCM_VALIDATE_GENERIC (1, gf
);
2163 n
= scm_ilength (args
);
2164 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2165 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2169 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2170 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
));
2173 lock_cache_mutex (void *m
)
2175 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2176 scm_lock_mutex (mutex
);
2180 unlock_cache_mutex (void *m
)
2182 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2183 scm_unlock_mutex (mutex
);
2187 call_memoize_method (void *a
)
2189 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2190 SCM gf
= SCM_CAR (args
);
2191 SCM x
= SCM_CADR (args
);
2192 /* First check if another thread has inserted a method between
2193 * the cache miss and locking the mutex.
2195 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2196 if (scm_is_true (cmethod
))
2199 if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x
)))
2200 var_memoize_method_x
=
2201 scm_permanent_object
2202 (scm_module_variable (scm_module_goops
, sym_memoize_method_x
));
2204 return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x
), gf
, SCM_CDDR (args
), x
);
2208 scm_memoize_method (SCM x
, SCM args
)
2210 SCM gf
= SCM_CAR (scm_last_pair (x
));
2211 return scm_internal_dynamic_wind (
2213 call_memoize_method
,
2215 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2216 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2219 /******************************************************************************
2221 * A simple make (which will be redefined later in Scheme)
2222 * This version handles only creation of gf, methods and classes (no instances)
2224 * Since this code will disappear when Goops will be fully booted,
2225 * no precaution is taken to be efficient.
2227 ******************************************************************************/
2229 SCM_KEYWORD (k_setter
, "setter");
2230 SCM_KEYWORD (k_specializers
, "specializers");
2231 SCM_KEYWORD (k_procedure
, "procedure");
2232 SCM_KEYWORD (k_formals
, "formals");
2233 SCM_KEYWORD (k_body
, "body");
2234 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2235 SCM_KEYWORD (k_dsupers
, "dsupers");
2236 SCM_KEYWORD (k_slots
, "slots");
2237 SCM_KEYWORD (k_gf
, "generic-function");
2239 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2241 "Make a new object. @var{args} must contain the class and\n"
2242 "all necessary initialization information.")
2243 #define FUNC_NAME s_scm_make
2246 long len
= scm_ilength (args
);
2248 if (len
<= 0 || (len
& 1) == 0)
2249 SCM_WRONG_NUM_ARGS ();
2251 class = SCM_CAR(args
);
2252 args
= SCM_CDR(args
);
2254 if (class == scm_class_generic
|| class == scm_class_accessor
)
2256 z
= scm_make_struct (class, SCM_INUM0
,
2257 scm_list_5 (SCM_EOL
,
2262 scm_set_procedure_property_x (z
, scm_sym_name
,
2263 scm_get_keyword (k_name
,
2266 clear_method_cache (z
);
2267 if (class == scm_class_accessor
)
2269 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2270 if (scm_is_true (setter
))
2271 scm_sys_set_object_setter_x (z
, setter
);
2276 z
= scm_sys_allocate_instance (class, args
);
2278 if (class == scm_class_method
2279 || class == scm_class_simple_method
2280 || class == scm_class_accessor_method
)
2282 SCM_SET_SLOT (z
, scm_si_generic_function
,
2283 scm_i_get_keyword (k_gf
,
2288 SCM_SET_SLOT (z
, scm_si_specializers
,
2289 scm_i_get_keyword (k_specializers
,
2294 SCM_SET_SLOT (z
, scm_si_procedure
,
2295 scm_i_get_keyword (k_procedure
,
2300 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2301 SCM_SET_SLOT (z
, scm_si_formals
,
2302 scm_i_get_keyword (k_formals
,
2307 SCM_SET_SLOT (z
, scm_si_body
,
2308 scm_i_get_keyword (k_body
,
2313 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2314 scm_i_get_keyword (k_make_procedure
,
2322 /* In all the others case, make a new class .... No instance here */
2323 SCM_SET_SLOT (z
, scm_si_name
,
2324 scm_i_get_keyword (k_name
,
2327 scm_from_locale_symbol ("???"),
2329 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2330 scm_i_get_keyword (k_dsupers
,
2335 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2336 scm_i_get_keyword (k_slots
,
2347 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2350 #define FUNC_NAME s_scm_find_method
2353 long len
= scm_ilength (l
);
2356 SCM_WRONG_NUM_ARGS ();
2358 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2359 SCM_VALIDATE_GENERIC (1, gf
);
2360 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2361 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2363 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2367 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2368 (SCM m1
, SCM m2
, SCM targs
),
2369 "Return true if method @var{m1} is more specific than @var{m2} "
2370 "given the argument types (classes) listed in @var{targs}.")
2371 #define FUNC_NAME s_scm_sys_method_more_specific_p
2375 long i
, len
, m1_specs
, m2_specs
;
2376 scm_t_array_handle handle
;
2378 SCM_VALIDATE_METHOD (1, m1
);
2379 SCM_VALIDATE_METHOD (2, m2
);
2381 len
= scm_ilength (targs
);
2382 m1_specs
= scm_ilength (SPEC_OF (m1
));
2383 m2_specs
= scm_ilength (SPEC_OF (m2
));
2384 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2385 targs
, SCM_ARG3
, FUNC_NAME
);
2387 /* Verify that all the arguments of TARGS are classes and place them
2390 v
= scm_c_make_vector (len
, SCM_EOL
);
2391 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2393 for (i
= 0, l
= targs
;
2394 i
< len
&& scm_is_pair (l
);
2395 i
++, l
= SCM_CDR (l
))
2397 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2398 v_elts
[i
] = SCM_CAR (l
);
2400 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2402 scm_array_handle_release (&handle
);
2410 /******************************************************************************
2414 ******************************************************************************/
2417 fix_cpl (SCM c
, SCM before
, SCM after
)
2419 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2420 SCM ls
= scm_c_memq (after
, cpl
);
2421 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2422 if (scm_is_false (ls
))
2423 /* if this condition occurs, fix_cpl should not be applied this way */
2425 SCM_SETCAR (ls
, before
);
2426 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2428 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2429 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2430 SCM g_n_s
= compute_getters_n_setters (slots
);
2431 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2432 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2438 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2440 SCM tmp
= scm_from_locale_symbol (name
);
2442 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2446 : scm_list_1 (super
),
2452 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2455 create_standard_classes (void)
2458 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2459 scm_from_locale_symbol ("specializers"),
2461 scm_from_locale_symbol ("code-table"),
2462 scm_from_locale_symbol ("formals"),
2463 scm_from_locale_symbol ("body"),
2464 scm_from_locale_symbol ("make-procedure"),
2466 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2468 k_slot_definition
));
2469 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2470 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2474 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2475 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2478 scm_list_3 (scm_from_locale_symbol ("used-by"),
2481 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2484 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2487 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2490 /* Foreign class slot classes */
2491 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2492 scm_class_class
, scm_class_top
, SCM_EOL
);
2493 make_stdcls (&scm_class_protected
, "<protected-slot>",
2494 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2495 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2496 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2497 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2498 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2499 make_stdcls (&scm_class_self
, "<self-slot>",
2501 scm_class_read_only
,
2503 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2505 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2507 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2509 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2511 make_stdcls (&scm_class_scm
, "<scm-slot>",
2512 scm_class_class
, scm_class_protected
, SCM_EOL
);
2513 make_stdcls (&scm_class_int
, "<int-slot>",
2514 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2515 make_stdcls (&scm_class_float
, "<float-slot>",
2516 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2517 make_stdcls (&scm_class_double
, "<double-slot>",
2518 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2520 /* Continue initialization of class <class> */
2522 slots
= build_class_class_slots ();
2523 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2524 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2525 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2526 compute_getters_n_setters (slots
));
2528 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2529 scm_class_class
, scm_class_class
,
2530 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2533 scm_list_3 (scm_from_locale_symbol ("destructor"),
2535 scm_class_opaque
)));
2536 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2537 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2538 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2540 /* scm_class_generic functions classes */
2541 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2542 scm_class_class
, scm_class_class
, SCM_EOL
);
2543 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2544 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2545 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2546 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2547 make_stdcls (&scm_class_operator_with_setter_class
,
2548 "<operator-with-setter-class>",
2549 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2550 make_stdcls (&scm_class_method
, "<method>",
2551 scm_class_class
, scm_class_object
, method_slots
);
2552 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2553 scm_class_class
, scm_class_method
, SCM_EOL
);
2554 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2555 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2556 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2557 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2558 make_stdcls (&scm_class_applicable
, "<applicable>",
2559 scm_class_class
, scm_class_top
, SCM_EOL
);
2560 make_stdcls (&scm_class_entity
, "<entity>",
2561 scm_class_entity_class
,
2562 scm_list_2 (scm_class_object
, scm_class_applicable
),
2564 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2565 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2566 make_stdcls (&scm_class_generic
, "<generic>",
2567 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2568 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2569 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2570 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2571 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2572 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2573 scm_class_entity_class
,
2574 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2576 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2577 make_stdcls (&scm_class_accessor
, "<accessor>",
2578 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2579 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2580 make_stdcls (&scm_class_extended_generic_with_setter
,
2581 "<extended-generic-with-setter>",
2582 scm_class_entity_class
,
2583 scm_list_2 (scm_class_generic_with_setter
,
2584 scm_class_extended_generic
),
2586 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2587 SCM_CLASSF_PURE_GENERIC
);
2588 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2589 scm_class_entity_class
,
2590 scm_list_2 (scm_class_accessor
,
2591 scm_class_extended_generic_with_setter
),
2593 fix_cpl (scm_class_extended_accessor
,
2594 scm_class_extended_generic
, scm_class_generic
);
2595 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2597 /* Primitive types classes */
2598 make_stdcls (&scm_class_boolean
, "<boolean>",
2599 scm_class_class
, scm_class_top
, SCM_EOL
);
2600 make_stdcls (&scm_class_char
, "<char>",
2601 scm_class_class
, scm_class_top
, SCM_EOL
);
2602 make_stdcls (&scm_class_list
, "<list>",
2603 scm_class_class
, scm_class_top
, SCM_EOL
);
2604 make_stdcls (&scm_class_pair
, "<pair>",
2605 scm_class_class
, scm_class_list
, SCM_EOL
);
2606 make_stdcls (&scm_class_null
, "<null>",
2607 scm_class_class
, scm_class_list
, SCM_EOL
);
2608 make_stdcls (&scm_class_string
, "<string>",
2609 scm_class_class
, scm_class_top
, SCM_EOL
);
2610 make_stdcls (&scm_class_symbol
, "<symbol>",
2611 scm_class_class
, scm_class_top
, SCM_EOL
);
2612 make_stdcls (&scm_class_vector
, "<vector>",
2613 scm_class_class
, scm_class_top
, SCM_EOL
);
2614 make_stdcls (&scm_class_number
, "<number>",
2615 scm_class_class
, scm_class_top
, SCM_EOL
);
2616 make_stdcls (&scm_class_complex
, "<complex>",
2617 scm_class_class
, scm_class_number
, SCM_EOL
);
2618 make_stdcls (&scm_class_real
, "<real>",
2619 scm_class_class
, scm_class_complex
, SCM_EOL
);
2620 make_stdcls (&scm_class_integer
, "<integer>",
2621 scm_class_class
, scm_class_real
, SCM_EOL
);
2622 make_stdcls (&scm_class_fraction
, "<fraction>",
2623 scm_class_class
, scm_class_real
, SCM_EOL
);
2624 make_stdcls (&scm_class_keyword
, "<keyword>",
2625 scm_class_class
, scm_class_top
, SCM_EOL
);
2626 make_stdcls (&scm_class_unknown
, "<unknown>",
2627 scm_class_class
, scm_class_top
, SCM_EOL
);
2628 make_stdcls (&scm_class_procedure
, "<procedure>",
2629 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2630 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2631 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2632 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2633 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2634 make_stdcls (&scm_class_port
, "<port>",
2635 scm_class_class
, scm_class_top
, SCM_EOL
);
2636 make_stdcls (&scm_class_input_port
, "<input-port>",
2637 scm_class_class
, scm_class_port
, SCM_EOL
);
2638 make_stdcls (&scm_class_output_port
, "<output-port>",
2639 scm_class_class
, scm_class_port
, SCM_EOL
);
2640 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2642 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2646 /**********************************************************************
2650 **********************************************************************/
2653 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2659 sprintf (buffer
, template, type_name
);
2660 name
= scm_from_locale_symbol (buffer
);
2663 name
= SCM_GOOPS_UNBOUND
;
2665 class = scm_permanent_object (scm_basic_make_class (applicablep
2666 ? scm_class_procedure_class
2672 /* Only define name if doesn't already exist. */
2673 if (!SCM_GOOPS_UNBOUNDP (name
)
2674 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2675 DEFVAR (name
, class);
2680 scm_make_extended_class (char const *type_name
, int applicablep
)
2682 return make_class_from_template ("<%s>",
2684 scm_list_1 (applicablep
2685 ? scm_class_applicable
2691 scm_i_inherit_applicable (SCM c
)
2693 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2695 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2696 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2697 /* patch scm_class_applicable into direct-supers */
2698 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2699 if (scm_is_false (top
))
2700 dsupers
= scm_append (scm_list_2 (dsupers
,
2701 scm_list_1 (scm_class_applicable
)));
2704 SCM_SETCAR (top
, scm_class_applicable
);
2705 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2707 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2708 /* patch scm_class_applicable into cpl */
2709 top
= scm_c_memq (scm_class_top
, cpl
);
2710 if (scm_is_false (top
))
2714 SCM_SETCAR (top
, scm_class_applicable
);
2715 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2717 /* add class to direct-subclasses of scm_class_applicable */
2718 SCM_SET_SLOT (scm_class_applicable
,
2719 scm_si_direct_subclasses
,
2720 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2721 scm_si_direct_subclasses
)));
2726 create_smob_classes (void)
2730 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2731 for (i
= 0; i
< 255; ++i
)
2732 scm_smob_class
[i
] = 0;
2734 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2736 for (i
= 0; i
< scm_numsmob
; ++i
)
2737 if (!scm_smob_class
[i
])
2738 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2739 scm_smobs
[i
].apply
!= 0);
2743 scm_make_port_classes (long ptobnum
, char *type_name
)
2745 SCM c
, class = make_class_from_template ("<%s-port>",
2747 scm_list_1 (scm_class_port
),
2749 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2750 = make_class_from_template ("<%s-input-port>",
2752 scm_list_2 (class, scm_class_input_port
),
2754 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2755 = make_class_from_template ("<%s-output-port>",
2757 scm_list_2 (class, scm_class_output_port
),
2759 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2761 = make_class_from_template ("<%s-input-output-port>",
2763 scm_list_2 (class, scm_class_input_output_port
),
2765 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2766 SCM_SET_SLOT (c
, scm_si_cpl
,
2767 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2771 create_port_classes (void)
2775 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2776 for (i
= 0; i
< 3 * 256; ++i
)
2777 scm_port_class
[i
] = 0;
2779 for (i
= 0; i
< scm_numptob
; ++i
)
2780 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2784 make_struct_class (void *closure SCM_UNUSED
,
2785 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2787 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2788 SCM_SET_STRUCT_TABLE_CLASS (data
,
2789 scm_make_extended_class
2790 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2791 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2792 return SCM_UNSPECIFIED
;
2796 create_struct_classes (void)
2798 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2801 /**********************************************************************
2805 **********************************************************************/
2810 if (!goops_loaded_p
)
2811 scm_c_resolve_module ("oop goops");
2816 scm_make_foreign_object (SCM
class, SCM initargs
)
2817 #define FUNC_NAME s_scm_make
2819 void * (*constructor
) (SCM
)
2820 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2821 if (constructor
== 0)
2822 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2823 return scm_wrap_object (class, constructor (initargs
));
2829 scm_free_foreign_object (SCM
*class, SCM
*data
)
2831 size_t (*destructor
) (void *)
2832 = (size_t (*) (void *)) class[scm_si_destructor
];
2833 return destructor (data
);
2837 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2838 void * (*constructor
) (SCM initargs
),
2839 size_t (*destructor
) (void *))
2842 name
= scm_from_locale_symbol (s_name
);
2843 if (scm_is_null (supers
))
2844 supers
= scm_list_1 (scm_class_foreign_object
);
2845 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2846 scm_sys_inherit_magic_x (class, supers
);
2848 if (destructor
!= 0)
2850 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2851 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2855 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2856 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2859 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2860 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2865 SCM_SYMBOL (sym_o
, "o");
2866 SCM_SYMBOL (sym_x
, "x");
2868 SCM_KEYWORD (k_accessor
, "accessor");
2869 SCM_KEYWORD (k_getter
, "getter");
2872 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2874 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2879 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2880 SCM (*getter
) (SCM obj
),
2881 SCM (*setter
) (SCM obj
, SCM x
),
2882 char *accessor_name
)
2885 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2886 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2887 setter
? setter
: default_setter
);
2889 /* Dirk:FIXME:: The following two expressions make use of the fact that
2890 * the memoizer will accept a subr-object in the place of a function.
2891 * This is not guaranteed to stay this way. */
2892 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2894 scm_list_2 (get
, sym_o
)),
2896 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2897 scm_list_2 (sym_o
, sym_x
),
2898 scm_list_3 (set
, sym_o
, sym_x
)),
2902 SCM name
= scm_from_locale_symbol (slot_name
);
2903 SCM aname
= scm_from_locale_symbol (accessor_name
);
2904 SCM gf
= scm_ensure_accessor (aname
);
2905 SCM slot
= scm_list_5 (name
,
2908 setter
? k_accessor
: k_getter
,
2910 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2915 scm_add_method (scm_setter (gf
),
2916 scm_make (scm_list_5 (scm_class_accessor_method
,
2918 scm_list_2 (class, scm_class_top
),
2923 SCM_SET_SLOT (class, scm_si_slots
,
2924 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2925 scm_list_1 (slot
))));
2927 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2928 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
2930 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2931 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2932 scm_list_1 (gns
))));
2933 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2940 scm_wrap_object (SCM
class, void *data
)
2942 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2950 scm_wrap_component (SCM
class, SCM container
, void *data
)
2952 SCM obj
= scm_wrap_object (class, data
);
2953 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2959 SCM_SETCDR (handle
, container
);
2964 scm_ensure_accessor (SCM name
)
2966 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2967 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2969 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2970 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2971 k_name
, name
, k_setter
, gf
));
2976 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2979 scm_add_method (SCM gf
, SCM m
)
2981 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2986 * Debugging utilities
2989 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2991 "Return @code{#t} if @var{obj} is a pure generic.")
2992 #define FUNC_NAME s_scm_pure_generic_p
2994 return scm_from_bool (SCM_PUREGENERICP (obj
));
2998 #endif /* GUILE_DEBUG */
3004 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
3006 "Announce that GOOPS is loaded and perform initialization\n"
3007 "on the C level which depends on the loaded GOOPS modules.")
3008 #define FUNC_NAME s_scm_sys_goops_loaded
3011 var_compute_applicable_methods
=
3012 scm_permanent_object
3013 (scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
));
3015 scm_permanent_object
3016 (scm_module_variable (scm_module_goops
, sym_slot_unbound
));
3018 scm_permanent_object
3019 (scm_module_variable (scm_module_goops
, sym_slot_missing
));
3021 scm_permanent_object
3022 (scm_module_variable (scm_module_goops
, sym_compute_cpl
));
3023 var_no_applicable_method
=
3024 scm_permanent_object
3025 (scm_module_variable (scm_module_goops
, sym_no_applicable_method
));
3027 scm_permanent_object
3028 (scm_module_variable (scm_module_goops
, sym_change_class
));
3029 setup_extended_primitive_generics ();
3030 return SCM_UNSPECIFIED
;
3034 SCM scm_module_goops
;
3037 scm_init_goops_builtins (void)
3039 scm_module_goops
= scm_current_module ();
3041 /* Not really necessary right now, but who knows...
3043 scm_permanent_object (scm_module_goops
);
3045 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
3046 (scm_from_int (37)));
3048 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3050 #include "libguile/goops.x"
3052 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3054 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3055 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3057 create_basic_classes ();
3058 create_standard_classes ();
3059 create_smob_classes ();
3060 create_struct_classes ();
3061 create_port_classes ();
3064 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3065 scm_no_applicable_method
3066 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3069 DEFVAR (name
, scm_no_applicable_method
);
3072 return SCM_UNSPECIFIED
;
3078 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3079 scm_init_goops_builtins
);