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 #define DEFVAR(v, val) \
63 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
65 /* Temporary hack until we get the new module system */
66 /*fixme* Should optimize by keeping track of the variable object itself */
67 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
70 /* Fixme: Should use already interned symbols */
72 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
74 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
76 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
78 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
81 /* Class redefinition protocol:
83 A class is represented by a heap header h1 which points to a
84 malloc:ed memory block m1.
86 When a new version of a class is created, a new header h2 and
87 memory block m2 are allocated. The headers h1 and h2 then switch
88 pointers so that h1 refers to m2 and h2 to m1. In this way, names
89 bound to h1 will point to the new class at the same time as h2 will
90 be a handle which the GC will use to free m1.
92 The `redefined' slot of m1 will be set to point to h1. An old
93 instance will have its class pointer (the CAR of the heap header)
94 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
95 the class modification and the new class pointer can be found via
99 /* The following definition is located in libguile/objects.h:
100 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
103 #define TEST_CHANGE_CLASS(obj, class) \
105 class = SCM_CLASS_OF (obj); \
106 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
108 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
109 class = SCM_CLASS_OF (obj); \
113 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
114 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
116 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
117 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
119 static int goops_loaded_p
= 0;
120 static scm_t_rstate
*goops_rstate
;
122 static SCM scm_goops_lookup_closure
;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
126 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
127 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
128 SCM scm_class_vector
, scm_class_null
;
129 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
130 SCM scm_class_unknown
;
131 SCM scm_class_top
, scm_class_object
, scm_class_class
;
132 SCM scm_class_applicable
;
133 SCM scm_class_entity
, scm_class_entity_with_setter
;
134 SCM scm_class_generic
, scm_class_generic_with_setter
;
135 SCM scm_class_accessor
;
136 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
137 SCM scm_class_extended_accessor
;
138 SCM scm_class_method
;
139 SCM scm_class_simple_method
, scm_class_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
142 SCM scm_class_entity_class
;
143 SCM scm_class_number
, scm_class_list
;
144 SCM scm_class_keyword
;
145 SCM scm_class_port
, scm_class_input_output_port
;
146 SCM scm_class_input_port
, scm_class_output_port
;
147 SCM scm_class_foreign_class
, scm_class_foreign_object
;
148 SCM scm_class_foreign_slot
;
149 SCM scm_class_self
, scm_class_protected
;
150 SCM scm_class_opaque
, scm_class_read_only
;
151 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
153 SCM scm_class_int
, scm_class_float
, scm_class_double
;
155 SCM
*scm_port_class
= 0;
156 SCM
*scm_smob_class
= 0;
158 SCM scm_no_applicable_method
;
160 SCM_SYMBOL (scm_sym_define_public
, "define-public");
162 static SCM
scm_make_unbound (void);
163 static SCM
scm_unbound_p (SCM obj
);
164 static SCM
scm_assert_bound (SCM value
, SCM obj
);
165 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
166 static SCM
scm_sys_goops_loaded (void);
168 /* This function is used for efficient type dispatch. */
169 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
171 "Return the class of @var{x}.")
172 #define FUNC_NAME s_scm_class_of
174 switch (SCM_ITAG3 (x
))
178 return scm_class_integer
;
182 return scm_class_char
;
183 else if (scm_is_bool (x
))
184 return scm_class_boolean
;
185 else if (scm_is_null (x
))
186 return scm_class_null
;
188 return scm_class_unknown
;
191 switch (SCM_TYP7 (x
))
193 case scm_tcs_cons_nimcar
:
194 return scm_class_pair
;
195 case scm_tcs_closures
:
196 return scm_class_procedure
;
198 return scm_class_symbol
;
201 return scm_class_vector
;
203 return scm_class_string
;
205 switch SCM_TYP16 (x
) {
207 return scm_class_integer
;
209 return scm_class_real
;
210 case scm_tc16_complex
:
211 return scm_class_complex
;
212 case scm_tc16_fraction
:
213 return scm_class_fraction
;
223 case scm_tc7_subr_1o
:
224 case scm_tc7_subr_2o
:
225 case scm_tc7_lsubr_2
:
227 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
228 return scm_class_primitive_generic
;
230 return scm_class_procedure
;
232 return scm_class_procedure
;
234 return scm_class_procedure_with_setter
;
238 scm_t_bits type
= SCM_TYP16 (x
);
239 if (type
!= scm_tc16_port_with_ps
)
240 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
241 x
= SCM_PORT_WITH_PS_PORT (x
);
242 /* fall through to ports */
245 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
246 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
247 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
248 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
249 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
251 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
252 return SCM_CLASS_OF (x
);
253 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
256 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
257 scm_change_object_class (x
,
258 SCM_CLASS_OF (x
), /* old */
259 SCM_OBJ_CLASS_REDEF (x
)); /* new */
260 return SCM_CLASS_OF (x
);
264 /* ordinary struct */
265 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
266 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
267 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
270 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
271 SCM
class = scm_make_extended_class (scm_is_true (name
)
272 ? scm_i_symbol_chars (name
)
274 SCM_I_OPERATORP (x
));
275 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
281 return scm_class_pair
;
283 return scm_class_unknown
;
289 case scm_tc3_closure
:
293 return scm_class_unknown
;
297 /******************************************************************************
301 * This version doesn't fully handle multiple-inheritance. It serves
302 * only for booting classes and will be overloaded in Scheme
304 ******************************************************************************/
307 map (SCM (*proc
) (SCM
), SCM ls
)
309 if (scm_is_null (ls
))
313 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
316 while (!scm_is_null (ls
))
318 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
330 while (!scm_is_null (ls
))
332 SCM el
= SCM_CAR (ls
);
333 if (scm_is_false (scm_c_memq (el
, res
)))
334 res
= scm_cons (el
, res
);
341 compute_cpl (SCM
class)
344 return CALL_GF1 ("compute-cpl", class);
347 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
348 SCM ls
= scm_append (scm_acons (class, supers
,
349 map (compute_cpl
, supers
)));
350 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
354 /******************************************************************************
358 ******************************************************************************/
361 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
369 if (!scm_is_symbol (tmp
))
370 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
372 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
373 res
= scm_cons (SCM_CAR (l
), res
);
374 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
377 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
381 build_slots_list (SCM dslots
, SCM cpl
)
383 register SCM res
= dslots
;
385 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
386 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
387 scm_si_direct_slots
),
390 /* res contains a list of slots. Remove slots which appears more than once */
391 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
398 while (!scm_is_null (ls
))
400 if (!scm_is_pair (SCM_CAR (ls
)))
401 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
408 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
410 "Return a list consisting of the names of all slots belonging to\n"
411 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
413 #define FUNC_NAME s_scm_sys_compute_slots
415 SCM_VALIDATE_CLASS (1, class);
416 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
417 SCM_SLOT (class, scm_si_cpl
));
422 /******************************************************************************
424 * compute-getters-n-setters
426 * This version doesn't handle slot options. It serves only for booting
427 * classes and will be overloaded in Scheme.
429 ******************************************************************************/
431 SCM_KEYWORD (k_init_value
, "init-value");
432 SCM_KEYWORD (k_init_thunk
, "init-thunk");
435 compute_getters_n_setters (SCM slots
)
441 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
443 SCM init
= SCM_BOOL_F
;
444 SCM options
= SCM_CDAR (slots
);
445 if (!scm_is_null (options
))
447 init
= scm_get_keyword (k_init_value
, options
, 0);
450 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
452 scm_list_2 (scm_sym_quote
,
457 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
459 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
461 scm_from_int (i
++))),
463 cdrloc
= SCM_CDRLOC (*cdrloc
);
468 /******************************************************************************
472 ******************************************************************************/
474 /*fixme* Manufacture keywords in advance */
476 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
480 for (i
= 0; i
!= len
; i
+= 2)
482 SCM obj
= SCM_CAR (l
);
484 if (!scm_is_keyword (obj
))
485 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
486 else if (scm_is_eq (obj
, key
))
492 return default_value
;
496 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
497 (SCM key
, SCM l
, SCM default_value
),
498 "Determine an associated value for the keyword @var{key} from\n"
499 "the list @var{l}. The list @var{l} has to consist of an even\n"
500 "number of elements, where, starting with the first, every\n"
501 "second element is a keyword, followed by its associated value.\n"
502 "If @var{l} does not hold a value for @var{key}, the value\n"
503 "@var{default_value} is returned.")
504 #define FUNC_NAME s_scm_get_keyword
508 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
509 len
= scm_ilength (l
);
510 if (len
< 0 || len
% 2 == 1)
511 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
513 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
518 SCM_KEYWORD (k_init_keyword
, "init-keyword");
520 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
521 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
523 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
524 (SCM obj
, SCM initargs
),
525 "Initialize the object @var{obj} with the given arguments\n"
527 #define FUNC_NAME s_scm_sys_initialize_object
529 SCM tmp
, get_n_set
, slots
;
530 SCM
class = SCM_CLASS_OF (obj
);
533 SCM_VALIDATE_INSTANCE (1, obj
);
534 n_initargs
= scm_ilength (initargs
);
535 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
537 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
538 slots
= SCM_SLOT (class, scm_si_slots
);
540 /* See for each slot how it must be initialized */
542 !scm_is_null (slots
);
543 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
545 SCM slot_name
= SCM_CAR (slots
);
548 if (!scm_is_null (SCM_CDR (slot_name
)))
550 /* This slot admits (perhaps) to be initialized at creation time */
551 long n
= scm_ilength (SCM_CDR (slot_name
));
552 if (n
& 1) /* odd or -1 */
553 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
554 scm_list_1 (slot_name
));
555 tmp
= scm_i_get_keyword (k_init_keyword
,
560 slot_name
= SCM_CAR (slot_name
);
563 /* an initarg was provided for this slot */
564 if (!scm_is_keyword (tmp
))
565 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
567 slot_value
= scm_i_get_keyword (tmp
,
576 /* set slot to provided value */
577 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
580 /* set slot to its :init-form if it exists */
581 tmp
= SCM_CADAR (get_n_set
);
582 if (scm_is_true (tmp
))
584 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
585 if (SCM_GOOPS_UNBOUNDP (slot_value
))
586 set_slot_value (class,
598 /* NOTE: The following macros are interdependent with code
599 * in goops.scm:compute-getters-n-setters
601 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
602 (SCM_I_INUMP (SCM_CDDR (gns)) \
603 || (scm_is_pair (SCM_CDDR (gns)) \
604 && scm_is_pair (SCM_CDDDR (gns)) \
605 && scm_is_pair (SCM_CDDDDR (gns))))
606 #define SCM_GNS_INDEX(gns) \
607 (SCM_I_INUMP (SCM_CDDR (gns)) \
608 ? SCM_I_INUM (SCM_CDDR (gns)) \
609 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
610 #define SCM_GNS_SIZE(gns) \
611 (SCM_I_INUMP (SCM_CDDR (gns)) \
613 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
615 SCM_KEYWORD (k_class
, "class");
616 SCM_KEYWORD (k_allocation
, "allocation");
617 SCM_KEYWORD (k_instance
, "instance");
619 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
622 #define FUNC_NAME s_scm_sys_prep_layout_x
624 SCM slots
, getters_n_setters
, nfields
;
625 unsigned long int n
, i
;
629 SCM_VALIDATE_INSTANCE (1, class);
630 slots
= SCM_SLOT (class, scm_si_slots
);
631 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
632 nfields
= SCM_SLOT (class, scm_si_nfields
);
633 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
634 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
635 scm_list_1 (nfields
));
636 n
= 2 * SCM_I_INUM (nfields
);
637 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
638 && SCM_SUBCLASSP (class, scm_class_class
))
639 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
640 scm_list_1 (nfields
));
642 layout
= scm_i_make_string (n
, &s
);
644 while (scm_is_pair (getters_n_setters
))
646 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
649 int len
, index
, size
;
652 if (i
>= n
|| !scm_is_pair (slots
))
655 /* extract slot type */
656 len
= scm_ilength (SCM_CDAR (slots
));
657 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
658 len
, SCM_BOOL_F
, FUNC_NAME
);
659 /* determine slot GC protection and access mode */
660 if (scm_is_false (type
))
667 if (!SCM_CLASSP (type
))
668 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
669 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
671 if (SCM_SUBCLASSP (type
, scm_class_self
))
673 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
678 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
680 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
692 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
693 if (index
!= (i
>> 1))
695 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
703 slots
= SCM_CDR (slots
);
704 getters_n_setters
= SCM_CDR (getters_n_setters
);
706 if (!scm_is_null (slots
))
709 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
711 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
712 return SCM_UNSPECIFIED
;
716 static void prep_hashsets (SCM
);
718 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
719 (SCM
class, SCM dsupers
),
721 #define FUNC_NAME s_scm_sys_inherit_magic_x
725 SCM_VALIDATE_INSTANCE (1, class);
726 while (!scm_is_null (ls
))
728 SCM_ASSERT (scm_is_pair (ls
)
729 && SCM_INSTANCEP (SCM_CAR (ls
)),
733 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
736 flags
&= SCM_CLASSF_INHERIT
;
737 if (flags
& SCM_CLASSF_ENTITY
)
738 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
741 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
744 * We could avoid calling scm_gc_malloc in the allocation code
745 * (in which case the following two lines are needed). Instead
746 * we make 0-slot instances non-light, so that the light case
747 * can be handled without special cases.
750 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
752 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
754 /* NOTE: The following depends on scm_struct_i_size. */
755 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
756 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
759 SCM_SET_CLASS_FLAGS (class, flags
);
761 prep_hashsets (class);
763 return SCM_UNSPECIFIED
;
768 prep_hashsets (SCM
class)
772 for (i
= 0; i
< 7; ++i
)
773 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
776 /******************************************************************************/
779 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
781 SCM z
, cpl
, slots
, nfields
, g_n_s
;
783 /* Allocate one instance */
784 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
786 /* Initialize its slots */
787 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
788 cpl
= compute_cpl (z
);
789 slots
= build_slots_list (maplist (dslots
), cpl
);
790 nfields
= scm_from_int (scm_ilength (slots
));
791 g_n_s
= compute_getters_n_setters (slots
);
793 SCM_SET_SLOT (z
, scm_si_name
, name
);
794 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
795 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
796 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
797 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
798 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
799 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
800 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
801 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
802 SCM_SET_SLOT (z
, scm_si_environment
,
803 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
805 /* Add this class in the direct-subclasses slot of dsupers */
808 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
809 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
810 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
811 scm_si_direct_subclasses
)));
814 /* Support for the underlying structs: */
815 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
816 ? (SCM_CLASSF_GOOPS_OR_VALID
817 | SCM_CLASSF_OPERATOR
819 : class == scm_class_operator_class
820 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
821 : SCM_CLASSF_GOOPS_OR_VALID
));
826 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
828 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
829 scm_sys_inherit_magic_x (z
, dsupers
);
830 scm_sys_prep_layout_x (z
);
834 /******************************************************************************/
836 SCM_SYMBOL (sym_layout
, "layout");
837 SCM_SYMBOL (sym_vcell
, "vcell");
838 SCM_SYMBOL (sym_vtable
, "vtable");
839 SCM_SYMBOL (sym_print
, "print");
840 SCM_SYMBOL (sym_procedure
, "procedure");
841 SCM_SYMBOL (sym_setter
, "setter");
842 SCM_SYMBOL (sym_redefined
, "redefined");
843 SCM_SYMBOL (sym_h0
, "h0");
844 SCM_SYMBOL (sym_h1
, "h1");
845 SCM_SYMBOL (sym_h2
, "h2");
846 SCM_SYMBOL (sym_h3
, "h3");
847 SCM_SYMBOL (sym_h4
, "h4");
848 SCM_SYMBOL (sym_h5
, "h5");
849 SCM_SYMBOL (sym_h6
, "h6");
850 SCM_SYMBOL (sym_h7
, "h7");
851 SCM_SYMBOL (sym_name
, "name");
852 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
853 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
854 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
855 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
856 SCM_SYMBOL (sym_cpl
, "cpl");
857 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
858 SCM_SYMBOL (sym_slots
, "slots");
859 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
860 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
861 SCM_SYMBOL (sym_nfields
, "nfields");
862 SCM_SYMBOL (sym_environment
, "environment");
866 build_class_class_slots ()
869 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
870 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
871 scm_list_1 (sym_print
),
872 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
873 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
874 scm_list_1 (sym_redefined
),
875 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
876 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
877 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
878 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
879 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
880 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
881 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
882 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
883 scm_list_1 (sym_name
),
884 scm_list_1 (sym_direct_supers
),
885 scm_list_1 (sym_direct_slots
),
886 scm_list_1 (sym_direct_subclasses
),
887 scm_list_1 (sym_direct_methods
),
888 scm_list_1 (sym_cpl
),
889 scm_list_1 (sym_default_slot_definition_class
),
890 scm_list_1 (sym_slots
),
891 scm_list_1 (sym_getters_n_setters
),
892 scm_list_1 (sym_keyword_access
),
893 scm_list_1 (sym_nfields
),
894 scm_list_1 (sym_environment
),
899 create_basic_classes (void)
901 /* SCM slots_of_class = build_class_class_slots (); */
903 /**** <scm_class_class> ****/
904 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
905 + 2 * scm_vtable_offset_user
);
906 SCM name
= scm_from_locale_symbol ("<class>");
907 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
910 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
911 | SCM_CLASSF_METACLASS
));
913 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
914 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
915 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
916 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
917 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
918 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
919 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
920 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
921 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
922 compute_getters_n_setters (slots_of_class)); */
923 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
924 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
925 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
927 prep_hashsets (scm_class_class
);
929 DEFVAR(name
, scm_class_class
);
931 /**** <scm_class_top> ****/
932 name
= scm_from_locale_symbol ("<top>");
933 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
938 DEFVAR(name
, scm_class_top
);
940 /**** <scm_class_object> ****/
941 name
= scm_from_locale_symbol ("<object>");
942 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
944 scm_list_1 (scm_class_top
),
947 DEFVAR (name
, scm_class_object
);
949 /* <top> <object> and <class> were partially initialized. Correct them here */
950 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
952 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
953 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
956 /******************************************************************************/
958 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
960 "Return @code{#t} if @var{obj} is an instance.")
961 #define FUNC_NAME s_scm_instance_p
963 return scm_from_bool (SCM_INSTANCEP (obj
));
968 /******************************************************************************
970 * Meta object accessors
972 ******************************************************************************/
973 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
975 "Return the class name of @var{obj}.")
976 #define FUNC_NAME s_scm_class_name
978 SCM_VALIDATE_CLASS (1, obj
);
979 return scm_slot_ref (obj
, sym_name
);
983 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
985 "Return the direct superclasses of the class @var{obj}.")
986 #define FUNC_NAME s_scm_class_direct_supers
988 SCM_VALIDATE_CLASS (1, obj
);
989 return scm_slot_ref (obj
, sym_direct_supers
);
993 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
995 "Return the direct slots of the class @var{obj}.")
996 #define FUNC_NAME s_scm_class_direct_slots
998 SCM_VALIDATE_CLASS (1, obj
);
999 return scm_slot_ref (obj
, sym_direct_slots
);
1003 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1005 "Return the direct subclasses of the class @var{obj}.")
1006 #define FUNC_NAME s_scm_class_direct_subclasses
1008 SCM_VALIDATE_CLASS (1, obj
);
1009 return scm_slot_ref(obj
, sym_direct_subclasses
);
1013 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1015 "Return the direct methods of the class @var{obj}")
1016 #define FUNC_NAME s_scm_class_direct_methods
1018 SCM_VALIDATE_CLASS (1, obj
);
1019 return scm_slot_ref (obj
, sym_direct_methods
);
1023 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1025 "Return the class precedence list of the class @var{obj}.")
1026 #define FUNC_NAME s_scm_class_precedence_list
1028 SCM_VALIDATE_CLASS (1, obj
);
1029 return scm_slot_ref (obj
, sym_cpl
);
1033 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1035 "Return the slot list of the class @var{obj}.")
1036 #define FUNC_NAME s_scm_class_slots
1038 SCM_VALIDATE_CLASS (1, obj
);
1039 return scm_slot_ref (obj
, sym_slots
);
1043 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1045 "Return the environment of the class @var{obj}.")
1046 #define FUNC_NAME s_scm_class_environment
1048 SCM_VALIDATE_CLASS (1, obj
);
1049 return scm_slot_ref(obj
, sym_environment
);
1054 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1056 "Return the name of the generic function @var{obj}.")
1057 #define FUNC_NAME s_scm_generic_function_name
1059 SCM_VALIDATE_GENERIC (1, obj
);
1060 return scm_procedure_property (obj
, scm_sym_name
);
1064 SCM_SYMBOL (sym_methods
, "methods");
1065 SCM_SYMBOL (sym_extended_by
, "extended-by");
1066 SCM_SYMBOL (sym_extends
, "extends");
1069 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1071 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1072 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1073 while (!scm_is_null (gfs
))
1075 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1076 gfs
= SCM_CDR (gfs
);
1078 return method_lists
;
1082 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1084 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1086 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1087 while (!scm_is_null (gfs
))
1089 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1090 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1093 gfs
= SCM_CDR (gfs
);
1096 return method_lists
;
1099 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1101 "Return the methods of the generic function @var{obj}.")
1102 #define FUNC_NAME s_scm_generic_function_methods
1105 SCM_VALIDATE_GENERIC (1, obj
);
1106 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1107 methods
= fold_downward_gf_methods (methods
, obj
);
1108 return scm_append (methods
);
1112 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1114 "Return the generic function for the method @var{obj}.")
1115 #define FUNC_NAME s_scm_method_generic_function
1117 SCM_VALIDATE_METHOD (1, obj
);
1118 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1122 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1124 "Return specializers of the method @var{obj}.")
1125 #define FUNC_NAME s_scm_method_specializers
1127 SCM_VALIDATE_METHOD (1, obj
);
1128 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1132 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1134 "Return the procedure of the method @var{obj}.")
1135 #define FUNC_NAME s_scm_method_procedure
1137 SCM_VALIDATE_METHOD (1, obj
);
1138 return scm_slot_ref (obj
, sym_procedure
);
1142 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1144 "Return the slot definition of the accessor @var{obj}.")
1145 #define FUNC_NAME s_scm_accessor_method_slot_definition
1147 SCM_VALIDATE_ACCESSOR (1, obj
);
1148 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1152 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1154 "Internal GOOPS magic---don't use this function!")
1155 #define FUNC_NAME s_scm_sys_tag_body
1157 return scm_cons (SCM_IM_LAMBDA
, body
);
1161 /******************************************************************************
1163 * S l o t a c c e s s
1165 ******************************************************************************/
1167 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1169 "Return the unbound value.")
1170 #define FUNC_NAME s_scm_make_unbound
1172 return SCM_GOOPS_UNBOUND
;
1176 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1178 "Return @code{#t} if @var{obj} is unbound.")
1179 #define FUNC_NAME s_scm_unbound_p
1181 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1185 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1186 (SCM value
, SCM obj
),
1187 "Return @var{value} if it is bound, and invoke the\n"
1188 "@var{slot-unbound} method of @var{obj} if it is not.")
1189 #define FUNC_NAME s_scm_assert_bound
1191 if (SCM_GOOPS_UNBOUNDP (value
))
1192 return CALL_GF1 ("slot-unbound", obj
);
1197 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1198 (SCM obj
, SCM index
),
1199 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1200 "the value from @var{obj}.")
1201 #define FUNC_NAME s_scm_at_assert_bound_ref
1203 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1204 if (SCM_GOOPS_UNBOUNDP (value
))
1205 return CALL_GF1 ("slot-unbound", obj
);
1210 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1211 (SCM obj
, SCM index
),
1212 "Return the slot value with index @var{index} from @var{obj}.")
1213 #define FUNC_NAME s_scm_sys_fast_slot_ref
1215 unsigned long int i
;
1217 SCM_VALIDATE_INSTANCE (1, obj
);
1218 i
= scm_to_unsigned_integer (index
, 0,
1219 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1222 return SCM_SLOT (obj
, i
);
1226 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1227 (SCM obj
, SCM index
, SCM value
),
1228 "Set the slot with index @var{index} in @var{obj} to\n"
1230 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1232 unsigned long int i
;
1234 SCM_VALIDATE_INSTANCE (1, obj
);
1235 i
= scm_to_unsigned_integer (index
, 0,
1236 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1240 SCM_SET_SLOT (obj
, i
, value
);
1242 return SCM_UNSPECIFIED
;
1247 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1248 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1253 /* In the future, this function will return the effective slot
1254 * definition associated with SLOT_NAME. Now it just returns some of
1255 * the information which will be stored in the effective slot
1260 slot_definition_using_name (SCM
class, SCM slot_name
)
1262 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1263 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1264 if (SCM_CAAR (slots
) == slot_name
)
1265 return SCM_CAR (slots
);
1270 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1271 #define FUNC_NAME "%get-slot-value"
1273 SCM access
= SCM_CDDR (slotdef
);
1275 * - access is an integer (the offset of this slot in the slots vector)
1276 * - otherwise (car access) is the getter function to apply
1278 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1279 * we can just assume fixnums here.
1281 if (SCM_I_INUMP (access
))
1282 /* Don't poke at the slots directly, because scm_struct_ref handles the
1283 access bits for us. */
1284 return scm_struct_ref (obj
, access
);
1287 /* We must evaluate (apply (car access) (list obj))
1288 * where (car access) is known to be a closure of arity 1 */
1289 register SCM code
, env
;
1291 code
= SCM_CAR (access
);
1292 if (!SCM_CLOSUREP (code
))
1293 return scm_call_1 (code
, obj
);
1294 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1297 /* Evaluate the closure body */
1298 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1304 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1306 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1307 if (scm_is_true (slotdef
))
1308 return get_slot_value (class, obj
, slotdef
);
1310 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1314 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1315 #define FUNC_NAME "%set-slot-value"
1317 SCM access
= SCM_CDDR (slotdef
);
1319 * - access is an integer (the offset of this slot in the slots vector)
1320 * - otherwise (cadr access) is the setter function to apply
1322 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1323 * we can just assume fixnums here.
1325 if (SCM_I_INUMP (access
))
1326 /* obey permissions bits via going through struct-set! */
1327 scm_struct_set_x (obj
, access
, value
);
1330 /* We must evaluate (apply (cadr l) (list obj value))
1331 * where (cadr l) is known to be a closure of arity 2 */
1332 register SCM code
, env
;
1334 code
= SCM_CADR (access
);
1335 if (!SCM_CLOSUREP (code
))
1336 scm_call_2 (code
, obj
, value
);
1339 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1340 scm_list_2 (obj
, value
),
1342 /* Evaluate the closure body */
1343 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1346 return SCM_UNSPECIFIED
;
1351 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1353 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1354 if (scm_is_true (slotdef
))
1355 return set_slot_value (class, obj
, slotdef
, value
);
1357 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1361 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1365 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1366 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1372 /* ======================================== */
1374 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1375 (SCM
class, SCM obj
, SCM slot_name
),
1377 #define FUNC_NAME s_scm_slot_ref_using_class
1381 SCM_VALIDATE_CLASS (1, class);
1382 SCM_VALIDATE_INSTANCE (2, obj
);
1383 SCM_VALIDATE_SYMBOL (3, slot_name
);
1385 res
= get_slot_value_using_name (class, obj
, slot_name
);
1386 if (SCM_GOOPS_UNBOUNDP (res
))
1387 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1393 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1394 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1396 #define FUNC_NAME s_scm_slot_set_using_class_x
1398 SCM_VALIDATE_CLASS (1, class);
1399 SCM_VALIDATE_INSTANCE (2, obj
);
1400 SCM_VALIDATE_SYMBOL (3, slot_name
);
1402 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1407 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1408 (SCM
class, SCM obj
, SCM slot_name
),
1410 #define FUNC_NAME s_scm_slot_bound_using_class_p
1412 SCM_VALIDATE_CLASS (1, class);
1413 SCM_VALIDATE_INSTANCE (2, obj
);
1414 SCM_VALIDATE_SYMBOL (3, slot_name
);
1416 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1422 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1423 (SCM
class, SCM obj
, SCM slot_name
),
1425 #define FUNC_NAME s_scm_slot_exists_using_class_p
1427 SCM_VALIDATE_CLASS (1, class);
1428 SCM_VALIDATE_INSTANCE (2, obj
);
1429 SCM_VALIDATE_SYMBOL (3, slot_name
);
1430 return test_slot_existence (class, obj
, slot_name
);
1435 /* ======================================== */
1437 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1438 (SCM obj
, SCM slot_name
),
1439 "Return the value from @var{obj}'s slot with the name\n"
1441 #define FUNC_NAME s_scm_slot_ref
1445 SCM_VALIDATE_INSTANCE (1, obj
);
1446 TEST_CHANGE_CLASS (obj
, class);
1448 res
= get_slot_value_using_name (class, obj
, slot_name
);
1449 if (SCM_GOOPS_UNBOUNDP (res
))
1450 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1455 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1456 (SCM obj
, SCM slot_name
, SCM value
),
1457 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1458 #define FUNC_NAME s_scm_slot_set_x
1462 SCM_VALIDATE_INSTANCE (1, obj
);
1463 TEST_CHANGE_CLASS(obj
, class);
1465 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1469 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1471 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1472 (SCM obj
, SCM slot_name
),
1473 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1475 #define FUNC_NAME s_scm_slot_bound_p
1479 SCM_VALIDATE_INSTANCE (1, obj
);
1480 TEST_CHANGE_CLASS(obj
, class);
1482 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1490 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1491 (SCM obj
, SCM slot_name
),
1492 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1493 #define FUNC_NAME s_scm_slot_exists_p
1497 SCM_VALIDATE_INSTANCE (1, obj
);
1498 SCM_VALIDATE_SYMBOL (2, slot_name
);
1499 TEST_CHANGE_CLASS (obj
, class);
1501 return test_slot_existence (class, obj
, slot_name
);
1506 /******************************************************************************
1508 * %allocate-instance (the low level instance allocation primitive)
1510 ******************************************************************************/
1512 static void clear_method_cache (SCM
);
1515 wrap_init (SCM
class, SCM
*m
, long n
)
1518 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1519 const char *layout
= scm_i_symbol_chars (SCM_PACK (slayout
));
1521 /* Set all SCM-holding slots to unbound */
1522 for (i
= 0; i
< n
; i
++)
1523 if (layout
[i
*2] == 'p')
1524 m
[i
] = SCM_GOOPS_UNBOUND
;
1528 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1530 (scm_t_bits
) m
, 0, 0);
1533 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1534 (SCM
class, SCM initargs
),
1535 "Create a new instance of class @var{class} and initialize it\n"
1536 "from the arguments @var{initargs}.")
1537 #define FUNC_NAME s_scm_sys_allocate_instance
1542 SCM_VALIDATE_CLASS (1, class);
1544 /* Most instances */
1545 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1547 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1548 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1549 return wrap_init (class, m
, n
);
1552 /* Foreign objects */
1553 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1554 return scm_make_foreign_object (class, initargs
);
1556 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1559 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1561 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1563 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1564 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1565 /* Generic functions */
1566 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1568 SCM gf
= wrap_init (class, m
, n
);
1569 clear_method_cache (gf
);
1573 return wrap_init (class, m
, n
);
1577 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1581 /* allocate class object */
1582 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1584 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1585 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1586 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1588 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1589 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1590 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1591 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1596 /* Non-light instances */
1598 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1599 return wrap_init (class, m
, n
);
1604 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1605 (SCM obj
, SCM setter
),
1607 #define FUNC_NAME s_scm_sys_set_object_setter_x
1609 SCM_ASSERT (SCM_STRUCTP (obj
)
1610 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1611 || SCM_I_ENTITYP (obj
)),
1615 if (SCM_I_ENTITYP (obj
))
1616 SCM_SET_ENTITY_SETTER (obj
, setter
);
1618 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1619 return SCM_UNSPECIFIED
;
1623 /******************************************************************************
1625 * %modify-instance (used by change-class to modify in place)
1627 ******************************************************************************/
1629 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1632 #define FUNC_NAME s_scm_sys_modify_instance
1634 SCM_VALIDATE_INSTANCE (1, old
);
1635 SCM_VALIDATE_INSTANCE (2, new);
1637 /* Exchange the data contained in old and new. We exchange rather than
1638 * scratch the old value with new to be correct with GC.
1639 * See "Class redefinition protocol above".
1641 SCM_CRITICAL_SECTION_START
;
1643 SCM car
= SCM_CAR (old
);
1644 SCM cdr
= SCM_CDR (old
);
1645 SCM_SETCAR (old
, SCM_CAR (new));
1646 SCM_SETCDR (old
, SCM_CDR (new));
1647 SCM_SETCAR (new, car
);
1648 SCM_SETCDR (new, cdr
);
1650 SCM_CRITICAL_SECTION_END
;
1651 return SCM_UNSPECIFIED
;
1655 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1658 #define FUNC_NAME s_scm_sys_modify_class
1660 SCM_VALIDATE_CLASS (1, old
);
1661 SCM_VALIDATE_CLASS (2, new);
1663 SCM_CRITICAL_SECTION_START
;
1665 SCM car
= SCM_CAR (old
);
1666 SCM cdr
= SCM_CDR (old
);
1667 SCM_SETCAR (old
, SCM_CAR (new));
1668 SCM_SETCDR (old
, SCM_CDR (new));
1669 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1670 SCM_SETCAR (new, car
);
1671 SCM_SETCDR (new, cdr
);
1672 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1674 SCM_CRITICAL_SECTION_END
;
1675 return SCM_UNSPECIFIED
;
1679 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1682 #define FUNC_NAME s_scm_sys_invalidate_class
1684 SCM_VALIDATE_CLASS (1, class);
1685 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1686 return SCM_UNSPECIFIED
;
1690 /* When instances change class, they finally get a new body, but
1691 * before that, they go through purgatory in hell. Odd as it may
1692 * seem, this data structure saves us from eternal suffering in
1693 * infinite recursions.
1696 static scm_t_bits
**hell
;
1697 static long n_hell
= 1; /* one place for the evil one himself */
1698 static long hell_size
= 4;
1699 static SCM hell_mutex
;
1705 for (i
= 1; i
< n_hell
; ++i
)
1706 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1712 go_to_hell (void *o
)
1714 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1715 scm_lock_mutex (hell_mutex
);
1716 if (n_hell
>= hell_size
)
1719 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1721 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1722 scm_unlock_mutex (hell_mutex
);
1726 go_to_heaven (void *o
)
1728 scm_lock_mutex (hell_mutex
);
1729 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1730 scm_unlock_mutex (hell_mutex
);
1734 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1737 purgatory (void *args
)
1739 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1740 SCM_PACK ((scm_t_bits
) args
));
1743 /* This function calls the generic function change-class for all
1744 * instances which aren't currently undergoing class change.
1748 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1751 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1752 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1753 (void *) SCM_UNPACK (obj
));
1756 /******************************************************************************
1762 * GGG E N E R I C F U N C T I O N S
1764 * This implementation provides
1765 * - generic functions (with class specializers)
1768 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1770 ******************************************************************************/
1772 SCM_KEYWORD (k_name
, "name");
1774 SCM_SYMBOL (sym_no_method
, "no-method");
1776 static SCM list_of_no_method
;
1778 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1782 scm_make_method_cache (SCM gf
)
1784 return scm_list_5 (SCM_IM_DISPATCH
,
1787 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1793 clear_method_cache (SCM gf
)
1795 SCM cache
= scm_make_method_cache (gf
);
1796 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1797 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1800 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1803 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1806 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1807 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1808 if (scm_is_true (used_by
))
1810 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1811 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1812 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1813 clear_method_cache (gf
);
1814 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1815 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1818 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1819 /* The sign of n is a flag indicating rest args. */
1820 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1822 return SCM_UNSPECIFIED
;
1826 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1829 #define FUNC_NAME s_scm_generic_capability_p
1831 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1832 proc
, SCM_ARG1
, FUNC_NAME
);
1833 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1839 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1842 #define FUNC_NAME s_scm_enable_primitive_generic_x
1844 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1845 while (!scm_is_null (subrs
))
1847 SCM subr
= SCM_CAR (subrs
);
1848 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1849 subr
, SCM_ARGn
, FUNC_NAME
);
1850 *SCM_SUBR_GENERIC (subr
)
1851 = scm_make (scm_list_3 (scm_class_generic
,
1854 subrs
= SCM_CDR (subrs
);
1856 return SCM_UNSPECIFIED
;
1860 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1863 #define FUNC_NAME s_scm_primitive_generic_generic
1865 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1867 if (!*SCM_SUBR_GENERIC (subr
))
1868 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1869 return *SCM_SUBR_GENERIC (subr
);
1871 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1875 typedef struct t_extension
{
1876 struct t_extension
*next
;
1881 static t_extension
*extensions
= 0;
1883 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1886 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1891 if (!*SCM_SUBR_GENERIC (extended
))
1892 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1893 gf
= *SCM_SUBR_GENERIC (extended
);
1894 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1896 SCM_SNAME (extension
));
1897 *SCM_SUBR_GENERIC (extension
) = gext
;
1901 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1902 t_extension
**loc
= &extensions
;
1903 /* Make sure that extensions are placed before their own
1904 * extensions in the extensions list. O(N^2) algorithm, but
1905 * extensions of primitive generics are rare.
1907 while (*loc
&& extension
!= (*loc
)->extended
)
1908 loc
= &(*loc
)->next
;
1910 e
->extended
= extended
;
1911 e
->extension
= extension
;
1917 setup_extended_primitive_generics ()
1921 t_extension
*e
= extensions
;
1922 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1923 extensions
= e
->next
;
1928 /******************************************************************************
1930 * Protocol for calling a generic fumction
1931 * This protocol is roughly equivalent to (parameter are a little bit different
1932 * for efficiency reasons):
1934 * + apply-generic (gf args)
1935 * + compute-applicable-methods (gf args ...)
1936 * + sort-applicable-methods (methods args)
1937 * + apply-methods (gf methods args)
1939 * apply-methods calls make-next-method to build the "continuation" of a a
1940 * method. Applying a next-method will call apply-next-method which in
1941 * turn will call apply again to call effectively the following method.
1943 ******************************************************************************/
1946 applicablep (SCM actual
, SCM formal
)
1948 /* We already know that the cpl is well formed. */
1949 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1953 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1955 register SCM s1
, s2
;
1959 * m1 and m2 can have != length (i.e. one can be one element longer than the
1960 * other when we have a dotted parameter list). For instance, with the call
1963 * (define-method M (a . l) ....)
1964 * (define-method M (a) ....)
1966 * we consider that the second method is more specific.
1968 * BTW, targs is an array of types. We don't need it's size since
1969 * we already know that m1 and m2 are applicable (no risk to go past
1970 * the end of this array).
1973 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1974 if (scm_is_null(s1
)) return 1;
1975 if (scm_is_null(s2
)) return 0;
1976 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1977 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1979 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1980 if (cs1
== SCM_CAR(l
))
1982 if (cs2
== SCM_CAR(l
))
1985 return 0;/* should not occur! */
1988 return 0; /* should not occur! */
1991 #define BUFFSIZE 32 /* big enough for most uses */
1994 scm_i_vector2list (SCM l
, long len
)
1997 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1999 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
2000 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2006 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2009 SCM
*v
, vector
= SCM_EOL
;
2010 SCM buffer
[BUFFSIZE
];
2011 SCM save
= method_list
;
2012 scm_t_array_handle handle
;
2014 /* For reasonably sized method_lists we can try to avoid all the
2015 * consing and reorder the list in place...
2016 * This idea is due to David McClain <Dave_McClain@msn.com>
2018 if (size
<= BUFFSIZE
)
2020 for (i
= 0; i
< size
; i
++)
2022 buffer
[i
] = SCM_CAR (method_list
);
2023 method_list
= SCM_CDR (method_list
);
2029 /* Too many elements in method_list to keep everything locally */
2030 vector
= scm_i_vector2list (save
, size
);
2031 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2034 /* Use a simple shell sort since it is generally faster than qsort on
2035 * small vectors (which is probably mostly the case when we have to
2036 * sort a list of applicable methods).
2038 for (incr
= size
/ 2; incr
; incr
/= 2)
2040 for (i
= incr
; i
< size
; i
++)
2042 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2044 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2048 SCM tmp
= v
[j
+ incr
];
2056 if (size
<= BUFFSIZE
)
2058 /* We did it in locally, so restore the original list (reordered) in-place */
2059 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2061 SCM_SETCAR (method_list
, *v
);
2062 method_list
= SCM_CDR (method_list
);
2067 /* If we are here, that's that we did it the hard way... */
2068 scm_array_handle_release (&handle
);
2069 return scm_vector_to_list (vector
);
2073 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2077 SCM l
, fl
, applicable
= SCM_EOL
;
2079 SCM buffer
[BUFFSIZE
];
2083 scm_t_array_handle handle
;
2085 /* Build the list of arguments types */
2086 if (len
>= BUFFSIZE
)
2088 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2089 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2092 note that we don't have to work to reset the generation
2093 count. TMP is a new vector anyway, and it is found
2100 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2101 *p
++ = scm_class_of (SCM_CAR (args
));
2103 /* Build a list of all applicable methods */
2104 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2106 fl
= SPEC_OF (SCM_CAR (l
));
2107 /* Only accept accessors which match exactly in first arg. */
2108 if (SCM_ACCESSORP (SCM_CAR (l
))
2109 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2111 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2113 if (SCM_INSTANCEP (fl
)
2114 /* We have a dotted argument list */
2115 || (i
>= len
&& scm_is_null (fl
)))
2116 { /* both list exhausted */
2117 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2123 || !applicablep (types
[i
], SCM_CAR (fl
)))
2128 if (len
>= BUFFSIZE
)
2129 scm_array_handle_release (&handle
);
2135 CALL_GF2 ("no-applicable-method", gf
, save
);
2136 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2142 : sort_applicable_methods (applicable
, count
, types
));
2146 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2149 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2152 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2153 #define FUNC_NAME s_sys_compute_applicable_methods
2156 SCM_VALIDATE_GENERIC (1, gf
);
2157 n
= scm_ilength (args
);
2158 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2159 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2163 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2164 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
));
2167 lock_cache_mutex (void *m
)
2169 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2170 scm_lock_mutex (mutex
);
2174 unlock_cache_mutex (void *m
)
2176 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2177 scm_unlock_mutex (mutex
);
2181 call_memoize_method (void *a
)
2183 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2184 SCM gf
= SCM_CAR (args
);
2185 SCM x
= SCM_CADR (args
);
2186 /* First check if another thread has inserted a method between
2187 * the cache miss and locking the mutex.
2189 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2190 if (scm_is_true (cmethod
))
2192 /*fixme* Use scm_apply */
2193 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2197 scm_memoize_method (SCM x
, SCM args
)
2199 SCM gf
= SCM_CAR (scm_last_pair (x
));
2200 return scm_internal_dynamic_wind (
2202 call_memoize_method
,
2204 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2205 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2208 /******************************************************************************
2210 * A simple make (which will be redefined later in Scheme)
2211 * This version handles only creation of gf, methods and classes (no instances)
2213 * Since this code will disappear when Goops will be fully booted,
2214 * no precaution is taken to be efficient.
2216 ******************************************************************************/
2218 SCM_KEYWORD (k_setter
, "setter");
2219 SCM_KEYWORD (k_specializers
, "specializers");
2220 SCM_KEYWORD (k_procedure
, "procedure");
2221 SCM_KEYWORD (k_formals
, "formals");
2222 SCM_KEYWORD (k_body
, "body");
2223 SCM_KEYWORD (k_compile_env
, "compile-env");
2224 SCM_KEYWORD (k_dsupers
, "dsupers");
2225 SCM_KEYWORD (k_slots
, "slots");
2226 SCM_KEYWORD (k_gf
, "generic-function");
2228 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2230 "Make a new object. @var{args} must contain the class and\n"
2231 "all necessary initialization information.")
2232 #define FUNC_NAME s_scm_make
2235 long len
= scm_ilength (args
);
2237 if (len
<= 0 || (len
& 1) == 0)
2238 SCM_WRONG_NUM_ARGS ();
2240 class = SCM_CAR(args
);
2241 args
= SCM_CDR(args
);
2243 if (class == scm_class_generic
|| class == scm_class_accessor
)
2245 z
= scm_make_struct (class, SCM_INUM0
,
2246 scm_list_5 (SCM_EOL
,
2251 scm_set_procedure_property_x (z
, scm_sym_name
,
2252 scm_get_keyword (k_name
,
2255 clear_method_cache (z
);
2256 if (class == scm_class_accessor
)
2258 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2259 if (scm_is_true (setter
))
2260 scm_sys_set_object_setter_x (z
, setter
);
2265 z
= scm_sys_allocate_instance (class, args
);
2267 if (class == scm_class_method
2268 || class == scm_class_simple_method
2269 || class == scm_class_accessor_method
)
2271 SCM_SET_SLOT (z
, scm_si_generic_function
,
2272 scm_i_get_keyword (k_gf
,
2277 SCM_SET_SLOT (z
, scm_si_specializers
,
2278 scm_i_get_keyword (k_specializers
,
2283 SCM_SET_SLOT (z
, scm_si_procedure
,
2284 scm_i_get_keyword (k_procedure
,
2289 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2290 SCM_SET_SLOT (z
, scm_si_formals
,
2291 scm_i_get_keyword (k_formals
,
2296 SCM_SET_SLOT (z
, scm_si_body
,
2297 scm_i_get_keyword (k_body
,
2302 SCM_SET_SLOT (z
, scm_si_compile_env
,
2303 scm_i_get_keyword (k_compile_env
,
2311 /* In all the others case, make a new class .... No instance here */
2312 SCM_SET_SLOT (z
, scm_si_name
,
2313 scm_i_get_keyword (k_name
,
2316 scm_from_locale_symbol ("???"),
2318 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2319 scm_i_get_keyword (k_dsupers
,
2324 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2325 scm_i_get_keyword (k_slots
,
2336 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2339 #define FUNC_NAME s_scm_find_method
2342 long len
= scm_ilength (l
);
2345 SCM_WRONG_NUM_ARGS ();
2347 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2348 SCM_VALIDATE_GENERIC (1, gf
);
2349 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2350 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2352 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2356 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2357 (SCM m1
, SCM m2
, SCM targs
),
2358 "Return true if method @var{m1} is more specific than @var{m2} "
2359 "given the argument types (classes) listed in @var{targs}.")
2360 #define FUNC_NAME s_scm_sys_method_more_specific_p
2364 long i
, len
, m1_specs
, m2_specs
;
2365 scm_t_array_handle handle
;
2367 SCM_VALIDATE_METHOD (1, m1
);
2368 SCM_VALIDATE_METHOD (2, m2
);
2370 len
= scm_ilength (targs
);
2371 m1_specs
= scm_ilength (SPEC_OF (m1
));
2372 m2_specs
= scm_ilength (SPEC_OF (m2
));
2373 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2374 targs
, SCM_ARG3
, FUNC_NAME
);
2376 /* Verify that all the arguments of TARGS are classes and place them
2379 v
= scm_c_make_vector (len
, SCM_EOL
);
2380 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2382 for (i
= 0, l
= targs
;
2383 i
< len
&& scm_is_pair (l
);
2384 i
++, l
= SCM_CDR (l
))
2386 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2387 v_elts
[i
] = SCM_CAR (l
);
2389 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2391 scm_array_handle_release (&handle
);
2399 /******************************************************************************
2403 ******************************************************************************/
2406 fix_cpl (SCM c
, SCM before
, SCM after
)
2408 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2409 SCM ls
= scm_c_memq (after
, cpl
);
2410 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2411 if (scm_is_false (ls
))
2412 /* if this condition occurs, fix_cpl should not be applied this way */
2414 SCM_SETCAR (ls
, before
);
2415 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2417 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2418 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2419 SCM g_n_s
= compute_getters_n_setters (slots
);
2420 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2421 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2427 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2429 SCM tmp
= scm_from_locale_symbol (name
);
2431 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2435 : scm_list_1 (super
),
2441 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2444 create_standard_classes (void)
2447 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2448 scm_from_locale_symbol ("specializers"),
2450 scm_from_locale_symbol ("code-table"),
2451 scm_from_locale_symbol ("formals"),
2452 scm_from_locale_symbol ("body"),
2453 scm_from_locale_symbol ("compile-env"),
2455 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2457 k_slot_definition
));
2458 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2459 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2463 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2464 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2467 scm_list_3 (scm_from_locale_symbol ("used-by"),
2470 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2473 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2476 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2479 /* Foreign class slot classes */
2480 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2481 scm_class_class
, scm_class_top
, SCM_EOL
);
2482 make_stdcls (&scm_class_protected
, "<protected-slot>",
2483 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2484 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2485 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2486 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2487 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2488 make_stdcls (&scm_class_self
, "<self-slot>",
2490 scm_class_read_only
,
2492 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2494 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2496 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2498 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2500 make_stdcls (&scm_class_scm
, "<scm-slot>",
2501 scm_class_class
, scm_class_protected
, SCM_EOL
);
2502 make_stdcls (&scm_class_int
, "<int-slot>",
2503 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2504 make_stdcls (&scm_class_float
, "<float-slot>",
2505 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2506 make_stdcls (&scm_class_double
, "<double-slot>",
2507 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2509 /* Continue initialization of class <class> */
2511 slots
= build_class_class_slots ();
2512 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2513 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2514 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2515 compute_getters_n_setters (slots
));
2517 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2518 scm_class_class
, scm_class_class
,
2519 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2522 scm_list_3 (scm_from_locale_symbol ("destructor"),
2524 scm_class_opaque
)));
2525 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2526 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2527 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2529 /* scm_class_generic functions classes */
2530 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2531 scm_class_class
, scm_class_class
, SCM_EOL
);
2532 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2533 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2534 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2535 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2536 make_stdcls (&scm_class_operator_with_setter_class
,
2537 "<operator-with-setter-class>",
2538 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2539 make_stdcls (&scm_class_method
, "<method>",
2540 scm_class_class
, scm_class_object
, method_slots
);
2541 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2542 scm_class_class
, scm_class_method
, SCM_EOL
);
2543 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2544 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2545 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2546 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2547 make_stdcls (&scm_class_applicable
, "<applicable>",
2548 scm_class_class
, scm_class_top
, SCM_EOL
);
2549 make_stdcls (&scm_class_entity
, "<entity>",
2550 scm_class_entity_class
,
2551 scm_list_2 (scm_class_object
, scm_class_applicable
),
2553 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2554 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2555 make_stdcls (&scm_class_generic
, "<generic>",
2556 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2557 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2558 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2559 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2560 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2561 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2562 scm_class_entity_class
,
2563 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2565 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2566 make_stdcls (&scm_class_accessor
, "<accessor>",
2567 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2568 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2569 make_stdcls (&scm_class_extended_generic_with_setter
,
2570 "<extended-generic-with-setter>",
2571 scm_class_entity_class
,
2572 scm_list_2 (scm_class_generic_with_setter
,
2573 scm_class_extended_generic
),
2575 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2576 SCM_CLASSF_PURE_GENERIC
);
2577 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2578 scm_class_entity_class
,
2579 scm_list_2 (scm_class_accessor
,
2580 scm_class_extended_generic_with_setter
),
2582 fix_cpl (scm_class_extended_accessor
,
2583 scm_class_extended_generic
, scm_class_generic
);
2584 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2586 /* Primitive types classes */
2587 make_stdcls (&scm_class_boolean
, "<boolean>",
2588 scm_class_class
, scm_class_top
, SCM_EOL
);
2589 make_stdcls (&scm_class_char
, "<char>",
2590 scm_class_class
, scm_class_top
, SCM_EOL
);
2591 make_stdcls (&scm_class_list
, "<list>",
2592 scm_class_class
, scm_class_top
, SCM_EOL
);
2593 make_stdcls (&scm_class_pair
, "<pair>",
2594 scm_class_class
, scm_class_list
, SCM_EOL
);
2595 make_stdcls (&scm_class_null
, "<null>",
2596 scm_class_class
, scm_class_list
, SCM_EOL
);
2597 make_stdcls (&scm_class_string
, "<string>",
2598 scm_class_class
, scm_class_top
, SCM_EOL
);
2599 make_stdcls (&scm_class_symbol
, "<symbol>",
2600 scm_class_class
, scm_class_top
, SCM_EOL
);
2601 make_stdcls (&scm_class_vector
, "<vector>",
2602 scm_class_class
, scm_class_top
, SCM_EOL
);
2603 make_stdcls (&scm_class_number
, "<number>",
2604 scm_class_class
, scm_class_top
, SCM_EOL
);
2605 make_stdcls (&scm_class_complex
, "<complex>",
2606 scm_class_class
, scm_class_number
, SCM_EOL
);
2607 make_stdcls (&scm_class_real
, "<real>",
2608 scm_class_class
, scm_class_complex
, SCM_EOL
);
2609 make_stdcls (&scm_class_integer
, "<integer>",
2610 scm_class_class
, scm_class_real
, SCM_EOL
);
2611 make_stdcls (&scm_class_fraction
, "<fraction>",
2612 scm_class_class
, scm_class_real
, SCM_EOL
);
2613 make_stdcls (&scm_class_keyword
, "<keyword>",
2614 scm_class_class
, scm_class_top
, SCM_EOL
);
2615 make_stdcls (&scm_class_unknown
, "<unknown>",
2616 scm_class_class
, scm_class_top
, SCM_EOL
);
2617 make_stdcls (&scm_class_procedure
, "<procedure>",
2618 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2619 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2620 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2621 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2622 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2623 make_stdcls (&scm_class_port
, "<port>",
2624 scm_class_class
, scm_class_top
, SCM_EOL
);
2625 make_stdcls (&scm_class_input_port
, "<input-port>",
2626 scm_class_class
, scm_class_port
, SCM_EOL
);
2627 make_stdcls (&scm_class_output_port
, "<output-port>",
2628 scm_class_class
, scm_class_port
, SCM_EOL
);
2629 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2631 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2635 /**********************************************************************
2639 **********************************************************************/
2642 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2648 sprintf (buffer
, template, type_name
);
2649 name
= scm_from_locale_symbol (buffer
);
2652 name
= SCM_GOOPS_UNBOUND
;
2654 class = scm_permanent_object (scm_basic_make_class (applicablep
2655 ? scm_class_procedure_class
2661 /* Only define name if doesn't already exist. */
2662 if (!SCM_GOOPS_UNBOUNDP (name
)
2663 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2664 DEFVAR (name
, class);
2669 scm_make_extended_class (char const *type_name
, int applicablep
)
2671 return make_class_from_template ("<%s>",
2673 scm_list_1 (applicablep
2674 ? scm_class_applicable
2680 scm_i_inherit_applicable (SCM c
)
2682 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2684 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2685 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2686 /* patch scm_class_applicable into direct-supers */
2687 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2688 if (scm_is_false (top
))
2689 dsupers
= scm_append (scm_list_2 (dsupers
,
2690 scm_list_1 (scm_class_applicable
)));
2693 SCM_SETCAR (top
, scm_class_applicable
);
2694 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2696 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2697 /* patch scm_class_applicable into cpl */
2698 top
= scm_c_memq (scm_class_top
, cpl
);
2699 if (scm_is_false (top
))
2703 SCM_SETCAR (top
, scm_class_applicable
);
2704 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2706 /* add class to direct-subclasses of scm_class_applicable */
2707 SCM_SET_SLOT (scm_class_applicable
,
2708 scm_si_direct_subclasses
,
2709 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2710 scm_si_direct_subclasses
)));
2715 create_smob_classes (void)
2719 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2720 for (i
= 0; i
< 255; ++i
)
2721 scm_smob_class
[i
] = 0;
2723 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2725 for (i
= 0; i
< scm_numsmob
; ++i
)
2726 if (!scm_smob_class
[i
])
2727 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2728 scm_smobs
[i
].apply
!= 0);
2732 scm_make_port_classes (long ptobnum
, char *type_name
)
2734 SCM c
, class = make_class_from_template ("<%s-port>",
2736 scm_list_1 (scm_class_port
),
2738 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2739 = make_class_from_template ("<%s-input-port>",
2741 scm_list_2 (class, scm_class_input_port
),
2743 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2744 = make_class_from_template ("<%s-output-port>",
2746 scm_list_2 (class, scm_class_output_port
),
2748 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2750 = make_class_from_template ("<%s-input-output-port>",
2752 scm_list_2 (class, scm_class_input_output_port
),
2754 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2755 SCM_SET_SLOT (c
, scm_si_cpl
,
2756 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2760 create_port_classes (void)
2764 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2765 for (i
= 0; i
< 3 * 256; ++i
)
2766 scm_port_class
[i
] = 0;
2768 for (i
= 0; i
< scm_numptob
; ++i
)
2769 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2773 make_struct_class (void *closure SCM_UNUSED
,
2774 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2776 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2777 SCM_SET_STRUCT_TABLE_CLASS (data
,
2778 scm_make_extended_class
2779 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2780 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2781 return SCM_UNSPECIFIED
;
2785 create_struct_classes (void)
2787 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2790 /**********************************************************************
2794 **********************************************************************/
2799 if (!goops_loaded_p
)
2800 scm_c_resolve_module ("oop goops");
2805 scm_make_foreign_object (SCM
class, SCM initargs
)
2806 #define FUNC_NAME s_scm_make
2808 void * (*constructor
) (SCM
)
2809 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2810 if (constructor
== 0)
2811 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2812 return scm_wrap_object (class, constructor (initargs
));
2818 scm_free_foreign_object (SCM
*class, SCM
*data
)
2820 size_t (*destructor
) (void *)
2821 = (size_t (*) (void *)) class[scm_si_destructor
];
2822 return destructor (data
);
2826 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2827 void * (*constructor
) (SCM initargs
),
2828 size_t (*destructor
) (void *))
2831 name
= scm_from_locale_symbol (s_name
);
2832 if (scm_is_null (supers
))
2833 supers
= scm_list_1 (scm_class_foreign_object
);
2834 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2835 scm_sys_inherit_magic_x (class, supers
);
2837 if (destructor
!= 0)
2839 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2840 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2844 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2845 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2848 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2849 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2854 SCM_SYMBOL (sym_o
, "o");
2855 SCM_SYMBOL (sym_x
, "x");
2857 SCM_KEYWORD (k_accessor
, "accessor");
2858 SCM_KEYWORD (k_getter
, "getter");
2861 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2863 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2868 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2869 SCM (*getter
) (SCM obj
),
2870 SCM (*setter
) (SCM obj
, SCM x
),
2871 char *accessor_name
)
2874 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2875 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2876 setter
? setter
: default_setter
);
2878 /* Dirk:FIXME:: The following two expressions make use of the fact that
2879 * the memoizer will accept a subr-object in the place of a function.
2880 * This is not guaranteed to stay this way. */
2881 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2883 scm_list_2 (get
, sym_o
)),
2885 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2886 scm_list_2 (sym_o
, sym_x
),
2887 scm_list_3 (set
, sym_o
, sym_x
)),
2891 SCM name
= scm_from_locale_symbol (slot_name
);
2892 SCM aname
= scm_from_locale_symbol (accessor_name
);
2893 SCM gf
= scm_ensure_accessor (aname
);
2894 SCM slot
= scm_list_5 (name
,
2897 setter
? k_accessor
: k_getter
,
2899 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2904 scm_add_method (scm_setter (gf
),
2905 scm_make (scm_list_5 (scm_class_accessor_method
,
2907 scm_list_2 (class, scm_class_top
),
2912 SCM_SET_SLOT (class, scm_si_slots
,
2913 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2914 scm_list_1 (slot
))));
2916 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2917 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
2919 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2920 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2921 scm_list_1 (gns
))));
2922 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2929 scm_wrap_object (SCM
class, void *data
)
2931 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2939 scm_wrap_component (SCM
class, SCM container
, void *data
)
2941 SCM obj
= scm_wrap_object (class, data
);
2942 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2948 SCM_SETCDR (handle
, container
);
2953 scm_ensure_accessor (SCM name
)
2955 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2956 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2958 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2959 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2960 k_name
, name
, k_setter
, gf
));
2965 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2968 scm_add_method (SCM gf
, SCM m
)
2970 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2975 * Debugging utilities
2978 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2980 "Return @code{#t} if @var{obj} is a pure generic.")
2981 #define FUNC_NAME s_scm_pure_generic_p
2983 return scm_from_bool (SCM_PUREGENERICP (obj
));
2987 #endif /* GUILE_DEBUG */
2993 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2995 "Announce that GOOPS is loaded and perform initialization\n"
2996 "on the C level which depends on the loaded GOOPS modules.")
2997 #define FUNC_NAME s_scm_sys_goops_loaded
3000 var_compute_applicable_methods
=
3001 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
3003 setup_extended_primitive_generics ();
3004 return SCM_UNSPECIFIED
;
3008 SCM scm_module_goops
;
3011 scm_init_goops_builtins (void)
3013 scm_module_goops
= scm_current_module ();
3014 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
3016 /* Not really necessary right now, but who knows...
3018 scm_permanent_object (scm_module_goops
);
3019 scm_permanent_object (scm_goops_lookup_closure
);
3021 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
3022 (scm_from_int (37)));
3024 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3026 #include "libguile/goops.x"
3028 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3030 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3031 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3033 create_basic_classes ();
3034 create_standard_classes ();
3035 create_smob_classes ();
3036 create_struct_classes ();
3037 create_port_classes ();
3040 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3041 scm_no_applicable_method
3042 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3045 DEFVAR (name
, scm_no_applicable_method
);
3048 return SCM_UNSPECIFIED
;
3054 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3055 scm_init_goops_builtins
);