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
))
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
;
740 if (flags
& SCM_CLASSF_ENTITY
)
741 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
744 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
747 * We could avoid calling scm_gc_malloc in the allocation code
748 * (in which case the following two lines are needed). Instead
749 * we make 0-slot instances non-light, so that the light case
750 * can be handled without special cases.
753 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
755 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
757 /* NOTE: The following depends on scm_struct_i_size. */
758 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
759 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
762 SCM_SET_CLASS_FLAGS (class, flags
);
764 prep_hashsets (class);
766 return SCM_UNSPECIFIED
;
771 prep_hashsets (SCM
class)
775 for (i
= 0; i
< 7; ++i
)
776 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
779 /******************************************************************************/
782 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
784 SCM z
, cpl
, slots
, nfields
, g_n_s
;
786 /* Allocate one instance */
787 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
789 /* Initialize its slots */
790 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
791 cpl
= compute_cpl (z
);
792 slots
= build_slots_list (maplist (dslots
), cpl
);
793 nfields
= scm_from_int (scm_ilength (slots
));
794 g_n_s
= compute_getters_n_setters (slots
);
796 SCM_SET_SLOT (z
, scm_si_name
, name
);
797 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
798 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
799 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
800 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
801 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
802 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
803 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
804 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
805 SCM_SET_SLOT (z
, scm_si_environment
,
806 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
808 /* Add this class in the direct-subclasses slot of dsupers */
811 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
812 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
813 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
814 scm_si_direct_subclasses
)));
817 /* Support for the underlying structs: */
818 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
819 ? (SCM_CLASSF_GOOPS_OR_VALID
820 | SCM_CLASSF_OPERATOR
822 : class == scm_class_operator_class
823 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
824 : SCM_CLASSF_GOOPS_OR_VALID
));
829 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
831 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
832 scm_sys_inherit_magic_x (z
, dsupers
);
833 scm_sys_prep_layout_x (z
);
837 /******************************************************************************/
839 SCM_SYMBOL (sym_layout
, "layout");
840 SCM_SYMBOL (sym_vcell
, "vcell");
841 SCM_SYMBOL (sym_vtable
, "vtable");
842 SCM_SYMBOL (sym_print
, "print");
843 SCM_SYMBOL (sym_procedure
, "procedure");
844 SCM_SYMBOL (sym_setter
, "setter");
845 SCM_SYMBOL (sym_redefined
, "redefined");
846 SCM_SYMBOL (sym_h0
, "h0");
847 SCM_SYMBOL (sym_h1
, "h1");
848 SCM_SYMBOL (sym_h2
, "h2");
849 SCM_SYMBOL (sym_h3
, "h3");
850 SCM_SYMBOL (sym_h4
, "h4");
851 SCM_SYMBOL (sym_h5
, "h5");
852 SCM_SYMBOL (sym_h6
, "h6");
853 SCM_SYMBOL (sym_h7
, "h7");
854 SCM_SYMBOL (sym_name
, "name");
855 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
856 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
857 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
858 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
859 SCM_SYMBOL (sym_cpl
, "cpl");
860 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
861 SCM_SYMBOL (sym_slots
, "slots");
862 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
863 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
864 SCM_SYMBOL (sym_nfields
, "nfields");
865 SCM_SYMBOL (sym_environment
, "environment");
869 build_class_class_slots ()
872 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
873 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
874 scm_list_1 (sym_print
),
875 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
876 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
877 scm_list_1 (sym_redefined
),
878 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
879 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
880 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
881 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
882 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
883 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
884 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
885 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
886 scm_list_1 (sym_name
),
887 scm_list_1 (sym_direct_supers
),
888 scm_list_1 (sym_direct_slots
),
889 scm_list_1 (sym_direct_subclasses
),
890 scm_list_1 (sym_direct_methods
),
891 scm_list_1 (sym_cpl
),
892 scm_list_1 (sym_default_slot_definition_class
),
893 scm_list_1 (sym_slots
),
894 scm_list_1 (sym_getters_n_setters
),
895 scm_list_1 (sym_keyword_access
),
896 scm_list_1 (sym_nfields
),
897 scm_list_1 (sym_environment
),
902 create_basic_classes (void)
904 /* SCM slots_of_class = build_class_class_slots (); */
906 /**** <scm_class_class> ****/
907 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
908 + 2 * scm_vtable_offset_user
);
909 SCM name
= scm_from_locale_symbol ("<class>");
910 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
913 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
914 | SCM_CLASSF_METACLASS
));
916 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
917 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
918 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
919 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
920 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
921 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
922 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
923 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
924 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
925 compute_getters_n_setters (slots_of_class)); */
926 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
927 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
928 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
930 prep_hashsets (scm_class_class
);
932 DEFVAR(name
, scm_class_class
);
934 /**** <scm_class_top> ****/
935 name
= scm_from_locale_symbol ("<top>");
936 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
941 DEFVAR(name
, scm_class_top
);
943 /**** <scm_class_object> ****/
944 name
= scm_from_locale_symbol ("<object>");
945 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
947 scm_list_1 (scm_class_top
),
950 DEFVAR (name
, scm_class_object
);
952 /* <top> <object> and <class> were partially initialized. Correct them here */
953 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
955 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
956 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
959 /******************************************************************************/
961 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
963 "Return @code{#t} if @var{obj} is an instance.")
964 #define FUNC_NAME s_scm_instance_p
966 return scm_from_bool (SCM_INSTANCEP (obj
));
971 /******************************************************************************
973 * Meta object accessors
975 ******************************************************************************/
976 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
978 "Return the class name of @var{obj}.")
979 #define FUNC_NAME s_scm_class_name
981 SCM_VALIDATE_CLASS (1, obj
);
982 return scm_slot_ref (obj
, sym_name
);
986 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
988 "Return the direct superclasses of the class @var{obj}.")
989 #define FUNC_NAME s_scm_class_direct_supers
991 SCM_VALIDATE_CLASS (1, obj
);
992 return scm_slot_ref (obj
, sym_direct_supers
);
996 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
998 "Return the direct slots of the class @var{obj}.")
999 #define FUNC_NAME s_scm_class_direct_slots
1001 SCM_VALIDATE_CLASS (1, obj
);
1002 return scm_slot_ref (obj
, sym_direct_slots
);
1006 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1008 "Return the direct subclasses of the class @var{obj}.")
1009 #define FUNC_NAME s_scm_class_direct_subclasses
1011 SCM_VALIDATE_CLASS (1, obj
);
1012 return scm_slot_ref(obj
, sym_direct_subclasses
);
1016 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1018 "Return the direct methods of the class @var{obj}")
1019 #define FUNC_NAME s_scm_class_direct_methods
1021 SCM_VALIDATE_CLASS (1, obj
);
1022 return scm_slot_ref (obj
, sym_direct_methods
);
1026 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1028 "Return the class precedence list of the class @var{obj}.")
1029 #define FUNC_NAME s_scm_class_precedence_list
1031 SCM_VALIDATE_CLASS (1, obj
);
1032 return scm_slot_ref (obj
, sym_cpl
);
1036 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1038 "Return the slot list of the class @var{obj}.")
1039 #define FUNC_NAME s_scm_class_slots
1041 SCM_VALIDATE_CLASS (1, obj
);
1042 return scm_slot_ref (obj
, sym_slots
);
1046 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1048 "Return the environment of the class @var{obj}.")
1049 #define FUNC_NAME s_scm_class_environment
1051 SCM_VALIDATE_CLASS (1, obj
);
1052 return scm_slot_ref(obj
, sym_environment
);
1057 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1059 "Return the name of the generic function @var{obj}.")
1060 #define FUNC_NAME s_scm_generic_function_name
1062 SCM_VALIDATE_GENERIC (1, obj
);
1063 return scm_procedure_property (obj
, scm_sym_name
);
1067 SCM_SYMBOL (sym_methods
, "methods");
1068 SCM_SYMBOL (sym_extended_by
, "extended-by");
1069 SCM_SYMBOL (sym_extends
, "extends");
1072 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1074 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1075 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1076 while (!scm_is_null (gfs
))
1078 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1079 gfs
= SCM_CDR (gfs
);
1081 return method_lists
;
1085 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1087 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1089 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1090 while (!scm_is_null (gfs
))
1092 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1093 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1096 gfs
= SCM_CDR (gfs
);
1099 return method_lists
;
1102 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1104 "Return the methods of the generic function @var{obj}.")
1105 #define FUNC_NAME s_scm_generic_function_methods
1108 SCM_VALIDATE_GENERIC (1, obj
);
1109 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1110 methods
= fold_downward_gf_methods (methods
, obj
);
1111 return scm_append (methods
);
1115 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1117 "Return the generic function for the method @var{obj}.")
1118 #define FUNC_NAME s_scm_method_generic_function
1120 SCM_VALIDATE_METHOD (1, obj
);
1121 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1125 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1127 "Return specializers of the method @var{obj}.")
1128 #define FUNC_NAME s_scm_method_specializers
1130 SCM_VALIDATE_METHOD (1, obj
);
1131 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1135 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1137 "Return the procedure of the method @var{obj}.")
1138 #define FUNC_NAME s_scm_method_procedure
1140 SCM_VALIDATE_METHOD (1, obj
);
1141 return scm_slot_ref (obj
, sym_procedure
);
1145 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1147 "Return the slot definition of the accessor @var{obj}.")
1148 #define FUNC_NAME s_scm_accessor_method_slot_definition
1150 SCM_VALIDATE_ACCESSOR (1, obj
);
1151 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1155 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1157 "Internal GOOPS magic---don't use this function!")
1158 #define FUNC_NAME s_scm_sys_tag_body
1160 return scm_cons (SCM_IM_LAMBDA
, body
);
1164 /******************************************************************************
1166 * S l o t a c c e s s
1168 ******************************************************************************/
1170 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1172 "Return the unbound value.")
1173 #define FUNC_NAME s_scm_make_unbound
1175 return SCM_GOOPS_UNBOUND
;
1179 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1181 "Return @code{#t} if @var{obj} is unbound.")
1182 #define FUNC_NAME s_scm_unbound_p
1184 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1188 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1189 (SCM value
, SCM obj
),
1190 "Return @var{value} if it is bound, and invoke the\n"
1191 "@var{slot-unbound} method of @var{obj} if it is not.")
1192 #define FUNC_NAME s_scm_assert_bound
1194 if (SCM_GOOPS_UNBOUNDP (value
))
1195 return CALL_GF1 ("slot-unbound", obj
);
1200 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1201 (SCM obj
, SCM index
),
1202 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1203 "the value from @var{obj}.")
1204 #define FUNC_NAME s_scm_at_assert_bound_ref
1206 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1207 if (SCM_GOOPS_UNBOUNDP (value
))
1208 return CALL_GF1 ("slot-unbound", obj
);
1213 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1214 (SCM obj
, SCM index
),
1215 "Return the slot value with index @var{index} from @var{obj}.")
1216 #define FUNC_NAME s_scm_sys_fast_slot_ref
1218 unsigned long int i
;
1220 SCM_VALIDATE_INSTANCE (1, obj
);
1221 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
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, SCM_NUMBER_OF_SLOTS(obj
)-1);
1237 SCM_SET_SLOT (obj
, i
, value
);
1239 return SCM_UNSPECIFIED
;
1244 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1245 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1250 /* In the future, this function will return the effective slot
1251 * definition associated with SLOT_NAME. Now it just returns some of
1252 * the information which will be stored in the effective slot
1257 slot_definition_using_name (SCM
class, SCM slot_name
)
1259 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1260 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1261 if (SCM_CAAR (slots
) == slot_name
)
1262 return SCM_CAR (slots
);
1267 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1268 #define FUNC_NAME "%get-slot-value"
1270 SCM access
= SCM_CDDR (slotdef
);
1272 * - access is an integer (the offset of this slot in the slots vector)
1273 * - otherwise (car access) is the getter function to apply
1275 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1276 * we can just assume fixnums here.
1278 if (SCM_I_INUMP (access
))
1279 /* Don't poke at the slots directly, because scm_struct_ref handles the
1280 access bits for us. */
1281 return scm_struct_ref (obj
, access
);
1284 /* We must evaluate (apply (car access) (list obj))
1285 * where (car access) is known to be a closure of arity 1 */
1286 register SCM code
, env
;
1288 code
= SCM_CAR (access
);
1289 if (!SCM_CLOSUREP (code
))
1290 return SCM_SUBRF (code
) (obj
);
1291 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1294 /* Evaluate the closure body */
1295 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1301 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1303 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1304 if (scm_is_true (slotdef
))
1305 return get_slot_value (class, obj
, slotdef
);
1307 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1311 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1312 #define FUNC_NAME "%set-slot-value"
1314 SCM access
= SCM_CDDR (slotdef
);
1316 * - access is an integer (the offset of this slot in the slots vector)
1317 * - otherwise (cadr access) is the setter function to apply
1319 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1320 * we can just assume fixnums here.
1322 if (SCM_I_INUMP (access
))
1323 /* obey permissions bits via going through struct-set! */
1324 scm_struct_set_x (obj
, access
, value
);
1327 /* We must evaluate (apply (cadr l) (list obj value))
1328 * where (cadr l) is known to be a closure of arity 2 */
1329 register SCM code
, env
;
1331 code
= SCM_CADR (access
);
1332 if (!SCM_CLOSUREP (code
))
1333 SCM_SUBRF (code
) (obj
, value
);
1336 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1337 scm_list_2 (obj
, value
),
1339 /* Evaluate the closure body */
1340 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1343 return SCM_UNSPECIFIED
;
1348 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1350 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1351 if (scm_is_true (slotdef
))
1352 return set_slot_value (class, obj
, slotdef
, value
);
1354 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1358 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1362 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1363 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1369 /* ======================================== */
1371 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1372 (SCM
class, SCM obj
, SCM slot_name
),
1374 #define FUNC_NAME s_scm_slot_ref_using_class
1378 SCM_VALIDATE_CLASS (1, class);
1379 SCM_VALIDATE_INSTANCE (2, obj
);
1380 SCM_VALIDATE_SYMBOL (3, slot_name
);
1382 res
= get_slot_value_using_name (class, obj
, slot_name
);
1383 if (SCM_GOOPS_UNBOUNDP (res
))
1384 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1390 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1391 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1393 #define FUNC_NAME s_scm_slot_set_using_class_x
1395 SCM_VALIDATE_CLASS (1, class);
1396 SCM_VALIDATE_INSTANCE (2, obj
);
1397 SCM_VALIDATE_SYMBOL (3, slot_name
);
1399 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1404 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1405 (SCM
class, SCM obj
, SCM slot_name
),
1407 #define FUNC_NAME s_scm_slot_bound_using_class_p
1409 SCM_VALIDATE_CLASS (1, class);
1410 SCM_VALIDATE_INSTANCE (2, obj
);
1411 SCM_VALIDATE_SYMBOL (3, slot_name
);
1413 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1419 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1420 (SCM
class, SCM obj
, SCM slot_name
),
1422 #define FUNC_NAME s_scm_slot_exists_using_class_p
1424 SCM_VALIDATE_CLASS (1, class);
1425 SCM_VALIDATE_INSTANCE (2, obj
);
1426 SCM_VALIDATE_SYMBOL (3, slot_name
);
1427 return test_slot_existence (class, obj
, slot_name
);
1432 /* ======================================== */
1434 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1435 (SCM obj
, SCM slot_name
),
1436 "Return the value from @var{obj}'s slot with the name\n"
1438 #define FUNC_NAME s_scm_slot_ref
1442 SCM_VALIDATE_INSTANCE (1, obj
);
1443 TEST_CHANGE_CLASS (obj
, class);
1445 res
= get_slot_value_using_name (class, obj
, slot_name
);
1446 if (SCM_GOOPS_UNBOUNDP (res
))
1447 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1452 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1453 (SCM obj
, SCM slot_name
, SCM value
),
1454 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1455 #define FUNC_NAME s_scm_slot_set_x
1459 SCM_VALIDATE_INSTANCE (1, obj
);
1460 TEST_CHANGE_CLASS(obj
, class);
1462 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1466 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1468 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1469 (SCM obj
, SCM slot_name
),
1470 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1472 #define FUNC_NAME s_scm_slot_bound_p
1476 SCM_VALIDATE_INSTANCE (1, obj
);
1477 TEST_CHANGE_CLASS(obj
, class);
1479 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1487 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1488 (SCM obj
, SCM slot_name
),
1489 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1490 #define FUNC_NAME s_scm_slot_exists_p
1494 SCM_VALIDATE_INSTANCE (1, obj
);
1495 SCM_VALIDATE_SYMBOL (2, slot_name
);
1496 TEST_CHANGE_CLASS (obj
, class);
1498 return test_slot_existence (class, obj
, slot_name
);
1503 /******************************************************************************
1505 * %allocate-instance (the low level instance allocation primitive)
1507 ******************************************************************************/
1509 static void clear_method_cache (SCM
);
1512 wrap_init (SCM
class, SCM
*m
, long n
)
1515 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1516 const char *layout
= scm_i_symbol_chars (SCM_PACK (slayout
));
1518 /* Set all SCM-holding slots to unbound */
1519 for (i
= 0; i
< n
; i
++)
1520 if (layout
[i
*2] == 'p')
1521 m
[i
] = SCM_GOOPS_UNBOUND
;
1525 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1527 (scm_t_bits
) m
, 0, 0);
1530 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1531 (SCM
class, SCM initargs
),
1532 "Create a new instance of class @var{class} and initialize it\n"
1533 "from the arguments @var{initargs}.")
1534 #define FUNC_NAME s_scm_sys_allocate_instance
1539 SCM_VALIDATE_CLASS (1, class);
1541 /* Most instances */
1542 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1544 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1545 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1546 return wrap_init (class, m
, n
);
1549 /* Foreign objects */
1550 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1551 return scm_make_foreign_object (class, initargs
);
1553 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1556 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1558 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1560 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1561 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1562 /* Generic functions */
1563 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1565 SCM gf
= wrap_init (class, m
, n
);
1566 clear_method_cache (gf
);
1570 return wrap_init (class, m
, n
);
1574 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1578 /* allocate class object */
1579 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1581 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1582 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1583 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1585 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1586 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1587 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1588 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1593 /* Non-light instances */
1595 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1596 return wrap_init (class, m
, n
);
1601 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1602 (SCM obj
, SCM setter
),
1604 #define FUNC_NAME s_scm_sys_set_object_setter_x
1606 SCM_ASSERT (SCM_STRUCTP (obj
)
1607 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1608 || SCM_I_ENTITYP (obj
)),
1612 if (SCM_I_ENTITYP (obj
))
1613 SCM_SET_ENTITY_SETTER (obj
, setter
);
1615 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1616 return SCM_UNSPECIFIED
;
1620 /******************************************************************************
1622 * %modify-instance (used by change-class to modify in place)
1624 ******************************************************************************/
1626 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1629 #define FUNC_NAME s_scm_sys_modify_instance
1631 SCM_VALIDATE_INSTANCE (1, old
);
1632 SCM_VALIDATE_INSTANCE (2, new);
1634 /* Exchange the data contained in old and new. We exchange rather than
1635 * scratch the old value with new to be correct with GC.
1636 * See "Class redefinition protocol above".
1638 SCM_CRITICAL_SECTION_START
;
1640 SCM car
= SCM_CAR (old
);
1641 SCM cdr
= SCM_CDR (old
);
1642 SCM_SETCAR (old
, SCM_CAR (new));
1643 SCM_SETCDR (old
, SCM_CDR (new));
1644 SCM_SETCAR (new, car
);
1645 SCM_SETCDR (new, cdr
);
1647 SCM_CRITICAL_SECTION_END
;
1648 return SCM_UNSPECIFIED
;
1652 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1655 #define FUNC_NAME s_scm_sys_modify_class
1657 SCM_VALIDATE_CLASS (1, old
);
1658 SCM_VALIDATE_CLASS (2, new);
1660 SCM_CRITICAL_SECTION_START
;
1662 SCM car
= SCM_CAR (old
);
1663 SCM cdr
= SCM_CDR (old
);
1664 SCM_SETCAR (old
, SCM_CAR (new));
1665 SCM_SETCDR (old
, SCM_CDR (new));
1666 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1667 SCM_SETCAR (new, car
);
1668 SCM_SETCDR (new, cdr
);
1669 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1671 SCM_CRITICAL_SECTION_END
;
1672 return SCM_UNSPECIFIED
;
1676 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1679 #define FUNC_NAME s_scm_sys_invalidate_class
1681 SCM_VALIDATE_CLASS (1, class);
1682 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1683 return SCM_UNSPECIFIED
;
1687 /* When instances change class, they finally get a new body, but
1688 * before that, they go through purgatory in hell. Odd as it may
1689 * seem, this data structure saves us from eternal suffering in
1690 * infinite recursions.
1693 static scm_t_bits
**hell
;
1694 static long n_hell
= 1; /* one place for the evil one himself */
1695 static long hell_size
= 4;
1696 static SCM hell_mutex
;
1702 for (i
= 1; i
< n_hell
; ++i
)
1703 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1709 go_to_hell (void *o
)
1711 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1712 scm_lock_mutex (hell_mutex
);
1713 if (n_hell
>= hell_size
)
1716 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1718 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1719 scm_unlock_mutex (hell_mutex
);
1723 go_to_heaven (void *o
)
1725 scm_lock_mutex (hell_mutex
);
1726 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1727 scm_unlock_mutex (hell_mutex
);
1731 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1734 purgatory (void *args
)
1736 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1737 SCM_PACK ((scm_t_bits
) args
));
1740 /* This function calls the generic function change-class for all
1741 * instances which aren't currently undergoing class change.
1745 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1748 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1749 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1750 (void *) SCM_UNPACK (obj
));
1753 /******************************************************************************
1759 * GGG E N E R I C F U N C T I O N S
1761 * This implementation provides
1762 * - generic functions (with class specializers)
1765 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1767 ******************************************************************************/
1769 SCM_KEYWORD (k_name
, "name");
1771 SCM_SYMBOL (sym_no_method
, "no-method");
1773 static SCM list_of_no_method
;
1775 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1779 scm_make_method_cache (SCM gf
)
1781 return scm_list_5 (SCM_IM_DISPATCH
,
1784 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1790 clear_method_cache (SCM gf
)
1792 SCM cache
= scm_make_method_cache (gf
);
1793 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1794 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1797 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1800 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1803 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1804 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1805 if (scm_is_true (used_by
))
1807 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1808 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1809 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1810 clear_method_cache (gf
);
1811 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1812 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1815 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1816 /* The sign of n is a flag indicating rest args. */
1817 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1819 return SCM_UNSPECIFIED
;
1823 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1826 #define FUNC_NAME s_scm_generic_capability_p
1828 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1829 proc
, SCM_ARG1
, FUNC_NAME
);
1830 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1836 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1839 #define FUNC_NAME s_scm_enable_primitive_generic_x
1841 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1842 while (!scm_is_null (subrs
))
1844 SCM subr
= SCM_CAR (subrs
);
1845 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1846 subr
, SCM_ARGn
, FUNC_NAME
);
1847 *SCM_SUBR_GENERIC (subr
)
1848 = scm_make (scm_list_3 (scm_class_generic
,
1851 subrs
= SCM_CDR (subrs
);
1853 return SCM_UNSPECIFIED
;
1857 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1860 #define FUNC_NAME s_scm_primitive_generic_generic
1862 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1864 if (!*SCM_SUBR_GENERIC (subr
))
1865 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1866 return *SCM_SUBR_GENERIC (subr
);
1868 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1872 typedef struct t_extension
{
1873 struct t_extension
*next
;
1878 static t_extension
*extensions
= 0;
1880 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1883 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1888 if (!*SCM_SUBR_GENERIC (extended
))
1889 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1890 gf
= *SCM_SUBR_GENERIC (extended
);
1891 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1893 SCM_SNAME (extension
));
1894 *SCM_SUBR_GENERIC (extension
) = gext
;
1898 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1899 t_extension
**loc
= &extensions
;
1900 /* Make sure that extensions are placed before their own
1901 * extensions in the extensions list. O(N^2) algorithm, but
1902 * extensions of primitive generics are rare.
1904 while (*loc
&& extension
!= (*loc
)->extended
)
1905 loc
= &(*loc
)->next
;
1907 e
->extended
= extended
;
1908 e
->extension
= extension
;
1914 setup_extended_primitive_generics ()
1918 t_extension
*e
= extensions
;
1919 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1920 extensions
= e
->next
;
1925 /******************************************************************************
1927 * Protocol for calling a generic fumction
1928 * This protocol is roughly equivalent to (parameter are a little bit different
1929 * for efficiency reasons):
1931 * + apply-generic (gf args)
1932 * + compute-applicable-methods (gf args ...)
1933 * + sort-applicable-methods (methods args)
1934 * + apply-methods (gf methods args)
1936 * apply-methods calls make-next-method to build the "continuation" of a a
1937 * method. Applying a next-method will call apply-next-method which in
1938 * turn will call apply again to call effectively the following method.
1940 ******************************************************************************/
1943 applicablep (SCM actual
, SCM formal
)
1945 /* We already know that the cpl is well formed. */
1946 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1950 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1952 register SCM s1
, s2
;
1956 * m1 and m2 can have != length (i.e. one can be one element longer than the
1957 * other when we have a dotted parameter list). For instance, with the call
1960 * (define-method M (a . l) ....)
1961 * (define-method M (a) ....)
1963 * we consider that the second method is more specific.
1965 * BTW, targs is an array of types. We don't need it's size since
1966 * we already know that m1 and m2 are applicable (no risk to go past
1967 * the end of this array).
1970 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1971 if (scm_is_null(s1
)) return 1;
1972 if (scm_is_null(s2
)) return 0;
1973 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1974 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1976 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1977 if (cs1
== SCM_CAR(l
))
1979 if (cs2
== SCM_CAR(l
))
1982 return 0;/* should not occur! */
1985 return 0; /* should not occur! */
1988 #define BUFFSIZE 32 /* big enough for most uses */
1991 scm_i_vector2list (SCM l
, long len
)
1994 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1996 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1997 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2003 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2006 SCM
*v
, vector
= SCM_EOL
;
2007 SCM buffer
[BUFFSIZE
];
2008 SCM save
= method_list
;
2009 scm_t_array_handle handle
;
2011 /* For reasonably sized method_lists we can try to avoid all the
2012 * consing and reorder the list in place...
2013 * This idea is due to David McClain <Dave_McClain@msn.com>
2015 if (size
<= BUFFSIZE
)
2017 for (i
= 0; i
< size
; i
++)
2019 buffer
[i
] = SCM_CAR (method_list
);
2020 method_list
= SCM_CDR (method_list
);
2026 /* Too many elements in method_list to keep everything locally */
2027 vector
= scm_i_vector2list (save
, size
);
2028 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2031 /* Use a simple shell sort since it is generally faster than qsort on
2032 * small vectors (which is probably mostly the case when we have to
2033 * sort a list of applicable methods).
2035 for (incr
= size
/ 2; incr
; incr
/= 2)
2037 for (i
= incr
; i
< size
; i
++)
2039 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2041 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2045 SCM tmp
= v
[j
+ incr
];
2053 if (size
<= BUFFSIZE
)
2055 /* We did it in locally, so restore the original list (reordered) in-place */
2056 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2058 SCM_SETCAR (method_list
, *v
);
2059 method_list
= SCM_CDR (method_list
);
2064 /* If we are here, that's that we did it the hard way... */
2065 scm_array_handle_release (&handle
);
2066 return scm_vector_to_list (vector
);
2070 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2074 SCM l
, fl
, applicable
= SCM_EOL
;
2076 SCM buffer
[BUFFSIZE
];
2080 scm_t_array_handle handle
;
2082 /* Build the list of arguments types */
2083 if (len
>= BUFFSIZE
)
2085 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2086 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2089 note that we don't have to work to reset the generation
2090 count. TMP is a new vector anyway, and it is found
2097 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2098 *p
++ = scm_class_of (SCM_CAR (args
));
2100 /* Build a list of all applicable methods */
2101 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2103 fl
= SPEC_OF (SCM_CAR (l
));
2104 /* Only accept accessors which match exactly in first arg. */
2105 if (SCM_ACCESSORP (SCM_CAR (l
))
2106 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2108 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2110 if (SCM_INSTANCEP (fl
)
2111 /* We have a dotted argument list */
2112 || (i
>= len
&& scm_is_null (fl
)))
2113 { /* both list exhausted */
2114 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2120 || !applicablep (types
[i
], SCM_CAR (fl
)))
2125 if (len
>= BUFFSIZE
)
2126 scm_array_handle_release (&handle
);
2132 CALL_GF2 ("no-applicable-method", gf
, save
);
2133 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2139 : sort_applicable_methods (applicable
, count
, types
));
2143 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2146 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2149 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2150 #define FUNC_NAME s_sys_compute_applicable_methods
2153 SCM_VALIDATE_GENERIC (1, gf
);
2154 n
= scm_ilength (args
);
2155 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2156 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2160 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2161 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
));
2164 lock_cache_mutex (void *m
)
2166 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2167 scm_lock_mutex (mutex
);
2171 unlock_cache_mutex (void *m
)
2173 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2174 scm_unlock_mutex (mutex
);
2178 call_memoize_method (void *a
)
2180 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2181 SCM gf
= SCM_CAR (args
);
2182 SCM x
= SCM_CADR (args
);
2183 /* First check if another thread has inserted a method between
2184 * the cache miss and locking the mutex.
2186 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2187 if (scm_is_true (cmethod
))
2189 /*fixme* Use scm_apply */
2190 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2194 scm_memoize_method (SCM x
, SCM args
)
2196 SCM gf
= SCM_CAR (scm_last_pair (x
));
2197 return scm_internal_dynamic_wind (
2199 call_memoize_method
,
2201 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2202 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2205 /******************************************************************************
2207 * A simple make (which will be redefined later in Scheme)
2208 * This version handles only creation of gf, methods and classes (no instances)
2210 * Since this code will disappear when Goops will be fully booted,
2211 * no precaution is taken to be efficient.
2213 ******************************************************************************/
2215 SCM_KEYWORD (k_setter
, "setter");
2216 SCM_KEYWORD (k_specializers
, "specializers");
2217 SCM_KEYWORD (k_procedure
, "procedure");
2218 SCM_KEYWORD (k_dsupers
, "dsupers");
2219 SCM_KEYWORD (k_slots
, "slots");
2220 SCM_KEYWORD (k_gf
, "generic-function");
2222 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2224 "Make a new object. @var{args} must contain the class and\n"
2225 "all necessary initialization information.")
2226 #define FUNC_NAME s_scm_make
2229 long len
= scm_ilength (args
);
2231 if (len
<= 0 || (len
& 1) == 0)
2232 SCM_WRONG_NUM_ARGS ();
2234 class = SCM_CAR(args
);
2235 args
= SCM_CDR(args
);
2237 if (class == scm_class_generic
|| class == scm_class_accessor
)
2239 z
= scm_make_struct (class, SCM_INUM0
,
2240 scm_list_5 (SCM_EOL
,
2245 scm_set_procedure_property_x (z
, scm_sym_name
,
2246 scm_get_keyword (k_name
,
2249 clear_method_cache (z
);
2250 if (class == scm_class_accessor
)
2252 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2253 if (scm_is_true (setter
))
2254 scm_sys_set_object_setter_x (z
, setter
);
2259 z
= scm_sys_allocate_instance (class, args
);
2261 if (class == scm_class_method
2262 || class == scm_class_simple_method
2263 || class == scm_class_accessor_method
)
2265 SCM_SET_SLOT (z
, scm_si_generic_function
,
2266 scm_i_get_keyword (k_gf
,
2271 SCM_SET_SLOT (z
, scm_si_specializers
,
2272 scm_i_get_keyword (k_specializers
,
2277 SCM_SET_SLOT (z
, scm_si_procedure
,
2278 scm_i_get_keyword (k_procedure
,
2283 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2287 /* In all the others case, make a new class .... No instance here */
2288 SCM_SET_SLOT (z
, scm_si_name
,
2289 scm_i_get_keyword (k_name
,
2292 scm_from_locale_symbol ("???"),
2294 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2295 scm_i_get_keyword (k_dsupers
,
2300 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2301 scm_i_get_keyword (k_slots
,
2312 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2315 #define FUNC_NAME s_scm_find_method
2318 long len
= scm_ilength (l
);
2321 SCM_WRONG_NUM_ARGS ();
2323 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2324 SCM_VALIDATE_GENERIC (1, gf
);
2325 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2326 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2328 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2332 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2333 (SCM m1
, SCM m2
, SCM targs
),
2334 "Return true if method @var{m1} is more specific than @var{m2} "
2335 "given the argument types (classes) listed in @var{targs}.")
2336 #define FUNC_NAME s_scm_sys_method_more_specific_p
2340 long i
, len
, m1_specs
, m2_specs
;
2341 scm_t_array_handle handle
;
2343 SCM_VALIDATE_METHOD (1, m1
);
2344 SCM_VALIDATE_METHOD (2, m2
);
2346 len
= scm_ilength (targs
);
2347 m1_specs
= scm_ilength (SPEC_OF (m1
));
2348 m2_specs
= scm_ilength (SPEC_OF (m2
));
2349 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2350 targs
, SCM_ARG3
, FUNC_NAME
);
2352 /* Verify that all the arguments of TARGS are classes and place them
2355 v
= scm_c_make_vector (len
, SCM_EOL
);
2356 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2358 for (i
= 0, l
= targs
;
2359 i
< len
&& scm_is_pair (l
);
2360 i
++, l
= SCM_CDR (l
))
2362 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2363 v_elts
[i
] = SCM_CAR (l
);
2365 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2367 scm_array_handle_release (&handle
);
2375 /******************************************************************************
2379 ******************************************************************************/
2382 fix_cpl (SCM c
, SCM before
, SCM after
)
2384 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2385 SCM ls
= scm_c_memq (after
, cpl
);
2386 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2387 if (scm_is_false (ls
))
2388 /* if this condition occurs, fix_cpl should not be applied this way */
2390 SCM_SETCAR (ls
, before
);
2391 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2393 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2394 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2395 SCM g_n_s
= compute_getters_n_setters (slots
);
2396 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2397 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2403 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2405 SCM tmp
= scm_from_locale_symbol (name
);
2407 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2411 : scm_list_1 (super
),
2417 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2420 create_standard_classes (void)
2423 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2424 scm_from_locale_symbol ("specializers"),
2426 scm_from_locale_symbol ("code-table"));
2427 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2429 k_slot_definition
));
2430 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2431 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2435 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2436 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2439 scm_list_3 (scm_from_locale_symbol ("used-by"),
2442 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2445 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2448 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2451 /* Foreign class slot classes */
2452 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2453 scm_class_class
, scm_class_top
, SCM_EOL
);
2454 make_stdcls (&scm_class_protected
, "<protected-slot>",
2455 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2456 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2457 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2458 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2459 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2460 make_stdcls (&scm_class_self
, "<self-slot>",
2462 scm_class_read_only
,
2464 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2466 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2468 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2470 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2472 make_stdcls (&scm_class_scm
, "<scm-slot>",
2473 scm_class_class
, scm_class_protected
, SCM_EOL
);
2474 make_stdcls (&scm_class_int
, "<int-slot>",
2475 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2476 make_stdcls (&scm_class_float
, "<float-slot>",
2477 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2478 make_stdcls (&scm_class_double
, "<double-slot>",
2479 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2481 /* Continue initialization of class <class> */
2483 slots
= build_class_class_slots ();
2484 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2485 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2486 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2487 compute_getters_n_setters (slots
));
2489 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2490 scm_class_class
, scm_class_class
,
2491 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2494 scm_list_3 (scm_from_locale_symbol ("destructor"),
2496 scm_class_opaque
)));
2497 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2498 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2499 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2501 /* scm_class_generic functions classes */
2502 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2503 scm_class_class
, scm_class_class
, SCM_EOL
);
2504 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2505 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2506 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2507 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2508 make_stdcls (&scm_class_operator_with_setter_class
,
2509 "<operator-with-setter-class>",
2510 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2511 make_stdcls (&scm_class_method
, "<method>",
2512 scm_class_class
, scm_class_object
, method_slots
);
2513 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2514 scm_class_class
, scm_class_method
, SCM_EOL
);
2515 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2516 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2517 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2518 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2519 make_stdcls (&scm_class_applicable
, "<applicable>",
2520 scm_class_class
, scm_class_top
, SCM_EOL
);
2521 make_stdcls (&scm_class_entity
, "<entity>",
2522 scm_class_entity_class
,
2523 scm_list_2 (scm_class_object
, scm_class_applicable
),
2525 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2526 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2527 make_stdcls (&scm_class_generic
, "<generic>",
2528 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2529 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2530 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2531 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2532 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2533 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2534 scm_class_entity_class
,
2535 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2537 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2538 make_stdcls (&scm_class_accessor
, "<accessor>",
2539 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2540 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2541 make_stdcls (&scm_class_extended_generic_with_setter
,
2542 "<extended-generic-with-setter>",
2543 scm_class_entity_class
,
2544 scm_list_2 (scm_class_generic_with_setter
,
2545 scm_class_extended_generic
),
2547 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2548 SCM_CLASSF_PURE_GENERIC
);
2549 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2550 scm_class_entity_class
,
2551 scm_list_2 (scm_class_accessor
,
2552 scm_class_extended_generic_with_setter
),
2554 fix_cpl (scm_class_extended_accessor
,
2555 scm_class_extended_generic
, scm_class_generic
);
2556 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2558 /* Primitive types classes */
2559 make_stdcls (&scm_class_boolean
, "<boolean>",
2560 scm_class_class
, scm_class_top
, SCM_EOL
);
2561 make_stdcls (&scm_class_char
, "<char>",
2562 scm_class_class
, scm_class_top
, SCM_EOL
);
2563 make_stdcls (&scm_class_list
, "<list>",
2564 scm_class_class
, scm_class_top
, SCM_EOL
);
2565 make_stdcls (&scm_class_pair
, "<pair>",
2566 scm_class_class
, scm_class_list
, SCM_EOL
);
2567 make_stdcls (&scm_class_null
, "<null>",
2568 scm_class_class
, scm_class_list
, SCM_EOL
);
2569 make_stdcls (&scm_class_string
, "<string>",
2570 scm_class_class
, scm_class_top
, SCM_EOL
);
2571 make_stdcls (&scm_class_symbol
, "<symbol>",
2572 scm_class_class
, scm_class_top
, SCM_EOL
);
2573 make_stdcls (&scm_class_vector
, "<vector>",
2574 scm_class_class
, scm_class_top
, SCM_EOL
);
2575 make_stdcls (&scm_class_number
, "<number>",
2576 scm_class_class
, scm_class_top
, SCM_EOL
);
2577 make_stdcls (&scm_class_complex
, "<complex>",
2578 scm_class_class
, scm_class_number
, SCM_EOL
);
2579 make_stdcls (&scm_class_real
, "<real>",
2580 scm_class_class
, scm_class_complex
, SCM_EOL
);
2581 make_stdcls (&scm_class_integer
, "<integer>",
2582 scm_class_class
, scm_class_real
, SCM_EOL
);
2583 make_stdcls (&scm_class_fraction
, "<fraction>",
2584 scm_class_class
, scm_class_real
, SCM_EOL
);
2585 make_stdcls (&scm_class_keyword
, "<keyword>",
2586 scm_class_class
, scm_class_top
, SCM_EOL
);
2587 make_stdcls (&scm_class_unknown
, "<unknown>",
2588 scm_class_class
, scm_class_top
, SCM_EOL
);
2589 make_stdcls (&scm_class_procedure
, "<procedure>",
2590 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2591 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2592 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2593 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2594 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2595 make_stdcls (&scm_class_port
, "<port>",
2596 scm_class_class
, scm_class_top
, SCM_EOL
);
2597 make_stdcls (&scm_class_input_port
, "<input-port>",
2598 scm_class_class
, scm_class_port
, SCM_EOL
);
2599 make_stdcls (&scm_class_output_port
, "<output-port>",
2600 scm_class_class
, scm_class_port
, SCM_EOL
);
2601 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2603 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2607 /**********************************************************************
2611 **********************************************************************/
2614 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2620 sprintf (buffer
, template, type_name
);
2621 name
= scm_from_locale_symbol (buffer
);
2624 name
= SCM_GOOPS_UNBOUND
;
2626 class = scm_permanent_object (scm_basic_make_class (applicablep
2627 ? scm_class_procedure_class
2633 /* Only define name if doesn't already exist. */
2634 if (!SCM_GOOPS_UNBOUNDP (name
)
2635 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2636 DEFVAR (name
, class);
2641 scm_make_extended_class (char const *type_name
, int applicablep
)
2643 return make_class_from_template ("<%s>",
2645 scm_list_1 (applicablep
2646 ? scm_class_applicable
2652 scm_i_inherit_applicable (SCM c
)
2654 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2656 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2657 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2658 /* patch scm_class_applicable into direct-supers */
2659 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2660 if (scm_is_false (top
))
2661 dsupers
= scm_append (scm_list_2 (dsupers
,
2662 scm_list_1 (scm_class_applicable
)));
2665 SCM_SETCAR (top
, scm_class_applicable
);
2666 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2668 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2669 /* patch scm_class_applicable into cpl */
2670 top
= scm_c_memq (scm_class_top
, cpl
);
2671 if (scm_is_false (top
))
2675 SCM_SETCAR (top
, scm_class_applicable
);
2676 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2678 /* add class to direct-subclasses of scm_class_applicable */
2679 SCM_SET_SLOT (scm_class_applicable
,
2680 scm_si_direct_subclasses
,
2681 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2682 scm_si_direct_subclasses
)));
2687 create_smob_classes (void)
2691 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2692 for (i
= 0; i
< 255; ++i
)
2693 scm_smob_class
[i
] = 0;
2695 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2697 for (i
= 0; i
< scm_numsmob
; ++i
)
2698 if (!scm_smob_class
[i
])
2699 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2700 scm_smobs
[i
].apply
!= 0);
2704 scm_make_port_classes (long ptobnum
, char *type_name
)
2706 SCM c
, class = make_class_from_template ("<%s-port>",
2708 scm_list_1 (scm_class_port
),
2710 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2711 = make_class_from_template ("<%s-input-port>",
2713 scm_list_2 (class, scm_class_input_port
),
2715 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2716 = make_class_from_template ("<%s-output-port>",
2718 scm_list_2 (class, scm_class_output_port
),
2720 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2722 = make_class_from_template ("<%s-input-output-port>",
2724 scm_list_2 (class, scm_class_input_output_port
),
2726 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2727 SCM_SET_SLOT (c
, scm_si_cpl
,
2728 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2732 create_port_classes (void)
2736 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2737 for (i
= 0; i
< 3 * 256; ++i
)
2738 scm_port_class
[i
] = 0;
2740 for (i
= 0; i
< scm_numptob
; ++i
)
2741 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2745 make_struct_class (void *closure SCM_UNUSED
,
2746 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2748 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2749 SCM_SET_STRUCT_TABLE_CLASS (data
,
2750 scm_make_extended_class
2751 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2752 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2753 return SCM_UNSPECIFIED
;
2757 create_struct_classes (void)
2759 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2762 /**********************************************************************
2766 **********************************************************************/
2771 if (!goops_loaded_p
)
2772 scm_c_resolve_module ("oop goops");
2777 scm_make_foreign_object (SCM
class, SCM initargs
)
2778 #define FUNC_NAME s_scm_make
2780 void * (*constructor
) (SCM
)
2781 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2782 if (constructor
== 0)
2783 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2784 return scm_wrap_object (class, constructor (initargs
));
2790 scm_free_foreign_object (SCM
*class, SCM
*data
)
2792 size_t (*destructor
) (void *)
2793 = (size_t (*) (void *)) class[scm_si_destructor
];
2794 return destructor (data
);
2798 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2799 void * (*constructor
) (SCM initargs
),
2800 size_t (*destructor
) (void *))
2803 name
= scm_from_locale_symbol (s_name
);
2804 if (scm_is_null (supers
))
2805 supers
= scm_list_1 (scm_class_foreign_object
);
2806 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2807 scm_sys_inherit_magic_x (class, supers
);
2809 if (destructor
!= 0)
2811 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2812 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2816 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2817 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2820 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2821 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2826 SCM_SYMBOL (sym_o
, "o");
2827 SCM_SYMBOL (sym_x
, "x");
2829 SCM_KEYWORD (k_accessor
, "accessor");
2830 SCM_KEYWORD (k_getter
, "getter");
2833 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2835 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2840 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2841 SCM (*getter
) (SCM obj
),
2842 SCM (*setter
) (SCM obj
, SCM x
),
2843 char *accessor_name
)
2846 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2847 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2848 setter
? setter
: default_setter
);
2850 /* Dirk:FIXME:: The following two expressions make use of the fact that
2851 * the memoizer will accept a subr-object in the place of a function.
2852 * This is not guaranteed to stay this way. */
2853 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2855 scm_list_2 (get
, sym_o
)),
2857 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2858 scm_list_2 (sym_o
, sym_x
),
2859 scm_list_3 (set
, sym_o
, sym_x
)),
2863 SCM name
= scm_from_locale_symbol (slot_name
);
2864 SCM aname
= scm_from_locale_symbol (accessor_name
);
2865 SCM gf
= scm_ensure_accessor (aname
);
2866 SCM slot
= scm_list_5 (name
,
2869 setter
? k_accessor
: k_getter
,
2871 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2876 scm_add_method (scm_setter (gf
),
2877 scm_make (scm_list_5 (scm_class_accessor_method
,
2879 scm_list_2 (class, scm_class_top
),
2884 SCM_SET_SLOT (class, scm_si_slots
,
2885 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2886 scm_list_1 (slot
))));
2888 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2889 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
2891 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2892 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2893 scm_list_1 (gns
))));
2894 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2901 scm_wrap_object (SCM
class, void *data
)
2903 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2911 scm_wrap_component (SCM
class, SCM container
, void *data
)
2913 SCM obj
= scm_wrap_object (class, data
);
2914 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2920 SCM_SETCDR (handle
, container
);
2925 scm_ensure_accessor (SCM name
)
2927 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2928 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2930 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2931 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2932 k_name
, name
, k_setter
, gf
));
2937 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2940 scm_add_method (SCM gf
, SCM m
)
2942 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2947 * Debugging utilities
2950 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2952 "Return @code{#t} if @var{obj} is a pure generic.")
2953 #define FUNC_NAME s_scm_pure_generic_p
2955 return scm_from_bool (SCM_PUREGENERICP (obj
));
2959 #endif /* GUILE_DEBUG */
2965 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2967 "Announce that GOOPS is loaded and perform initialization\n"
2968 "on the C level which depends on the loaded GOOPS modules.")
2969 #define FUNC_NAME s_scm_sys_goops_loaded
2972 var_compute_applicable_methods
=
2973 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2975 setup_extended_primitive_generics ();
2976 return SCM_UNSPECIFIED
;
2980 SCM scm_module_goops
;
2983 scm_init_goops_builtins (void)
2985 scm_module_goops
= scm_current_module ();
2986 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2988 /* Not really necessary right now, but who knows...
2990 scm_permanent_object (scm_module_goops
);
2991 scm_permanent_object (scm_goops_lookup_closure
);
2993 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2994 (scm_from_int (37)));
2996 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2998 #include "libguile/goops.x"
3000 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3002 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3003 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3005 create_basic_classes ();
3006 create_standard_classes ();
3007 create_smob_classes ();
3008 create_struct_classes ();
3009 create_port_classes ();
3012 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3013 scm_no_applicable_method
3014 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3017 DEFVAR (name
, scm_no_applicable_method
);
3020 return SCM_UNSPECIFIED
;
3026 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3027 scm_init_goops_builtins
);