1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
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
))
587 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
588 set_slot_value (class,
591 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
601 /* NOTE: The following macros are interdependent with code
602 * in goops.scm:compute-getters-n-setters
604 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
605 (SCM_I_INUMP (SCM_CDDR (gns)) \
606 || (scm_is_pair (SCM_CDDR (gns)) \
607 && scm_is_pair (SCM_CDDDR (gns)) \
608 && scm_is_pair (SCM_CDDDDR (gns))))
609 #define SCM_GNS_INDEX(gns) \
610 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 ? SCM_I_INUM (SCM_CDDR (gns)) \
612 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
613 #define SCM_GNS_SIZE(gns) \
614 (SCM_I_INUMP (SCM_CDDR (gns)) \
616 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
618 SCM_KEYWORD (k_class
, "class");
619 SCM_KEYWORD (k_allocation
, "allocation");
620 SCM_KEYWORD (k_instance
, "instance");
622 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
625 #define FUNC_NAME s_scm_sys_prep_layout_x
627 SCM slots
, getters_n_setters
, nfields
;
628 unsigned long int n
, i
;
632 SCM_VALIDATE_INSTANCE (1, class);
633 slots
= SCM_SLOT (class, scm_si_slots
);
634 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
635 nfields
= SCM_SLOT (class, scm_si_nfields
);
636 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
637 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
638 scm_list_1 (nfields
));
639 n
= 2 * SCM_I_INUM (nfields
);
640 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
641 && SCM_SUBCLASSP (class, scm_class_class
))
642 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
643 scm_list_1 (nfields
));
645 layout
= scm_i_make_string (n
, &s
);
647 while (scm_is_pair (getters_n_setters
))
649 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
652 int len
, index
, size
;
655 if (i
>= n
|| !scm_is_pair (slots
))
658 /* extract slot type */
659 len
= scm_ilength (SCM_CDAR (slots
));
660 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
661 len
, SCM_BOOL_F
, FUNC_NAME
);
662 /* determine slot GC protection and access mode */
663 if (scm_is_false (type
))
670 if (!SCM_CLASSP (type
))
671 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
672 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
674 if (SCM_SUBCLASSP (type
, scm_class_self
))
676 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
681 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
683 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
695 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
696 if (index
!= (i
>> 1))
698 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
706 slots
= SCM_CDR (slots
);
707 getters_n_setters
= SCM_CDR (getters_n_setters
);
709 if (!scm_is_null (slots
))
712 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
714 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
715 return SCM_UNSPECIFIED
;
719 static void prep_hashsets (SCM
);
721 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
722 (SCM
class, SCM dsupers
),
724 #define FUNC_NAME s_scm_sys_inherit_magic_x
728 SCM_VALIDATE_INSTANCE (1, class);
729 while (!scm_is_null (ls
))
731 SCM_ASSERT (scm_is_pair (ls
)
732 && SCM_INSTANCEP (SCM_CAR (ls
)),
736 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
739 flags
&= SCM_CLASSF_INHERIT
;
741 if (! (flags
& SCM_CLASSF_ENTITY
))
743 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
746 * We could avoid calling scm_gc_malloc in the allocation code
747 * (in which case the following two lines are needed). Instead
748 * we make 0-slot instances non-light, so that the light case
749 * can be handled without special cases.
752 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
754 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
756 /* NOTE: The following depends on scm_struct_i_size. */
757 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
760 SCM_SET_CLASS_FLAGS (class, flags
);
762 prep_hashsets (class);
764 return SCM_UNSPECIFIED
;
769 prep_hashsets (SCM
class)
773 for (i
= 0; i
< 7; ++i
)
774 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
777 /******************************************************************************/
780 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
782 SCM z
, cpl
, slots
, nfields
, g_n_s
;
784 /* Allocate one instance */
785 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
787 /* Initialize its slots */
788 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
789 cpl
= compute_cpl (z
);
790 slots
= build_slots_list (maplist (dslots
), cpl
);
791 nfields
= scm_from_int (scm_ilength (slots
));
792 g_n_s
= compute_getters_n_setters (slots
);
794 SCM_SET_SLOT (z
, scm_si_name
, name
);
795 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
796 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
797 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
798 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
799 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
800 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
801 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
802 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
803 SCM_SET_SLOT (z
, scm_si_environment
,
804 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
806 /* Add this class in the direct-subclasses slot of dsupers */
809 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
810 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
811 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
812 scm_si_direct_subclasses
)));
815 /* Support for the underlying structs: */
816 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
817 ? (SCM_CLASSF_GOOPS_OR_VALID
818 | SCM_CLASSF_OPERATOR
820 : class == scm_class_operator_class
821 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
822 : SCM_CLASSF_GOOPS_OR_VALID
));
827 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
829 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
830 scm_sys_inherit_magic_x (z
, dsupers
);
831 scm_sys_prep_layout_x (z
);
835 /******************************************************************************/
837 SCM_SYMBOL (sym_layout
, "layout");
838 SCM_SYMBOL (sym_vcell
, "vcell");
839 SCM_SYMBOL (sym_vtable
, "vtable");
840 SCM_SYMBOL (sym_print
, "print");
841 SCM_SYMBOL (sym_procedure
, "procedure");
842 SCM_SYMBOL (sym_setter
, "setter");
843 SCM_SYMBOL (sym_redefined
, "redefined");
844 SCM_SYMBOL (sym_h0
, "h0");
845 SCM_SYMBOL (sym_h1
, "h1");
846 SCM_SYMBOL (sym_h2
, "h2");
847 SCM_SYMBOL (sym_h3
, "h3");
848 SCM_SYMBOL (sym_h4
, "h4");
849 SCM_SYMBOL (sym_h5
, "h5");
850 SCM_SYMBOL (sym_h6
, "h6");
851 SCM_SYMBOL (sym_h7
, "h7");
852 SCM_SYMBOL (sym_name
, "name");
853 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
854 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
855 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
856 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
857 SCM_SYMBOL (sym_cpl
, "cpl");
858 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
859 SCM_SYMBOL (sym_slots
, "slots");
860 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
861 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
862 SCM_SYMBOL (sym_nfields
, "nfields");
863 SCM_SYMBOL (sym_environment
, "environment");
867 build_class_class_slots ()
870 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
871 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
872 scm_list_1 (sym_print
),
873 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
874 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
875 scm_list_1 (sym_redefined
),
876 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
877 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
878 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
879 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
880 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
881 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
882 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
883 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
884 scm_list_1 (sym_name
),
885 scm_list_1 (sym_direct_supers
),
886 scm_list_1 (sym_direct_slots
),
887 scm_list_1 (sym_direct_subclasses
),
888 scm_list_1 (sym_direct_methods
),
889 scm_list_1 (sym_cpl
),
890 scm_list_1 (sym_default_slot_definition_class
),
891 scm_list_1 (sym_slots
),
892 scm_list_1 (sym_getters_n_setters
),
893 scm_list_1 (sym_keyword_access
),
894 scm_list_1 (sym_nfields
),
895 scm_list_1 (sym_environment
),
900 create_basic_classes (void)
902 /* SCM slots_of_class = build_class_class_slots (); */
904 /**** <scm_class_class> ****/
905 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
906 + 2 * scm_vtable_offset_user
);
907 SCM name
= scm_from_locale_symbol ("<class>");
908 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
911 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
912 | SCM_CLASSF_METACLASS
));
914 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
915 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
916 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
917 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
918 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
919 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
920 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
921 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
922 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
923 compute_getters_n_setters (slots_of_class)); */
924 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
925 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
926 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
928 prep_hashsets (scm_class_class
);
930 DEFVAR(name
, scm_class_class
);
932 /**** <scm_class_top> ****/
933 name
= scm_from_locale_symbol ("<top>");
934 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
939 DEFVAR(name
, scm_class_top
);
941 /**** <scm_class_object> ****/
942 name
= scm_from_locale_symbol ("<object>");
943 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
945 scm_list_1 (scm_class_top
),
948 DEFVAR (name
, scm_class_object
);
950 /* <top> <object> and <class> were partially initialized. Correct them here */
951 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
953 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
954 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
957 /******************************************************************************/
959 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
961 "Return @code{#t} if @var{obj} is an instance.")
962 #define FUNC_NAME s_scm_instance_p
964 return scm_from_bool (SCM_INSTANCEP (obj
));
969 /******************************************************************************
971 * Meta object accessors
973 ******************************************************************************/
974 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
976 "Return the class name of @var{obj}.")
977 #define FUNC_NAME s_scm_class_name
979 SCM_VALIDATE_CLASS (1, obj
);
980 return scm_slot_ref (obj
, sym_name
);
984 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
986 "Return the direct superclasses of the class @var{obj}.")
987 #define FUNC_NAME s_scm_class_direct_supers
989 SCM_VALIDATE_CLASS (1, obj
);
990 return scm_slot_ref (obj
, sym_direct_supers
);
994 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
996 "Return the direct slots of the class @var{obj}.")
997 #define FUNC_NAME s_scm_class_direct_slots
999 SCM_VALIDATE_CLASS (1, obj
);
1000 return scm_slot_ref (obj
, sym_direct_slots
);
1004 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1006 "Return the direct subclasses of the class @var{obj}.")
1007 #define FUNC_NAME s_scm_class_direct_subclasses
1009 SCM_VALIDATE_CLASS (1, obj
);
1010 return scm_slot_ref(obj
, sym_direct_subclasses
);
1014 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1016 "Return the direct methods of the class @var{obj}")
1017 #define FUNC_NAME s_scm_class_direct_methods
1019 SCM_VALIDATE_CLASS (1, obj
);
1020 return scm_slot_ref (obj
, sym_direct_methods
);
1024 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1026 "Return the class precedence list of the class @var{obj}.")
1027 #define FUNC_NAME s_scm_class_precedence_list
1029 SCM_VALIDATE_CLASS (1, obj
);
1030 return scm_slot_ref (obj
, sym_cpl
);
1034 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1036 "Return the slot list of the class @var{obj}.")
1037 #define FUNC_NAME s_scm_class_slots
1039 SCM_VALIDATE_CLASS (1, obj
);
1040 return scm_slot_ref (obj
, sym_slots
);
1044 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1046 "Return the environment of the class @var{obj}.")
1047 #define FUNC_NAME s_scm_class_environment
1049 SCM_VALIDATE_CLASS (1, obj
);
1050 return scm_slot_ref(obj
, sym_environment
);
1055 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1057 "Return the name of the generic function @var{obj}.")
1058 #define FUNC_NAME s_scm_generic_function_name
1060 SCM_VALIDATE_GENERIC (1, obj
);
1061 return scm_procedure_property (obj
, scm_sym_name
);
1065 SCM_SYMBOL (sym_methods
, "methods");
1066 SCM_SYMBOL (sym_extended_by
, "extended-by");
1067 SCM_SYMBOL (sym_extends
, "extends");
1070 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1072 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1073 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1074 while (!scm_is_null (gfs
))
1076 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1077 gfs
= SCM_CDR (gfs
);
1079 return method_lists
;
1083 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1085 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1087 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1088 while (!scm_is_null (gfs
))
1090 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1091 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1094 gfs
= SCM_CDR (gfs
);
1097 return method_lists
;
1100 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1102 "Return the methods of the generic function @var{obj}.")
1103 #define FUNC_NAME s_scm_generic_function_methods
1106 SCM_VALIDATE_GENERIC (1, obj
);
1107 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1108 methods
= fold_downward_gf_methods (methods
, obj
);
1109 return scm_append (methods
);
1113 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1115 "Return the generic function for the method @var{obj}.")
1116 #define FUNC_NAME s_scm_method_generic_function
1118 SCM_VALIDATE_METHOD (1, obj
);
1119 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1123 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1125 "Return specializers of the method @var{obj}.")
1126 #define FUNC_NAME s_scm_method_specializers
1128 SCM_VALIDATE_METHOD (1, obj
);
1129 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1133 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1135 "Return the procedure of the method @var{obj}.")
1136 #define FUNC_NAME s_scm_method_procedure
1138 SCM_VALIDATE_METHOD (1, obj
);
1139 return scm_slot_ref (obj
, sym_procedure
);
1143 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1145 "Return the slot definition of the accessor @var{obj}.")
1146 #define FUNC_NAME s_scm_accessor_method_slot_definition
1148 SCM_VALIDATE_ACCESSOR (1, obj
);
1149 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1153 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1155 "Internal GOOPS magic---don't use this function!")
1156 #define FUNC_NAME s_scm_sys_tag_body
1158 return scm_cons (SCM_IM_LAMBDA
, body
);
1162 /******************************************************************************
1164 * S l o t a c c e s s
1166 ******************************************************************************/
1168 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1170 "Return the unbound value.")
1171 #define FUNC_NAME s_scm_make_unbound
1173 return SCM_GOOPS_UNBOUND
;
1177 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1179 "Return @code{#t} if @var{obj} is unbound.")
1180 #define FUNC_NAME s_scm_unbound_p
1182 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1186 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1187 (SCM value
, SCM obj
),
1188 "Return @var{value} if it is bound, and invoke the\n"
1189 "@var{slot-unbound} method of @var{obj} if it is not.")
1190 #define FUNC_NAME s_scm_assert_bound
1192 if (SCM_GOOPS_UNBOUNDP (value
))
1193 return CALL_GF1 ("slot-unbound", obj
);
1198 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1199 (SCM obj
, SCM index
),
1200 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1201 "the value from @var{obj}.")
1202 #define FUNC_NAME s_scm_at_assert_bound_ref
1204 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1205 if (SCM_GOOPS_UNBOUNDP (value
))
1206 return CALL_GF1 ("slot-unbound", obj
);
1211 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1212 (SCM obj
, SCM index
),
1213 "Return the slot value with index @var{index} from @var{obj}.")
1214 #define FUNC_NAME s_scm_sys_fast_slot_ref
1216 unsigned long int i
;
1218 SCM_VALIDATE_INSTANCE (1, obj
);
1219 i
= scm_to_unsigned_integer (index
, 0,
1220 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1223 return SCM_SLOT (obj
, i
);
1227 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1228 (SCM obj
, SCM index
, SCM value
),
1229 "Set the slot with index @var{index} in @var{obj} to\n"
1231 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1233 unsigned long int i
;
1235 SCM_VALIDATE_INSTANCE (1, obj
);
1236 i
= scm_to_unsigned_integer (index
, 0,
1237 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1241 SCM_SET_SLOT (obj
, i
, value
);
1243 return SCM_UNSPECIFIED
;
1248 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1249 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1254 /* In the future, this function will return the effective slot
1255 * definition associated with SLOT_NAME. Now it just returns some of
1256 * the information which will be stored in the effective slot
1261 slot_definition_using_name (SCM
class, SCM slot_name
)
1263 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1264 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1265 if (SCM_CAAR (slots
) == slot_name
)
1266 return SCM_CAR (slots
);
1271 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1272 #define FUNC_NAME "%get-slot-value"
1274 SCM access
= SCM_CDDR (slotdef
);
1276 * - access is an integer (the offset of this slot in the slots vector)
1277 * - otherwise (car access) is the getter function to apply
1279 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1280 * we can just assume fixnums here.
1282 if (SCM_I_INUMP (access
))
1283 /* Don't poke at the slots directly, because scm_struct_ref handles the
1284 access bits for us. */
1285 return scm_struct_ref (obj
, access
);
1288 /* We must evaluate (apply (car access) (list obj))
1289 * where (car access) is known to be a closure of arity 1 */
1290 register SCM code
, env
;
1292 code
= SCM_CAR (access
);
1293 if (!SCM_CLOSUREP (code
))
1294 return SCM_SUBRF (code
) (obj
);
1295 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1298 /* Evaluate the closure body */
1299 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1305 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1307 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1308 if (scm_is_true (slotdef
))
1309 return get_slot_value (class, obj
, slotdef
);
1311 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1315 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1316 #define FUNC_NAME "%set-slot-value"
1318 SCM access
= SCM_CDDR (slotdef
);
1320 * - access is an integer (the offset of this slot in the slots vector)
1321 * - otherwise (cadr access) is the setter function to apply
1323 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1324 * we can just assume fixnums here.
1326 if (SCM_I_INUMP (access
))
1327 /* obey permissions bits via going through struct-set! */
1328 scm_struct_set_x (obj
, access
, value
);
1331 /* We must evaluate (apply (cadr l) (list obj value))
1332 * where (cadr l) is known to be a closure of arity 2 */
1333 register SCM code
, env
;
1335 code
= SCM_CADR (access
);
1336 if (!SCM_CLOSUREP (code
))
1337 SCM_SUBRF (code
) (obj
, value
);
1340 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1341 scm_list_2 (obj
, value
),
1343 /* Evaluate the closure body */
1344 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1347 return SCM_UNSPECIFIED
;
1352 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1354 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1355 if (scm_is_true (slotdef
))
1356 return set_slot_value (class, obj
, slotdef
, value
);
1358 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1362 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1366 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1367 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1373 /* ======================================== */
1375 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1376 (SCM
class, SCM obj
, SCM slot_name
),
1378 #define FUNC_NAME s_scm_slot_ref_using_class
1382 SCM_VALIDATE_CLASS (1, class);
1383 SCM_VALIDATE_INSTANCE (2, obj
);
1384 SCM_VALIDATE_SYMBOL (3, slot_name
);
1386 res
= get_slot_value_using_name (class, obj
, slot_name
);
1387 if (SCM_GOOPS_UNBOUNDP (res
))
1388 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1394 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1395 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1397 #define FUNC_NAME s_scm_slot_set_using_class_x
1399 SCM_VALIDATE_CLASS (1, class);
1400 SCM_VALIDATE_INSTANCE (2, obj
);
1401 SCM_VALIDATE_SYMBOL (3, slot_name
);
1403 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1408 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1409 (SCM
class, SCM obj
, SCM slot_name
),
1411 #define FUNC_NAME s_scm_slot_bound_using_class_p
1413 SCM_VALIDATE_CLASS (1, class);
1414 SCM_VALIDATE_INSTANCE (2, obj
);
1415 SCM_VALIDATE_SYMBOL (3, slot_name
);
1417 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1423 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1424 (SCM
class, SCM obj
, SCM slot_name
),
1426 #define FUNC_NAME s_scm_slot_exists_using_class_p
1428 SCM_VALIDATE_CLASS (1, class);
1429 SCM_VALIDATE_INSTANCE (2, obj
);
1430 SCM_VALIDATE_SYMBOL (3, slot_name
);
1431 return test_slot_existence (class, obj
, slot_name
);
1436 /* ======================================== */
1438 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1439 (SCM obj
, SCM slot_name
),
1440 "Return the value from @var{obj}'s slot with the name\n"
1442 #define FUNC_NAME s_scm_slot_ref
1446 SCM_VALIDATE_INSTANCE (1, obj
);
1447 TEST_CHANGE_CLASS (obj
, class);
1449 res
= get_slot_value_using_name (class, obj
, slot_name
);
1450 if (SCM_GOOPS_UNBOUNDP (res
))
1451 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1456 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1457 (SCM obj
, SCM slot_name
, SCM value
),
1458 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1459 #define FUNC_NAME s_scm_slot_set_x
1463 SCM_VALIDATE_INSTANCE (1, obj
);
1464 TEST_CHANGE_CLASS(obj
, class);
1466 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1470 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1472 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1473 (SCM obj
, SCM slot_name
),
1474 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1476 #define FUNC_NAME s_scm_slot_bound_p
1480 SCM_VALIDATE_INSTANCE (1, obj
);
1481 TEST_CHANGE_CLASS(obj
, class);
1483 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1491 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1492 (SCM obj
, SCM slot_name
),
1493 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1494 #define FUNC_NAME s_scm_slot_exists_p
1498 SCM_VALIDATE_INSTANCE (1, obj
);
1499 SCM_VALIDATE_SYMBOL (2, slot_name
);
1500 TEST_CHANGE_CLASS (obj
, class);
1502 return test_slot_existence (class, obj
, slot_name
);
1507 /******************************************************************************
1509 * %allocate-instance (the low level instance allocation primitive)
1511 ******************************************************************************/
1513 static void clear_method_cache (SCM
);
1516 wrap_init (SCM
class, SCM
*m
, long n
)
1519 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1520 const char *layout
= scm_i_symbol_chars (SCM_PACK (slayout
));
1522 /* Set all SCM-holding slots to unbound */
1523 for (i
= 0; i
< n
; i
++)
1524 if (layout
[i
*2] == 'p')
1525 m
[i
] = SCM_GOOPS_UNBOUND
;
1529 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1531 (scm_t_bits
) m
, 0, 0);
1534 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1535 (SCM
class, SCM initargs
),
1536 "Create a new instance of class @var{class} and initialize it\n"
1537 "from the arguments @var{initargs}.")
1538 #define FUNC_NAME s_scm_sys_allocate_instance
1543 SCM_VALIDATE_CLASS (1, class);
1545 /* Most instances */
1546 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1548 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1549 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1550 return wrap_init (class, m
, n
);
1553 /* Foreign objects */
1554 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1555 return scm_make_foreign_object (class, initargs
);
1557 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1560 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1562 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1564 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1565 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1566 /* Generic functions */
1567 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1569 SCM gf
= wrap_init (class, m
, n
);
1570 clear_method_cache (gf
);
1574 return wrap_init (class, m
, n
);
1578 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1582 /* allocate class object */
1583 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1585 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1586 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1587 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1589 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1590 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1591 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1592 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1597 /* Non-light instances */
1599 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1600 return wrap_init (class, m
, n
);
1605 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1606 (SCM obj
, SCM setter
),
1608 #define FUNC_NAME s_scm_sys_set_object_setter_x
1610 SCM_ASSERT (SCM_STRUCTP (obj
)
1611 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1612 || SCM_I_ENTITYP (obj
)),
1616 if (SCM_I_ENTITYP (obj
))
1617 SCM_SET_ENTITY_SETTER (obj
, setter
);
1619 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1620 return SCM_UNSPECIFIED
;
1624 /******************************************************************************
1626 * %modify-instance (used by change-class to modify in place)
1628 ******************************************************************************/
1630 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1633 #define FUNC_NAME s_scm_sys_modify_instance
1635 SCM_VALIDATE_INSTANCE (1, old
);
1636 SCM_VALIDATE_INSTANCE (2, new);
1638 /* Exchange the data contained in old and new. We exchange rather than
1639 * scratch the old value with new to be correct with GC.
1640 * See "Class redefinition protocol above".
1642 SCM_CRITICAL_SECTION_START
;
1644 SCM car
= SCM_CAR (old
);
1645 SCM cdr
= SCM_CDR (old
);
1646 SCM_SETCAR (old
, SCM_CAR (new));
1647 SCM_SETCDR (old
, SCM_CDR (new));
1648 SCM_SETCAR (new, car
);
1649 SCM_SETCDR (new, cdr
);
1651 SCM_CRITICAL_SECTION_END
;
1652 return SCM_UNSPECIFIED
;
1656 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1659 #define FUNC_NAME s_scm_sys_modify_class
1661 SCM_VALIDATE_CLASS (1, old
);
1662 SCM_VALIDATE_CLASS (2, new);
1664 SCM_CRITICAL_SECTION_START
;
1666 SCM car
= SCM_CAR (old
);
1667 SCM cdr
= SCM_CDR (old
);
1668 SCM_SETCAR (old
, SCM_CAR (new));
1669 SCM_SETCDR (old
, SCM_CDR (new));
1670 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1671 SCM_SETCAR (new, car
);
1672 SCM_SETCDR (new, cdr
);
1673 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1675 SCM_CRITICAL_SECTION_END
;
1676 return SCM_UNSPECIFIED
;
1680 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1683 #define FUNC_NAME s_scm_sys_invalidate_class
1685 SCM_VALIDATE_CLASS (1, class);
1686 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1687 return SCM_UNSPECIFIED
;
1691 /* When instances change class, they finally get a new body, but
1692 * before that, they go through purgatory in hell. Odd as it may
1693 * seem, this data structure saves us from eternal suffering in
1694 * infinite recursions.
1697 static scm_t_bits
**hell
;
1698 static long n_hell
= 1; /* one place for the evil one himself */
1699 static long hell_size
= 4;
1700 static SCM hell_mutex
;
1706 for (i
= 1; i
< n_hell
; ++i
)
1707 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1713 go_to_hell (void *o
)
1715 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1716 scm_lock_mutex (hell_mutex
);
1717 if (n_hell
>= hell_size
)
1720 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1722 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1723 scm_unlock_mutex (hell_mutex
);
1727 go_to_heaven (void *o
)
1729 scm_lock_mutex (hell_mutex
);
1730 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1731 scm_unlock_mutex (hell_mutex
);
1735 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1738 purgatory (void *args
)
1740 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1741 SCM_PACK ((scm_t_bits
) args
));
1744 /* This function calls the generic function change-class for all
1745 * instances which aren't currently undergoing class change.
1749 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1752 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1753 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1754 (void *) SCM_UNPACK (obj
));
1757 /******************************************************************************
1763 * GGG E N E R I C F U N C T I O N S
1765 * This implementation provides
1766 * - generic functions (with class specializers)
1769 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1771 ******************************************************************************/
1773 SCM_KEYWORD (k_name
, "name");
1775 SCM_SYMBOL (sym_no_method
, "no-method");
1777 static SCM list_of_no_method
;
1779 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1783 scm_make_method_cache (SCM gf
)
1785 return scm_list_5 (SCM_IM_DISPATCH
,
1788 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1794 clear_method_cache (SCM gf
)
1796 SCM cache
= scm_make_method_cache (gf
);
1797 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1798 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1801 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1804 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1807 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1808 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1809 if (scm_is_true (used_by
))
1811 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1812 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1813 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1814 clear_method_cache (gf
);
1815 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1816 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1819 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1820 /* The sign of n is a flag indicating rest args. */
1821 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1823 return SCM_UNSPECIFIED
;
1827 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1830 #define FUNC_NAME s_scm_generic_capability_p
1832 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1833 proc
, SCM_ARG1
, FUNC_NAME
);
1834 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1840 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1843 #define FUNC_NAME s_scm_enable_primitive_generic_x
1845 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1846 while (!scm_is_null (subrs
))
1848 SCM subr
= SCM_CAR (subrs
);
1849 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1850 subr
, SCM_ARGn
, FUNC_NAME
);
1851 *SCM_SUBR_GENERIC (subr
)
1852 = scm_make (scm_list_3 (scm_class_generic
,
1855 subrs
= SCM_CDR (subrs
);
1857 return SCM_UNSPECIFIED
;
1861 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1864 #define FUNC_NAME s_scm_primitive_generic_generic
1866 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1868 if (!*SCM_SUBR_GENERIC (subr
))
1869 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1870 return *SCM_SUBR_GENERIC (subr
);
1872 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1876 typedef struct t_extension
{
1877 struct t_extension
*next
;
1883 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1885 static const char extension_gc_hint
[] = "GOOPS extension";
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_gc_malloc (sizeof (t_extension
),
1909 t_extension
**loc
= &extensions
;
1910 /* Make sure that extensions are placed before their own
1911 * extensions in the extensions list. O(N^2) algorithm, but
1912 * extensions of primitive generics are rare.
1914 while (*loc
&& extension
!= (*loc
)->extended
)
1915 loc
= &(*loc
)->next
;
1917 e
->extended
= extended
;
1918 e
->extension
= extension
;
1924 setup_extended_primitive_generics ()
1928 t_extension
*e
= extensions
;
1929 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1930 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 CALL_GF2 ("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
))
2198 /*fixme* Use scm_apply */
2199 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2203 scm_memoize_method (SCM x
, SCM args
)
2205 SCM gf
= SCM_CAR (scm_last_pair (x
));
2206 return scm_internal_dynamic_wind (
2208 call_memoize_method
,
2210 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2211 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2214 /******************************************************************************
2216 * A simple make (which will be redefined later in Scheme)
2217 * This version handles only creation of gf, methods and classes (no instances)
2219 * Since this code will disappear when Goops will be fully booted,
2220 * no precaution is taken to be efficient.
2222 ******************************************************************************/
2224 SCM_KEYWORD (k_setter
, "setter");
2225 SCM_KEYWORD (k_specializers
, "specializers");
2226 SCM_KEYWORD (k_procedure
, "procedure");
2227 SCM_KEYWORD (k_dsupers
, "dsupers");
2228 SCM_KEYWORD (k_slots
, "slots");
2229 SCM_KEYWORD (k_gf
, "generic-function");
2231 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2233 "Make a new object. @var{args} must contain the class and\n"
2234 "all necessary initialization information.")
2235 #define FUNC_NAME s_scm_make
2238 long len
= scm_ilength (args
);
2240 if (len
<= 0 || (len
& 1) == 0)
2241 SCM_WRONG_NUM_ARGS ();
2243 class = SCM_CAR(args
);
2244 args
= SCM_CDR(args
);
2246 if (class == scm_class_generic
|| class == scm_class_accessor
)
2248 z
= scm_make_struct (class, SCM_INUM0
,
2249 scm_list_5 (SCM_EOL
,
2254 scm_set_procedure_property_x (z
, scm_sym_name
,
2255 scm_get_keyword (k_name
,
2258 clear_method_cache (z
);
2259 if (class == scm_class_accessor
)
2261 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2262 if (scm_is_true (setter
))
2263 scm_sys_set_object_setter_x (z
, setter
);
2268 z
= scm_sys_allocate_instance (class, args
);
2270 if (class == scm_class_method
2271 || class == scm_class_simple_method
2272 || class == scm_class_accessor_method
)
2274 SCM_SET_SLOT (z
, scm_si_generic_function
,
2275 scm_i_get_keyword (k_gf
,
2280 SCM_SET_SLOT (z
, scm_si_specializers
,
2281 scm_i_get_keyword (k_specializers
,
2286 SCM_SET_SLOT (z
, scm_si_procedure
,
2287 scm_i_get_keyword (k_procedure
,
2292 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2296 /* In all the others case, make a new class .... No instance here */
2297 SCM_SET_SLOT (z
, scm_si_name
,
2298 scm_i_get_keyword (k_name
,
2301 scm_from_locale_symbol ("???"),
2303 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2304 scm_i_get_keyword (k_dsupers
,
2309 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2310 scm_i_get_keyword (k_slots
,
2321 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2324 #define FUNC_NAME s_scm_find_method
2327 long len
= scm_ilength (l
);
2330 SCM_WRONG_NUM_ARGS ();
2332 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2333 SCM_VALIDATE_GENERIC (1, gf
);
2334 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2335 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2337 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2341 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2342 (SCM m1
, SCM m2
, SCM targs
),
2343 "Return true if method @var{m1} is more specific than @var{m2} "
2344 "given the argument types (classes) listed in @var{targs}.")
2345 #define FUNC_NAME s_scm_sys_method_more_specific_p
2349 long i
, len
, m1_specs
, m2_specs
;
2350 scm_t_array_handle handle
;
2352 SCM_VALIDATE_METHOD (1, m1
);
2353 SCM_VALIDATE_METHOD (2, m2
);
2355 len
= scm_ilength (targs
);
2356 m1_specs
= scm_ilength (SPEC_OF (m1
));
2357 m2_specs
= scm_ilength (SPEC_OF (m2
));
2358 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2359 targs
, SCM_ARG3
, FUNC_NAME
);
2361 /* Verify that all the arguments of TARGS are classes and place them
2364 v
= scm_c_make_vector (len
, SCM_EOL
);
2365 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2367 for (i
= 0, l
= targs
;
2368 i
< len
&& scm_is_pair (l
);
2369 i
++, l
= SCM_CDR (l
))
2371 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2372 v_elts
[i
] = SCM_CAR (l
);
2374 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2376 scm_array_handle_release (&handle
);
2384 /******************************************************************************
2388 ******************************************************************************/
2391 fix_cpl (SCM c
, SCM before
, SCM after
)
2393 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2394 SCM ls
= scm_c_memq (after
, cpl
);
2395 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2396 if (scm_is_false (ls
))
2397 /* if this condition occurs, fix_cpl should not be applied this way */
2399 SCM_SETCAR (ls
, before
);
2400 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2402 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2403 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2404 SCM g_n_s
= compute_getters_n_setters (slots
);
2405 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2406 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2412 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2414 SCM tmp
= scm_from_locale_symbol (name
);
2416 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2420 : scm_list_1 (super
),
2426 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2429 create_standard_classes (void)
2432 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2433 scm_from_locale_symbol ("specializers"),
2435 scm_from_locale_symbol ("code-table"));
2436 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2438 k_slot_definition
));
2439 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2440 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2444 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2445 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2448 scm_list_3 (scm_from_locale_symbol ("used-by"),
2451 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2454 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2457 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2460 /* Foreign class slot classes */
2461 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2462 scm_class_class
, scm_class_top
, SCM_EOL
);
2463 make_stdcls (&scm_class_protected
, "<protected-slot>",
2464 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2465 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2466 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2467 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2468 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2469 make_stdcls (&scm_class_self
, "<self-slot>",
2471 scm_class_read_only
,
2473 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2475 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2477 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2479 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2481 make_stdcls (&scm_class_scm
, "<scm-slot>",
2482 scm_class_class
, scm_class_protected
, SCM_EOL
);
2483 make_stdcls (&scm_class_int
, "<int-slot>",
2484 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2485 make_stdcls (&scm_class_float
, "<float-slot>",
2486 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2487 make_stdcls (&scm_class_double
, "<double-slot>",
2488 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2490 /* Continue initialization of class <class> */
2492 slots
= build_class_class_slots ();
2493 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2494 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2495 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2496 compute_getters_n_setters (slots
));
2498 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2499 scm_class_class
, scm_class_class
,
2500 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2503 scm_list_3 (scm_from_locale_symbol ("destructor"),
2505 scm_class_opaque
)));
2506 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2507 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2508 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2510 /* scm_class_generic functions classes */
2511 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2512 scm_class_class
, scm_class_class
, SCM_EOL
);
2513 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2514 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2515 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2516 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2517 make_stdcls (&scm_class_operator_with_setter_class
,
2518 "<operator-with-setter-class>",
2519 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2520 make_stdcls (&scm_class_method
, "<method>",
2521 scm_class_class
, scm_class_object
, method_slots
);
2522 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2523 scm_class_class
, scm_class_method
, SCM_EOL
);
2524 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2525 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2526 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2527 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2528 make_stdcls (&scm_class_applicable
, "<applicable>",
2529 scm_class_class
, scm_class_top
, SCM_EOL
);
2530 make_stdcls (&scm_class_entity
, "<entity>",
2531 scm_class_entity_class
,
2532 scm_list_2 (scm_class_object
, scm_class_applicable
),
2534 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2535 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2536 make_stdcls (&scm_class_generic
, "<generic>",
2537 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2538 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2539 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2540 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2541 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2542 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2543 scm_class_entity_class
,
2544 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2546 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2547 make_stdcls (&scm_class_accessor
, "<accessor>",
2548 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2549 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2550 make_stdcls (&scm_class_extended_generic_with_setter
,
2551 "<extended-generic-with-setter>",
2552 scm_class_entity_class
,
2553 scm_list_2 (scm_class_generic_with_setter
,
2554 scm_class_extended_generic
),
2556 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2557 SCM_CLASSF_PURE_GENERIC
);
2558 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2559 scm_class_entity_class
,
2560 scm_list_2 (scm_class_accessor
,
2561 scm_class_extended_generic_with_setter
),
2563 fix_cpl (scm_class_extended_accessor
,
2564 scm_class_extended_generic
, scm_class_generic
);
2565 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2567 /* Primitive types classes */
2568 make_stdcls (&scm_class_boolean
, "<boolean>",
2569 scm_class_class
, scm_class_top
, SCM_EOL
);
2570 make_stdcls (&scm_class_char
, "<char>",
2571 scm_class_class
, scm_class_top
, SCM_EOL
);
2572 make_stdcls (&scm_class_list
, "<list>",
2573 scm_class_class
, scm_class_top
, SCM_EOL
);
2574 make_stdcls (&scm_class_pair
, "<pair>",
2575 scm_class_class
, scm_class_list
, SCM_EOL
);
2576 make_stdcls (&scm_class_null
, "<null>",
2577 scm_class_class
, scm_class_list
, SCM_EOL
);
2578 make_stdcls (&scm_class_string
, "<string>",
2579 scm_class_class
, scm_class_top
, SCM_EOL
);
2580 make_stdcls (&scm_class_symbol
, "<symbol>",
2581 scm_class_class
, scm_class_top
, SCM_EOL
);
2582 make_stdcls (&scm_class_vector
, "<vector>",
2583 scm_class_class
, scm_class_top
, SCM_EOL
);
2584 make_stdcls (&scm_class_number
, "<number>",
2585 scm_class_class
, scm_class_top
, SCM_EOL
);
2586 make_stdcls (&scm_class_complex
, "<complex>",
2587 scm_class_class
, scm_class_number
, SCM_EOL
);
2588 make_stdcls (&scm_class_real
, "<real>",
2589 scm_class_class
, scm_class_complex
, SCM_EOL
);
2590 make_stdcls (&scm_class_integer
, "<integer>",
2591 scm_class_class
, scm_class_real
, SCM_EOL
);
2592 make_stdcls (&scm_class_fraction
, "<fraction>",
2593 scm_class_class
, scm_class_real
, SCM_EOL
);
2594 make_stdcls (&scm_class_keyword
, "<keyword>",
2595 scm_class_class
, scm_class_top
, SCM_EOL
);
2596 make_stdcls (&scm_class_unknown
, "<unknown>",
2597 scm_class_class
, scm_class_top
, SCM_EOL
);
2598 make_stdcls (&scm_class_procedure
, "<procedure>",
2599 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2600 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2601 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2602 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2603 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2604 make_stdcls (&scm_class_port
, "<port>",
2605 scm_class_class
, scm_class_top
, SCM_EOL
);
2606 make_stdcls (&scm_class_input_port
, "<input-port>",
2607 scm_class_class
, scm_class_port
, SCM_EOL
);
2608 make_stdcls (&scm_class_output_port
, "<output-port>",
2609 scm_class_class
, scm_class_port
, SCM_EOL
);
2610 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2612 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2616 /**********************************************************************
2620 **********************************************************************/
2623 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2629 sprintf (buffer
, template, type_name
);
2630 name
= scm_from_locale_symbol (buffer
);
2633 name
= SCM_GOOPS_UNBOUND
;
2635 class = scm_permanent_object (scm_basic_make_class (applicablep
2636 ? scm_class_procedure_class
2642 /* Only define name if doesn't already exist. */
2643 if (!SCM_GOOPS_UNBOUNDP (name
)
2644 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2645 DEFVAR (name
, class);
2650 scm_make_extended_class (char const *type_name
, int applicablep
)
2652 return make_class_from_template ("<%s>",
2654 scm_list_1 (applicablep
2655 ? scm_class_applicable
2661 scm_i_inherit_applicable (SCM c
)
2663 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2665 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2666 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2667 /* patch scm_class_applicable into direct-supers */
2668 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2669 if (scm_is_false (top
))
2670 dsupers
= scm_append (scm_list_2 (dsupers
,
2671 scm_list_1 (scm_class_applicable
)));
2674 SCM_SETCAR (top
, scm_class_applicable
);
2675 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2677 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2678 /* patch scm_class_applicable into cpl */
2679 top
= scm_c_memq (scm_class_top
, cpl
);
2680 if (scm_is_false (top
))
2684 SCM_SETCAR (top
, scm_class_applicable
);
2685 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2687 /* add class to direct-subclasses of scm_class_applicable */
2688 SCM_SET_SLOT (scm_class_applicable
,
2689 scm_si_direct_subclasses
,
2690 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2691 scm_si_direct_subclasses
)));
2696 create_smob_classes (void)
2700 scm_smob_class
= scm_malloc (SCM_I_MAX_SMOB_TYPE_COUNT
* sizeof (SCM
));
2701 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2702 scm_smob_class
[i
] = 0;
2704 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2706 for (i
= 0; i
< scm_numsmob
; ++i
)
2707 if (!scm_smob_class
[i
])
2708 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2709 scm_smobs
[i
].apply
!= 0);
2713 scm_make_port_classes (long ptobnum
, char *type_name
)
2715 SCM c
, class = make_class_from_template ("<%s-port>",
2717 scm_list_1 (scm_class_port
),
2719 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2720 = make_class_from_template ("<%s-input-port>",
2722 scm_list_2 (class, scm_class_input_port
),
2724 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2725 = make_class_from_template ("<%s-output-port>",
2727 scm_list_2 (class, scm_class_output_port
),
2729 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2731 = make_class_from_template ("<%s-input-output-port>",
2733 scm_list_2 (class, scm_class_input_output_port
),
2735 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2736 SCM_SET_SLOT (c
, scm_si_cpl
,
2737 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2741 create_port_classes (void)
2745 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2746 for (i
= 0; i
< 3 * 256; ++i
)
2747 scm_port_class
[i
] = 0;
2749 for (i
= 0; i
< scm_numptob
; ++i
)
2750 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2754 make_struct_class (void *closure SCM_UNUSED
,
2755 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2757 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2758 SCM_SET_STRUCT_TABLE_CLASS (data
,
2759 scm_make_extended_class
2760 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2761 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2762 return SCM_UNSPECIFIED
;
2766 create_struct_classes (void)
2768 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2771 /**********************************************************************
2775 **********************************************************************/
2780 if (!goops_loaded_p
)
2781 scm_c_resolve_module ("oop goops");
2786 scm_make_foreign_object (SCM
class, SCM initargs
)
2787 #define FUNC_NAME s_scm_make
2789 void * (*constructor
) (SCM
)
2790 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2791 if (constructor
== 0)
2792 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2793 return scm_wrap_object (class, constructor (initargs
));
2799 scm_free_foreign_object (SCM
*class, SCM
*data
)
2801 size_t (*destructor
) (void *)
2802 = (size_t (*) (void *)) class[scm_si_destructor
];
2803 return destructor (data
);
2807 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2808 void * (*constructor
) (SCM initargs
),
2809 size_t (*destructor
) (void *))
2812 name
= scm_from_locale_symbol (s_name
);
2813 if (scm_is_null (supers
))
2814 supers
= scm_list_1 (scm_class_foreign_object
);
2815 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2816 scm_sys_inherit_magic_x (class, supers
);
2818 if (destructor
!= 0)
2820 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2821 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2825 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2828 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2829 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2834 SCM_SYMBOL (sym_o
, "o");
2835 SCM_SYMBOL (sym_x
, "x");
2837 SCM_KEYWORD (k_accessor
, "accessor");
2838 SCM_KEYWORD (k_getter
, "getter");
2841 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2843 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2848 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2849 SCM (*getter
) (SCM obj
),
2850 SCM (*setter
) (SCM obj
, SCM x
),
2851 char *accessor_name
)
2854 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2855 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2856 setter
? setter
: default_setter
);
2858 /* Dirk:FIXME:: The following two expressions make use of the fact that
2859 * the memoizer will accept a subr-object in the place of a function.
2860 * This is not guaranteed to stay this way. */
2861 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2863 scm_list_2 (get
, sym_o
)),
2865 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2866 scm_list_2 (sym_o
, sym_x
),
2867 scm_list_3 (set
, sym_o
, sym_x
)),
2871 SCM name
= scm_from_locale_symbol (slot_name
);
2872 SCM aname
= scm_from_locale_symbol (accessor_name
);
2873 SCM gf
= scm_ensure_accessor (aname
);
2874 SCM slot
= scm_list_5 (name
,
2877 setter
? k_accessor
: k_getter
,
2879 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2884 scm_add_method (scm_setter (gf
),
2885 scm_make (scm_list_5 (scm_class_accessor_method
,
2887 scm_list_2 (class, scm_class_top
),
2892 SCM_SET_SLOT (class, scm_si_slots
,
2893 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2894 scm_list_1 (slot
))));
2896 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2897 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
2899 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2900 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2901 scm_list_1 (gns
))));
2902 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2909 scm_wrap_object (SCM
class, void *data
)
2911 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2919 scm_wrap_component (SCM
class, SCM container
, void *data
)
2921 SCM obj
= scm_wrap_object (class, data
);
2922 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2928 SCM_SETCDR (handle
, container
);
2933 scm_ensure_accessor (SCM name
)
2935 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2936 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2938 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2939 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2940 k_name
, name
, k_setter
, gf
));
2945 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2948 scm_add_method (SCM gf
, SCM m
)
2950 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2955 * Debugging utilities
2958 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2960 "Return @code{#t} if @var{obj} is a pure generic.")
2961 #define FUNC_NAME s_scm_pure_generic_p
2963 return scm_from_bool (SCM_PUREGENERICP (obj
));
2967 #endif /* GUILE_DEBUG */
2973 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2975 "Announce that GOOPS is loaded and perform initialization\n"
2976 "on the C level which depends on the loaded GOOPS modules.")
2977 #define FUNC_NAME s_scm_sys_goops_loaded
2980 var_compute_applicable_methods
=
2981 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2983 setup_extended_primitive_generics ();
2984 return SCM_UNSPECIFIED
;
2988 SCM scm_module_goops
;
2991 scm_init_goops_builtins (void)
2993 scm_module_goops
= scm_current_module ();
2994 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2996 /* Not really necessary right now, but who knows...
2998 scm_permanent_object (scm_module_goops
);
2999 scm_permanent_object (scm_goops_lookup_closure
);
3001 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
3002 (scm_from_int (37)));
3004 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3006 #include "libguile/goops.x"
3008 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3010 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3011 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3013 create_basic_classes ();
3014 create_standard_classes ();
3015 create_smob_classes ();
3016 create_struct_classes ();
3017 create_port_classes ();
3020 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3021 scm_no_applicable_method
3022 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3025 DEFVAR (name
, scm_no_applicable_method
);
3028 return SCM_UNSPECIFIED
;
3034 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3035 scm_init_goops_builtins
);