1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004
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>.
29 #include "libguile/_scm.h"
30 #include "libguile/alist.h"
31 #include "libguile/async.h"
32 #include "libguile/chars.h"
33 #include "libguile/debug.h"
34 #include "libguile/dynl.h"
35 #include "libguile/dynwind.h"
36 #include "libguile/eval.h"
37 #include "libguile/hashtab.h"
38 #include "libguile/keywords.h"
39 #include "libguile/macros.h"
40 #include "libguile/modules.h"
41 #include "libguile/objects.h"
42 #include "libguile/ports.h"
43 #include "libguile/procprop.h"
44 #include "libguile/random.h"
45 #include "libguile/root.h"
46 #include "libguile/smob.h"
47 #include "libguile/strings.h"
48 #include "libguile/strports.h"
49 #include "libguile/vectors.h"
50 #include "libguile/weaks.h"
52 #include "libguile/validate.h"
53 #include "libguile/goops.h"
55 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
57 #define DEFVAR(v, val) \
58 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
60 /* Temporary hack until we get the new module system */
61 /*fixme* Should optimize by keeping track of the variable object itself */
62 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
65 /* Fixme: Should use already interned symbols */
67 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
69 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
71 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
73 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
76 /* Class redefinition protocol:
78 A class is represented by a heap header h1 which points to a
79 malloc:ed memory block m1.
81 When a new version of a class is created, a new header h2 and
82 memory block m2 are allocated. The headers h1 and h2 then switch
83 pointers so that h1 refers to m2 and h2 to m1. In this way, names
84 bound to h1 will point to the new class at the same time as h2 will
85 be a handle which the GC will use to free m1.
87 The `redefined' slot of m1 will be set to point to h1. An old
88 instance will have its class pointer (the CAR of the heap header)
89 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
90 the class modification and the new class pointer can be found via
94 /* The following definition is located in libguile/objects.h:
95 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
98 #define TEST_CHANGE_CLASS(obj, class) \
100 class = SCM_CLASS_OF (obj); \
101 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
103 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
104 class = SCM_CLASS_OF (obj); \
108 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
109 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
111 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
112 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
114 static int goops_loaded_p
= 0;
115 static scm_t_rstate
*goops_rstate
;
117 static SCM scm_goops_lookup_closure
;
119 /* These variables are filled in by the object system when loaded. */
120 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
121 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
122 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
123 SCM scm_class_vector
, scm_class_null
;
124 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
125 SCM scm_class_unknown
;
126 SCM scm_class_top
, scm_class_object
, scm_class_class
;
127 SCM scm_class_applicable
;
128 SCM scm_class_entity
, scm_class_entity_with_setter
;
129 SCM scm_class_generic
, scm_class_generic_with_setter
;
130 SCM scm_class_accessor
;
131 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
132 SCM scm_class_extended_accessor
;
133 SCM scm_class_method
;
134 SCM scm_class_simple_method
, scm_class_accessor_method
;
135 SCM scm_class_procedure_class
;
136 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
137 SCM scm_class_entity_class
;
138 SCM scm_class_number
, scm_class_list
;
139 SCM scm_class_keyword
;
140 SCM scm_class_port
, scm_class_input_output_port
;
141 SCM scm_class_input_port
, scm_class_output_port
;
142 SCM scm_class_foreign_class
, scm_class_foreign_object
;
143 SCM scm_class_foreign_slot
;
144 SCM scm_class_self
, scm_class_protected
;
145 SCM scm_class_opaque
, scm_class_read_only
;
146 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
148 SCM scm_class_int
, scm_class_float
, scm_class_double
;
150 SCM
*scm_port_class
= 0;
151 SCM
*scm_smob_class
= 0;
153 SCM scm_no_applicable_method
;
155 SCM_SYMBOL (scm_sym_define_public
, "define-public");
157 static SCM
scm_make_unbound (void);
158 static SCM
scm_unbound_p (SCM obj
);
159 static SCM
scm_assert_bound (SCM value
, SCM obj
);
160 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
161 static SCM
scm_sys_goops_loaded (void);
163 /* This function is used for efficient type dispatch. */
164 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
166 "Return the class of @var{x}.")
167 #define FUNC_NAME s_scm_class_of
169 switch (SCM_ITAG3 (x
))
173 return scm_class_integer
;
177 return scm_class_char
;
178 else if (scm_is_bool (x
))
179 return scm_class_boolean
;
180 else if (scm_is_null (x
))
181 return scm_class_null
;
183 return scm_class_unknown
;
186 switch (SCM_TYP7 (x
))
188 case scm_tcs_cons_nimcar
:
189 return scm_class_pair
;
190 case scm_tcs_closures
:
191 return scm_class_procedure
;
193 return scm_class_symbol
;
196 return scm_class_vector
;
198 return scm_class_string
;
200 switch SCM_TYP16 (x
) {
202 return scm_class_integer
;
204 return scm_class_real
;
205 case scm_tc16_complex
:
206 return scm_class_complex
;
207 case scm_tc16_fraction
:
208 return scm_class_fraction
;
218 case scm_tc7_subr_1o
:
219 case scm_tc7_subr_2o
:
220 case scm_tc7_lsubr_2
:
222 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
223 return scm_class_primitive_generic
;
225 return scm_class_procedure
;
227 return scm_class_procedure
;
229 return scm_class_procedure_with_setter
;
233 scm_t_bits type
= SCM_TYP16 (x
);
234 if (type
!= scm_tc16_port_with_ps
)
235 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
236 x
= SCM_PORT_WITH_PS_PORT (x
);
237 /* fall through to ports */
240 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
241 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
242 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
243 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
244 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
246 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
247 return SCM_CLASS_OF (x
);
248 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
251 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
252 scm_change_object_class (x
,
253 SCM_CLASS_OF (x
), /* old */
254 SCM_OBJ_CLASS_REDEF (x
)); /* new */
255 return SCM_CLASS_OF (x
);
259 /* ordinary struct */
260 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
261 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
262 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
265 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
266 SCM
class = scm_make_extended_class (scm_is_true (name
)
267 ? scm_i_symbol_chars (name
)
269 SCM_I_OPERATORP (x
));
270 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
276 return scm_class_pair
;
278 return scm_class_unknown
;
284 case scm_tc3_closure
:
288 return scm_class_unknown
;
292 /******************************************************************************
296 * This version doesn't fully handle multiple-inheritance. It serves
297 * only for booting classes and will be overloaded in Scheme
299 ******************************************************************************/
302 map (SCM (*proc
) (SCM
), SCM ls
)
304 if (scm_is_null (ls
))
308 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
311 while (!scm_is_null (ls
))
313 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
325 while (!scm_is_null (ls
))
327 SCM el
= SCM_CAR (ls
);
328 if (scm_is_false (scm_c_memq (el
, res
)))
329 res
= scm_cons (el
, res
);
336 compute_cpl (SCM
class)
339 return CALL_GF1 ("compute-cpl", class);
342 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
343 SCM ls
= scm_append (scm_acons (class, supers
,
344 map (compute_cpl
, supers
)));
345 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
349 /******************************************************************************
353 ******************************************************************************/
356 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
364 if (!scm_is_symbol (tmp
))
365 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
367 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
368 res
= scm_cons (SCM_CAR (l
), res
);
369 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
372 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
376 build_slots_list (SCM dslots
, SCM cpl
)
378 register SCM res
= dslots
;
380 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
381 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
382 scm_si_direct_slots
),
385 /* res contains a list of slots. Remove slots which appears more than once */
386 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
393 while (!scm_is_null (ls
))
395 if (!scm_is_pair (SCM_CAR (ls
)))
396 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
403 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
405 "Return a list consisting of the names of all slots belonging to\n"
406 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
408 #define FUNC_NAME s_scm_sys_compute_slots
410 SCM_VALIDATE_CLASS (1, class);
411 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
412 SCM_SLOT (class, scm_si_cpl
));
417 /******************************************************************************
419 * compute-getters-n-setters
421 * This version doesn't handle slot options. It serves only for booting
422 * classes and will be overloaded in Scheme.
424 ******************************************************************************/
426 SCM_KEYWORD (k_init_value
, "init-value");
427 SCM_KEYWORD (k_init_thunk
, "init-thunk");
430 compute_getters_n_setters (SCM slots
)
436 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
438 SCM init
= SCM_BOOL_F
;
439 SCM options
= SCM_CDAR (slots
);
440 if (!scm_is_null (options
))
442 init
= scm_get_keyword (k_init_value
, options
, 0);
445 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
447 scm_list_2 (scm_sym_quote
,
452 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
454 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
456 scm_from_int (i
++))),
458 cdrloc
= SCM_CDRLOC (*cdrloc
);
463 /******************************************************************************
467 ******************************************************************************/
469 /*fixme* Manufacture keywords in advance */
471 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
475 for (i
= 0; i
!= len
; i
+= 2)
477 SCM obj
= SCM_CAR (l
);
479 if (!scm_is_keyword (obj
))
480 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
481 else if (scm_is_eq (obj
, key
))
487 return default_value
;
491 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
492 (SCM key
, SCM l
, SCM default_value
),
493 "Determine an associated value for the keyword @var{key} from\n"
494 "the list @var{l}. The list @var{l} has to consist of an even\n"
495 "number of elements, where, starting with the first, every\n"
496 "second element is a keyword, followed by its associated value.\n"
497 "If @var{l} does not hold a value for @var{key}, the value\n"
498 "@var{default_value} is returned.")
499 #define FUNC_NAME s_scm_get_keyword
503 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
504 len
= scm_ilength (l
);
505 if (len
< 0 || len
% 2 == 1)
506 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
508 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
513 SCM_KEYWORD (k_init_keyword
, "init-keyword");
515 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
516 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
518 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
519 (SCM obj
, SCM initargs
),
520 "Initialize the object @var{obj} with the given arguments\n"
522 #define FUNC_NAME s_scm_sys_initialize_object
524 SCM tmp
, get_n_set
, slots
;
525 SCM
class = SCM_CLASS_OF (obj
);
528 SCM_VALIDATE_INSTANCE (1, obj
);
529 n_initargs
= scm_ilength (initargs
);
530 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
532 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
533 slots
= SCM_SLOT (class, scm_si_slots
);
535 /* See for each slot how it must be initialized */
537 !scm_is_null (slots
);
538 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
540 SCM slot_name
= SCM_CAR (slots
);
543 if (!scm_is_null (SCM_CDR (slot_name
)))
545 /* This slot admits (perhaps) to be initialized at creation time */
546 long n
= scm_ilength (SCM_CDR (slot_name
));
547 if (n
& 1) /* odd or -1 */
548 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
549 scm_list_1 (slot_name
));
550 tmp
= scm_i_get_keyword (k_init_keyword
,
555 slot_name
= SCM_CAR (slot_name
);
558 /* an initarg was provided for this slot */
559 if (!scm_is_keyword (tmp
))
560 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
562 slot_value
= scm_i_get_keyword (tmp
,
571 /* set slot to provided value */
572 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
575 /* set slot to its :init-form if it exists */
576 tmp
= SCM_CADAR (get_n_set
);
577 if (scm_is_true (tmp
))
579 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
580 if (SCM_GOOPS_UNBOUNDP (slot_value
))
582 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
583 set_slot_value (class,
586 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
596 /* NOTE: The following macros are interdependent with code
597 * in goops.scm:compute-getters-n-setters
599 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
600 (SCM_I_INUMP (SCM_CDDR (gns)) \
601 || (scm_is_pair (SCM_CDDR (gns)) \
602 && scm_is_pair (SCM_CDDDR (gns)) \
603 && scm_is_pair (SCM_CDDDDR (gns))))
604 #define SCM_GNS_INDEX(gns) \
605 (SCM_I_INUMP (SCM_CDDR (gns)) \
606 ? SCM_I_INUM (SCM_CDDR (gns)) \
607 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
608 #define SCM_GNS_SIZE(gns) \
609 (SCM_I_INUMP (SCM_CDDR (gns)) \
611 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
613 SCM_KEYWORD (k_class
, "class");
614 SCM_KEYWORD (k_allocation
, "allocation");
615 SCM_KEYWORD (k_instance
, "instance");
617 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
620 #define FUNC_NAME s_scm_sys_prep_layout_x
622 SCM slots
, getters_n_setters
, nfields
;
623 unsigned long int n
, i
;
627 SCM_VALIDATE_INSTANCE (1, class);
628 slots
= SCM_SLOT (class, scm_si_slots
);
629 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
630 nfields
= SCM_SLOT (class, scm_si_nfields
);
631 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
632 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
633 scm_list_1 (nfields
));
634 n
= 2 * SCM_I_INUM (nfields
);
635 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
636 && SCM_SUBCLASSP (class, scm_class_class
))
637 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
638 scm_list_1 (nfields
));
640 layout
= scm_i_make_string (n
, &s
);
642 while (scm_is_pair (getters_n_setters
))
644 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
647 int len
, index
, size
;
650 if (i
>= n
|| !scm_is_pair (slots
))
653 /* extract slot type */
654 len
= scm_ilength (SCM_CDAR (slots
));
655 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
656 len
, SCM_BOOL_F
, FUNC_NAME
);
657 /* determine slot GC protection and access mode */
658 if (scm_is_false (type
))
665 if (!SCM_CLASSP (type
))
666 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
667 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
669 if (SCM_SUBCLASSP (type
, scm_class_self
))
671 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
676 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
678 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
690 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
691 if (index
!= (i
>> 1))
693 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
701 slots
= SCM_CDR (slots
);
702 getters_n_setters
= SCM_CDR (getters_n_setters
);
704 if (!scm_is_null (slots
))
707 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
709 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
710 return SCM_UNSPECIFIED
;
714 static void prep_hashsets (SCM
);
716 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
717 (SCM
class, SCM dsupers
),
719 #define FUNC_NAME s_scm_sys_inherit_magic_x
723 SCM_VALIDATE_INSTANCE (1, class);
724 while (!scm_is_null (ls
))
726 SCM_ASSERT (scm_is_pair (ls
)
727 && SCM_INSTANCEP (SCM_CAR (ls
)),
731 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
734 flags
&= SCM_CLASSF_INHERIT
;
736 if (! (flags
& SCM_CLASSF_ENTITY
))
738 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
741 * We could avoid calling scm_gc_malloc in the allocation code
742 * (in which case the following two lines are needed). Instead
743 * we make 0-slot instances non-light, so that the light case
744 * can be handled without special cases.
747 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
749 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
751 /* NOTE: The following depends on scm_struct_i_size. */
752 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
755 SCM_SET_CLASS_FLAGS (class, flags
);
757 prep_hashsets (class);
759 return SCM_UNSPECIFIED
;
764 prep_hashsets (SCM
class)
768 for (i
= 0; i
< 7; ++i
)
769 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
772 /******************************************************************************/
775 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
777 SCM z
, cpl
, slots
, nfields
, g_n_s
;
779 /* Allocate one instance */
780 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
782 /* Initialize its slots */
783 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
784 cpl
= compute_cpl (z
);
785 slots
= build_slots_list (maplist (dslots
), cpl
);
786 nfields
= scm_from_int (scm_ilength (slots
));
787 g_n_s
= compute_getters_n_setters (slots
);
789 SCM_SET_SLOT (z
, scm_si_name
, name
);
790 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
791 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
792 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
793 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
794 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
795 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
796 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
797 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
798 SCM_SET_SLOT (z
, scm_si_environment
,
799 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
801 /* Add this class in the direct-subclasses slot of dsupers */
804 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
805 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
806 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
807 scm_si_direct_subclasses
)));
810 /* Support for the underlying structs: */
811 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
812 ? (SCM_CLASSF_GOOPS_OR_VALID
813 | SCM_CLASSF_OPERATOR
815 : class == scm_class_operator_class
816 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
817 : SCM_CLASSF_GOOPS_OR_VALID
));
822 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
824 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
825 scm_sys_inherit_magic_x (z
, dsupers
);
826 scm_sys_prep_layout_x (z
);
830 /******************************************************************************/
832 SCM_SYMBOL (sym_layout
, "layout");
833 SCM_SYMBOL (sym_vcell
, "vcell");
834 SCM_SYMBOL (sym_vtable
, "vtable");
835 SCM_SYMBOL (sym_print
, "print");
836 SCM_SYMBOL (sym_procedure
, "procedure");
837 SCM_SYMBOL (sym_setter
, "setter");
838 SCM_SYMBOL (sym_redefined
, "redefined");
839 SCM_SYMBOL (sym_h0
, "h0");
840 SCM_SYMBOL (sym_h1
, "h1");
841 SCM_SYMBOL (sym_h2
, "h2");
842 SCM_SYMBOL (sym_h3
, "h3");
843 SCM_SYMBOL (sym_h4
, "h4");
844 SCM_SYMBOL (sym_h5
, "h5");
845 SCM_SYMBOL (sym_h6
, "h6");
846 SCM_SYMBOL (sym_h7
, "h7");
847 SCM_SYMBOL (sym_name
, "name");
848 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
849 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
850 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
851 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
852 SCM_SYMBOL (sym_cpl
, "cpl");
853 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
854 SCM_SYMBOL (sym_slots
, "slots");
855 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
856 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
857 SCM_SYMBOL (sym_nfields
, "nfields");
858 SCM_SYMBOL (sym_environment
, "environment");
862 build_class_class_slots ()
865 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
866 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
867 scm_list_1 (sym_print
),
868 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
869 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
870 scm_list_1 (sym_redefined
),
871 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
872 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
873 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
874 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
875 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
876 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
877 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
878 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
879 scm_list_1 (sym_name
),
880 scm_list_1 (sym_direct_supers
),
881 scm_list_1 (sym_direct_slots
),
882 scm_list_1 (sym_direct_subclasses
),
883 scm_list_1 (sym_direct_methods
),
884 scm_list_1 (sym_cpl
),
885 scm_list_1 (sym_default_slot_definition_class
),
886 scm_list_1 (sym_slots
),
887 scm_list_1 (sym_getters_n_setters
),
888 scm_list_1 (sym_keyword_access
),
889 scm_list_1 (sym_nfields
),
890 scm_list_1 (sym_environment
),
895 create_basic_classes (void)
897 /* SCM slots_of_class = build_class_class_slots (); */
899 /**** <scm_class_class> ****/
900 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
901 + 2 * scm_vtable_offset_user
);
902 SCM name
= scm_from_locale_symbol ("<class>");
903 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
906 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
907 | SCM_CLASSF_METACLASS
));
909 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
910 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
911 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
912 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
913 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
914 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
915 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
916 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
917 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
918 compute_getters_n_setters (slots_of_class)); */
919 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
920 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
921 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
923 prep_hashsets (scm_class_class
);
925 DEFVAR(name
, scm_class_class
);
927 /**** <scm_class_top> ****/
928 name
= scm_from_locale_symbol ("<top>");
929 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
934 DEFVAR(name
, scm_class_top
);
936 /**** <scm_class_object> ****/
937 name
= scm_from_locale_symbol ("<object>");
938 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
940 scm_list_1 (scm_class_top
),
943 DEFVAR (name
, scm_class_object
);
945 /* <top> <object> and <class> were partially initialized. Correct them here */
946 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
948 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
949 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
952 /******************************************************************************/
954 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
956 "Return @code{#t} if @var{obj} is an instance.")
957 #define FUNC_NAME s_scm_instance_p
959 return scm_from_bool (SCM_INSTANCEP (obj
));
964 /******************************************************************************
966 * Meta object accessors
968 ******************************************************************************/
969 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
971 "Return the class name of @var{obj}.")
972 #define FUNC_NAME s_scm_class_name
974 SCM_VALIDATE_CLASS (1, obj
);
975 return scm_slot_ref (obj
, sym_name
);
979 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
981 "Return the direct superclasses of the class @var{obj}.")
982 #define FUNC_NAME s_scm_class_direct_supers
984 SCM_VALIDATE_CLASS (1, obj
);
985 return scm_slot_ref (obj
, sym_direct_supers
);
989 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
991 "Return the direct slots of the class @var{obj}.")
992 #define FUNC_NAME s_scm_class_direct_slots
994 SCM_VALIDATE_CLASS (1, obj
);
995 return scm_slot_ref (obj
, sym_direct_slots
);
999 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1001 "Return the direct subclasses of the class @var{obj}.")
1002 #define FUNC_NAME s_scm_class_direct_subclasses
1004 SCM_VALIDATE_CLASS (1, obj
);
1005 return scm_slot_ref(obj
, sym_direct_subclasses
);
1009 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1011 "Return the direct methods of the class @var{obj}")
1012 #define FUNC_NAME s_scm_class_direct_methods
1014 SCM_VALIDATE_CLASS (1, obj
);
1015 return scm_slot_ref (obj
, sym_direct_methods
);
1019 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1021 "Return the class precedence list of the class @var{obj}.")
1022 #define FUNC_NAME s_scm_class_precedence_list
1024 SCM_VALIDATE_CLASS (1, obj
);
1025 return scm_slot_ref (obj
, sym_cpl
);
1029 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1031 "Return the slot list of the class @var{obj}.")
1032 #define FUNC_NAME s_scm_class_slots
1034 SCM_VALIDATE_CLASS (1, obj
);
1035 return scm_slot_ref (obj
, sym_slots
);
1039 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1041 "Return the environment of the class @var{obj}.")
1042 #define FUNC_NAME s_scm_class_environment
1044 SCM_VALIDATE_CLASS (1, obj
);
1045 return scm_slot_ref(obj
, sym_environment
);
1050 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1052 "Return the name of the generic function @var{obj}.")
1053 #define FUNC_NAME s_scm_generic_function_name
1055 SCM_VALIDATE_GENERIC (1, obj
);
1056 return scm_procedure_property (obj
, scm_sym_name
);
1060 SCM_SYMBOL (sym_methods
, "methods");
1061 SCM_SYMBOL (sym_extended_by
, "extended-by");
1062 SCM_SYMBOL (sym_extends
, "extends");
1065 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1067 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1068 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1069 while (!scm_is_null (gfs
))
1071 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1072 gfs
= SCM_CDR (gfs
);
1074 return method_lists
;
1078 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1080 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1082 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1083 while (!scm_is_null (gfs
))
1085 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1086 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1089 gfs
= SCM_CDR (gfs
);
1092 return method_lists
;
1095 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1097 "Return the methods of the generic function @var{obj}.")
1098 #define FUNC_NAME s_scm_generic_function_methods
1101 SCM_VALIDATE_GENERIC (1, obj
);
1102 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1103 methods
= fold_downward_gf_methods (methods
, obj
);
1104 return scm_append (methods
);
1108 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1110 "Return the generic function for the method @var{obj}.")
1111 #define FUNC_NAME s_scm_method_generic_function
1113 SCM_VALIDATE_METHOD (1, obj
);
1114 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1118 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1120 "Return specializers of the method @var{obj}.")
1121 #define FUNC_NAME s_scm_method_specializers
1123 SCM_VALIDATE_METHOD (1, obj
);
1124 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1128 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1130 "Return the procedure of the method @var{obj}.")
1131 #define FUNC_NAME s_scm_method_procedure
1133 SCM_VALIDATE_METHOD (1, obj
);
1134 return scm_slot_ref (obj
, sym_procedure
);
1138 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1140 "Return the slot definition of the accessor @var{obj}.")
1141 #define FUNC_NAME s_scm_accessor_method_slot_definition
1143 SCM_VALIDATE_ACCESSOR (1, obj
);
1144 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1148 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1150 "Internal GOOPS magic---don't use this function!")
1151 #define FUNC_NAME s_scm_sys_tag_body
1153 return scm_cons (SCM_IM_LAMBDA
, body
);
1157 /******************************************************************************
1159 * S l o t a c c e s s
1161 ******************************************************************************/
1163 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1165 "Return the unbound value.")
1166 #define FUNC_NAME s_scm_make_unbound
1168 return SCM_GOOPS_UNBOUND
;
1172 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1174 "Return @code{#t} if @var{obj} is unbound.")
1175 #define FUNC_NAME s_scm_unbound_p
1177 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1181 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1182 (SCM value
, SCM obj
),
1183 "Return @var{value} if it is bound, and invoke the\n"
1184 "@var{slot-unbound} method of @var{obj} if it is not.")
1185 #define FUNC_NAME s_scm_assert_bound
1187 if (SCM_GOOPS_UNBOUNDP (value
))
1188 return CALL_GF1 ("slot-unbound", obj
);
1193 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1194 (SCM obj
, SCM index
),
1195 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1196 "the value from @var{obj}.")
1197 #define FUNC_NAME s_scm_at_assert_bound_ref
1199 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1200 if (SCM_GOOPS_UNBOUNDP (value
))
1201 return CALL_GF1 ("slot-unbound", obj
);
1206 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1207 (SCM obj
, SCM index
),
1208 "Return the slot value with index @var{index} from @var{obj}.")
1209 #define FUNC_NAME s_scm_sys_fast_slot_ref
1211 unsigned long int i
;
1213 SCM_VALIDATE_INSTANCE (1, obj
);
1214 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1215 return SCM_SLOT (obj
, i
);
1219 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1220 (SCM obj
, SCM index
, SCM value
),
1221 "Set the slot with index @var{index} in @var{obj} to\n"
1223 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1225 unsigned long int i
;
1227 SCM_VALIDATE_INSTANCE (1, obj
);
1228 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1230 SCM_SET_SLOT (obj
, i
, value
);
1232 return SCM_UNSPECIFIED
;
1237 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1238 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1243 /* In the future, this function will return the effective slot
1244 * definition associated with SLOT_NAME. Now it just returns some of
1245 * the information which will be stored in the effective slot
1250 slot_definition_using_name (SCM
class, SCM slot_name
)
1252 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1253 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1254 if (SCM_CAAR (slots
) == slot_name
)
1255 return SCM_CAR (slots
);
1260 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1262 SCM access
= SCM_CDDR (slotdef
);
1264 * - access is an integer (the offset of this slot in the slots vector)
1265 * - otherwise (car access) is the getter function to apply
1267 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1268 * we can just assume fixnums here.
1270 if (SCM_I_INUMP (access
))
1271 return SCM_SLOT (obj
, SCM_I_INUM (access
));
1274 /* We must evaluate (apply (car access) (list obj))
1275 * where (car access) is known to be a closure of arity 1 */
1276 register SCM code
, env
;
1278 code
= SCM_CAR (access
);
1279 if (!SCM_CLOSUREP (code
))
1280 return SCM_SUBRF (code
) (obj
);
1281 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1284 /* Evaluate the closure body */
1285 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1290 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1292 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1293 if (scm_is_true (slotdef
))
1294 return get_slot_value (class, obj
, slotdef
);
1296 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1300 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1302 SCM access
= SCM_CDDR (slotdef
);
1304 * - access is an integer (the offset of this slot in the slots vector)
1305 * - otherwise (cadr access) is the setter function to apply
1307 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1308 * we can just assume fixnums here.
1310 if (SCM_I_INUMP (access
))
1311 SCM_SET_SLOT (obj
, SCM_I_INUM (access
), value
);
1314 /* We must evaluate (apply (cadr l) (list obj value))
1315 * where (cadr l) is known to be a closure of arity 2 */
1316 register SCM code
, env
;
1318 code
= SCM_CADR (access
);
1319 if (!SCM_CLOSUREP (code
))
1320 SCM_SUBRF (code
) (obj
, value
);
1323 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1324 scm_list_2 (obj
, value
),
1326 /* Evaluate the closure body */
1327 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1330 return SCM_UNSPECIFIED
;
1334 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1336 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1337 if (scm_is_true (slotdef
))
1338 return set_slot_value (class, obj
, slotdef
, value
);
1340 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1344 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1348 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1349 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1355 /* ======================================== */
1357 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1358 (SCM
class, SCM obj
, SCM slot_name
),
1360 #define FUNC_NAME s_scm_slot_ref_using_class
1364 SCM_VALIDATE_CLASS (1, class);
1365 SCM_VALIDATE_INSTANCE (2, obj
);
1366 SCM_VALIDATE_SYMBOL (3, slot_name
);
1368 res
= get_slot_value_using_name (class, obj
, slot_name
);
1369 if (SCM_GOOPS_UNBOUNDP (res
))
1370 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1376 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1377 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1379 #define FUNC_NAME s_scm_slot_set_using_class_x
1381 SCM_VALIDATE_CLASS (1, class);
1382 SCM_VALIDATE_INSTANCE (2, obj
);
1383 SCM_VALIDATE_SYMBOL (3, slot_name
);
1385 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1390 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1391 (SCM
class, SCM obj
, SCM slot_name
),
1393 #define FUNC_NAME s_scm_slot_bound_using_class_p
1395 SCM_VALIDATE_CLASS (1, class);
1396 SCM_VALIDATE_INSTANCE (2, obj
);
1397 SCM_VALIDATE_SYMBOL (3, slot_name
);
1399 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1405 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1406 (SCM
class, SCM obj
, SCM slot_name
),
1408 #define FUNC_NAME s_scm_slot_exists_using_class_p
1410 SCM_VALIDATE_CLASS (1, class);
1411 SCM_VALIDATE_INSTANCE (2, obj
);
1412 SCM_VALIDATE_SYMBOL (3, slot_name
);
1413 return test_slot_existence (class, obj
, slot_name
);
1418 /* ======================================== */
1420 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1421 (SCM obj
, SCM slot_name
),
1422 "Return the value from @var{obj}'s slot with the name\n"
1424 #define FUNC_NAME s_scm_slot_ref
1428 SCM_VALIDATE_INSTANCE (1, obj
);
1429 TEST_CHANGE_CLASS (obj
, class);
1431 res
= get_slot_value_using_name (class, obj
, slot_name
);
1432 if (SCM_GOOPS_UNBOUNDP (res
))
1433 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1438 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1439 (SCM obj
, SCM slot_name
, SCM value
),
1440 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1441 #define FUNC_NAME s_scm_slot_set_x
1445 SCM_VALIDATE_INSTANCE (1, obj
);
1446 TEST_CHANGE_CLASS(obj
, class);
1448 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1452 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1454 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1455 (SCM obj
, SCM slot_name
),
1456 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1458 #define FUNC_NAME s_scm_slot_bound_p
1462 SCM_VALIDATE_INSTANCE (1, obj
);
1463 TEST_CHANGE_CLASS(obj
, class);
1465 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1473 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1474 (SCM obj
, SCM slot_name
),
1475 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1476 #define FUNC_NAME s_scm_slot_exists_p
1480 SCM_VALIDATE_INSTANCE (1, obj
);
1481 SCM_VALIDATE_SYMBOL (2, slot_name
);
1482 TEST_CHANGE_CLASS (obj
, class);
1484 return test_slot_existence (class, obj
, slot_name
);
1489 /******************************************************************************
1491 * %allocate-instance (the low level instance allocation primitive)
1493 ******************************************************************************/
1495 static void clear_method_cache (SCM
);
1498 wrap_init (SCM
class, SCM
*m
, long n
)
1502 /* Set all slots to unbound */
1503 for (i
= 0; i
< n
; i
++)
1504 m
[i
] = SCM_GOOPS_UNBOUND
;
1506 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1508 (scm_t_bits
) m
, 0, 0);
1511 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1512 (SCM
class, SCM initargs
),
1513 "Create a new instance of class @var{class} and initialize it\n"
1514 "from the arguments @var{initargs}.")
1515 #define FUNC_NAME s_scm_sys_allocate_instance
1520 SCM_VALIDATE_CLASS (1, class);
1522 /* Most instances */
1523 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1525 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1526 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1527 return wrap_init (class, m
, n
);
1530 /* Foreign objects */
1531 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1532 return scm_make_foreign_object (class, initargs
);
1534 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1537 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1539 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1541 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1542 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1543 /* Generic functions */
1544 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1546 SCM gf
= wrap_init (class, m
, n
);
1547 clear_method_cache (gf
);
1551 return wrap_init (class, m
, n
);
1555 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1559 /* allocate class object */
1560 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1562 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1563 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1564 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1566 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1567 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1568 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1569 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1574 /* Non-light instances */
1576 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1577 return wrap_init (class, m
, n
);
1582 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1583 (SCM obj
, SCM setter
),
1585 #define FUNC_NAME s_scm_sys_set_object_setter_x
1587 SCM_ASSERT (SCM_STRUCTP (obj
)
1588 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1589 || SCM_I_ENTITYP (obj
)),
1593 if (SCM_I_ENTITYP (obj
))
1594 SCM_SET_ENTITY_SETTER (obj
, setter
);
1596 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1597 return SCM_UNSPECIFIED
;
1601 /******************************************************************************
1603 * %modify-instance (used by change-class to modify in place)
1605 ******************************************************************************/
1607 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1610 #define FUNC_NAME s_scm_sys_modify_instance
1612 SCM_VALIDATE_INSTANCE (1, old
);
1613 SCM_VALIDATE_INSTANCE (2, new);
1615 /* Exchange the data contained in old and new. We exchange rather than
1616 * scratch the old value with new to be correct with GC.
1617 * See "Class redefinition protocol above".
1619 SCM_CRITICAL_SECTION_START
;
1621 SCM car
= SCM_CAR (old
);
1622 SCM cdr
= SCM_CDR (old
);
1623 SCM_SETCAR (old
, SCM_CAR (new));
1624 SCM_SETCDR (old
, SCM_CDR (new));
1625 SCM_SETCAR (new, car
);
1626 SCM_SETCDR (new, cdr
);
1628 SCM_CRITICAL_SECTION_END
;
1629 return SCM_UNSPECIFIED
;
1633 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1636 #define FUNC_NAME s_scm_sys_modify_class
1638 SCM_VALIDATE_CLASS (1, old
);
1639 SCM_VALIDATE_CLASS (2, new);
1641 SCM_CRITICAL_SECTION_START
;
1643 SCM car
= SCM_CAR (old
);
1644 SCM cdr
= SCM_CDR (old
);
1645 SCM_SETCAR (old
, SCM_CAR (new));
1646 SCM_SETCDR (old
, SCM_CDR (new));
1647 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1648 SCM_SETCAR (new, car
);
1649 SCM_SETCDR (new, cdr
);
1650 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1652 SCM_CRITICAL_SECTION_END
;
1653 return SCM_UNSPECIFIED
;
1657 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1660 #define FUNC_NAME s_scm_sys_invalidate_class
1662 SCM_VALIDATE_CLASS (1, class);
1663 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1664 return SCM_UNSPECIFIED
;
1668 /* When instances change class, they finally get a new body, but
1669 * before that, they go through purgatory in hell. Odd as it may
1670 * seem, this data structure saves us from eternal suffering in
1671 * infinite recursions.
1674 static scm_t_bits
**hell
;
1675 static long n_hell
= 1; /* one place for the evil one himself */
1676 static long hell_size
= 4;
1677 static SCM hell_mutex
;
1683 for (i
= 1; i
< n_hell
; ++i
)
1684 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1690 go_to_hell (void *o
)
1692 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1693 scm_lock_mutex (hell_mutex
);
1694 if (n_hell
== hell_size
)
1696 long new_size
= 2 * hell_size
;
1697 hell
= scm_realloc (hell
, new_size
);
1698 hell_size
= new_size
;
1700 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1701 scm_unlock_mutex (hell_mutex
);
1705 go_to_heaven (void *o
)
1707 scm_lock_mutex (hell_mutex
);
1708 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1709 scm_unlock_mutex (hell_mutex
);
1713 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1716 purgatory (void *args
)
1718 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1719 SCM_PACK ((scm_t_bits
) args
));
1722 /* This function calls the generic function change-class for all
1723 * instances which aren't currently undergoing class change.
1727 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1730 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1731 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1732 (void *) SCM_UNPACK (obj
));
1735 /******************************************************************************
1741 * GGG E N E R I C F U N C T I O N S
1743 * This implementation provides
1744 * - generic functions (with class specializers)
1747 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1749 ******************************************************************************/
1751 SCM_KEYWORD (k_name
, "name");
1753 SCM_SYMBOL (sym_no_method
, "no-method");
1755 static SCM list_of_no_method
;
1757 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1761 scm_make_method_cache (SCM gf
)
1763 return scm_list_5 (SCM_IM_DISPATCH
,
1766 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1772 clear_method_cache (SCM gf
)
1774 SCM cache
= scm_make_method_cache (gf
);
1775 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1776 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1779 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1782 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1785 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1786 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1787 if (scm_is_true (used_by
))
1789 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1790 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1791 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1792 clear_method_cache (gf
);
1793 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1794 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1797 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1798 /* The sign of n is a flag indicating rest args. */
1799 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1801 return SCM_UNSPECIFIED
;
1805 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1808 #define FUNC_NAME s_scm_generic_capability_p
1810 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1811 proc
, SCM_ARG1
, FUNC_NAME
);
1812 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1818 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1821 #define FUNC_NAME s_scm_enable_primitive_generic_x
1823 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1824 while (!scm_is_null (subrs
))
1826 SCM subr
= SCM_CAR (subrs
);
1827 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1828 subr
, SCM_ARGn
, FUNC_NAME
);
1829 *SCM_SUBR_GENERIC (subr
)
1830 = scm_make (scm_list_3 (scm_class_generic
,
1833 subrs
= SCM_CDR (subrs
);
1835 return SCM_UNSPECIFIED
;
1839 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1842 #define FUNC_NAME s_scm_primitive_generic_generic
1844 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1846 if (!*SCM_SUBR_GENERIC (subr
))
1847 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1848 return *SCM_SUBR_GENERIC (subr
);
1850 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1854 typedef struct t_extension
{
1855 struct t_extension
*next
;
1860 static t_extension
*extensions
= 0;
1862 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1865 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1870 if (!*SCM_SUBR_GENERIC (extended
))
1871 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1872 gf
= *SCM_SUBR_GENERIC (extended
);
1873 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1875 SCM_SNAME (extension
));
1876 *SCM_SUBR_GENERIC (extension
) = gext
;
1880 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1881 t_extension
**loc
= &extensions
;
1882 /* Make sure that extensions are placed before their own
1883 * extensions in the extensions list. O(N^2) algorithm, but
1884 * extensions of primitive generics are rare.
1886 while (*loc
&& extension
!= (*loc
)->extended
)
1887 loc
= &(*loc
)->next
;
1889 e
->extended
= extended
;
1890 e
->extension
= extension
;
1896 setup_extended_primitive_generics ()
1900 t_extension
*e
= extensions
;
1901 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1902 extensions
= e
->next
;
1907 /******************************************************************************
1909 * Protocol for calling a generic fumction
1910 * This protocol is roughly equivalent to (parameter are a little bit different
1911 * for efficiency reasons):
1913 * + apply-generic (gf args)
1914 * + compute-applicable-methods (gf args ...)
1915 * + sort-applicable-methods (methods args)
1916 * + apply-methods (gf methods args)
1918 * apply-methods calls make-next-method to build the "continuation" of a a
1919 * method. Applying a next-method will call apply-next-method which in
1920 * turn will call apply again to call effectively the following method.
1922 ******************************************************************************/
1925 applicablep (SCM actual
, SCM formal
)
1927 /* We already know that the cpl is well formed. */
1928 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1932 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1934 register SCM s1
, s2
;
1938 * m1 and m2 can have != length (i.e. one can be one element longer than the
1939 * other when we have a dotted parameter list). For instance, with the call
1942 * (define-method M (a . l) ....)
1943 * (define-method M (a) ....)
1945 * we consider that the second method is more specific.
1947 * BTW, targs is an array of types. We don't need it's size since
1948 * we already know that m1 and m2 are applicable (no risk to go past
1949 * the end of this array).
1952 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1953 if (scm_is_null(s1
)) return 1;
1954 if (scm_is_null(s2
)) return 0;
1955 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1956 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1958 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1959 if (cs1
== SCM_CAR(l
))
1961 if (cs2
== SCM_CAR(l
))
1964 return 0;/* should not occur! */
1967 return 0; /* should not occur! */
1970 #define BUFFSIZE 32 /* big enough for most uses */
1973 scm_i_vector2list (SCM l
, long len
)
1976 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1978 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1979 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1985 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1988 SCM
*v
, vector
= SCM_EOL
;
1989 SCM buffer
[BUFFSIZE
];
1990 SCM save
= method_list
;
1991 scm_t_array_handle handle
;
1993 /* For reasonably sized method_lists we can try to avoid all the
1994 * consing and reorder the list in place...
1995 * This idea is due to David McClain <Dave_McClain@msn.com>
1997 if (size
<= BUFFSIZE
)
1999 for (i
= 0; i
< size
; i
++)
2001 buffer
[i
] = SCM_CAR (method_list
);
2002 method_list
= SCM_CDR (method_list
);
2008 /* Too many elements in method_list to keep everything locally */
2009 vector
= scm_i_vector2list (save
, size
);
2010 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2013 /* Use a simple shell sort since it is generally faster than qsort on
2014 * small vectors (which is probably mostly the case when we have to
2015 * sort a list of applicable methods).
2017 for (incr
= size
/ 2; incr
; incr
/= 2)
2019 for (i
= incr
; i
< size
; i
++)
2021 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2023 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2027 SCM tmp
= v
[j
+ incr
];
2035 if (size
<= BUFFSIZE
)
2037 /* We did it in locally, so restore the original list (reordered) in-place */
2038 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2040 SCM_SETCAR (method_list
, *v
);
2041 method_list
= SCM_CDR (method_list
);
2046 /* If we are here, that's that we did it the hard way... */
2047 scm_array_handle_release (&handle
);
2048 return scm_vector_to_list (vector
);
2052 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2056 SCM l
, fl
, applicable
= SCM_EOL
;
2058 SCM buffer
[BUFFSIZE
];
2062 scm_t_array_handle handle
;
2064 /* Build the list of arguments types */
2065 if (len
>= BUFFSIZE
)
2067 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2068 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2071 note that we don't have to work to reset the generation
2072 count. TMP is a new vector anyway, and it is found
2079 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2080 *p
++ = scm_class_of (SCM_CAR (args
));
2082 /* Build a list of all applicable methods */
2083 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2085 fl
= SPEC_OF (SCM_CAR (l
));
2086 /* Only accept accessors which match exactly in first arg. */
2087 if (SCM_ACCESSORP (SCM_CAR (l
))
2088 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2090 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2092 if (SCM_INSTANCEP (fl
)
2093 /* We have a dotted argument list */
2094 || (i
>= len
&& scm_is_null (fl
)))
2095 { /* both list exhausted */
2096 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2102 || !applicablep (types
[i
], SCM_CAR (fl
)))
2107 if (len
>= BUFFSIZE
)
2108 scm_array_handle_release (&handle
);
2114 CALL_GF2 ("no-applicable-method", gf
, save
);
2115 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2121 : sort_applicable_methods (applicable
, count
, types
));
2125 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2128 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2131 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2132 #define FUNC_NAME s_sys_compute_applicable_methods
2135 SCM_VALIDATE_GENERIC (1, gf
);
2136 n
= scm_ilength (args
);
2137 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2138 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2142 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2143 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
));
2146 lock_cache_mutex (void *m
)
2148 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2149 scm_lock_mutex (mutex
);
2153 unlock_cache_mutex (void *m
)
2155 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2156 scm_unlock_mutex (mutex
);
2160 call_memoize_method (void *a
)
2162 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2163 SCM gf
= SCM_CAR (args
);
2164 SCM x
= SCM_CADR (args
);
2165 /* First check if another thread has inserted a method between
2166 * the cache miss and locking the mutex.
2168 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2169 if (scm_is_true (cmethod
))
2171 /*fixme* Use scm_apply */
2172 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2176 scm_memoize_method (SCM x
, SCM args
)
2178 SCM gf
= SCM_CAR (scm_last_pair (x
));
2179 return scm_internal_dynamic_wind (
2181 call_memoize_method
,
2183 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2184 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2187 /******************************************************************************
2189 * A simple make (which will be redefined later in Scheme)
2190 * This version handles only creation of gf, methods and classes (no instances)
2192 * Since this code will disappear when Goops will be fully booted,
2193 * no precaution is taken to be efficient.
2195 ******************************************************************************/
2197 SCM_KEYWORD (k_setter
, "setter");
2198 SCM_KEYWORD (k_specializers
, "specializers");
2199 SCM_KEYWORD (k_procedure
, "procedure");
2200 SCM_KEYWORD (k_dsupers
, "dsupers");
2201 SCM_KEYWORD (k_slots
, "slots");
2202 SCM_KEYWORD (k_gf
, "generic-function");
2204 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2206 "Make a new object. @var{args} must contain the class and\n"
2207 "all necessary initialization information.")
2208 #define FUNC_NAME s_scm_make
2211 long len
= scm_ilength (args
);
2213 if (len
<= 0 || (len
& 1) == 0)
2214 SCM_WRONG_NUM_ARGS ();
2216 class = SCM_CAR(args
);
2217 args
= SCM_CDR(args
);
2219 if (class == scm_class_generic
|| class == scm_class_accessor
)
2221 z
= scm_make_struct (class, SCM_INUM0
,
2222 scm_list_5 (SCM_EOL
,
2227 scm_set_procedure_property_x (z
, scm_sym_name
,
2228 scm_get_keyword (k_name
,
2231 clear_method_cache (z
);
2232 if (class == scm_class_accessor
)
2234 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2235 if (scm_is_true (setter
))
2236 scm_sys_set_object_setter_x (z
, setter
);
2241 z
= scm_sys_allocate_instance (class, args
);
2243 if (class == scm_class_method
2244 || class == scm_class_simple_method
2245 || class == scm_class_accessor_method
)
2247 SCM_SET_SLOT (z
, scm_si_generic_function
,
2248 scm_i_get_keyword (k_gf
,
2253 SCM_SET_SLOT (z
, scm_si_specializers
,
2254 scm_i_get_keyword (k_specializers
,
2259 SCM_SET_SLOT (z
, scm_si_procedure
,
2260 scm_i_get_keyword (k_procedure
,
2265 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2269 /* In all the others case, make a new class .... No instance here */
2270 SCM_SET_SLOT (z
, scm_si_name
,
2271 scm_i_get_keyword (k_name
,
2274 scm_from_locale_symbol ("???"),
2276 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2277 scm_i_get_keyword (k_dsupers
,
2282 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2283 scm_i_get_keyword (k_slots
,
2294 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2297 #define FUNC_NAME s_scm_find_method
2300 long len
= scm_ilength (l
);
2303 SCM_WRONG_NUM_ARGS ();
2305 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2306 SCM_VALIDATE_GENERIC (1, gf
);
2307 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2308 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2310 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2314 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2315 (SCM m1
, SCM m2
, SCM targs
),
2316 "Return true if method @var{m1} is more specific than @var{m2} "
2317 "given the argument types (classes) listed in @var{targs}.")
2318 #define FUNC_NAME s_scm_sys_method_more_specific_p
2322 long i
, len
, m1_specs
, m2_specs
;
2323 scm_t_array_handle handle
;
2325 SCM_VALIDATE_METHOD (1, m1
);
2326 SCM_VALIDATE_METHOD (2, m2
);
2328 len
= scm_ilength (targs
);
2329 m1_specs
= scm_ilength (SPEC_OF (m1
));
2330 m2_specs
= scm_ilength (SPEC_OF (m2
));
2331 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2332 targs
, SCM_ARG3
, FUNC_NAME
);
2334 /* Verify that all the arguments of TARGS are classes and place them
2337 v
= scm_c_make_vector (len
, SCM_EOL
);
2338 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2340 for (i
= 0, l
= targs
;
2341 i
< len
&& scm_is_pair (l
);
2342 i
++, l
= SCM_CDR (l
))
2344 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2345 v_elts
[i
] = SCM_CAR (l
);
2347 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2349 scm_array_handle_release (&handle
);
2357 /******************************************************************************
2361 ******************************************************************************/
2364 fix_cpl (SCM c
, SCM before
, SCM after
)
2366 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2367 SCM ls
= scm_c_memq (after
, cpl
);
2368 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2369 if (scm_is_false (ls
))
2370 /* if this condition occurs, fix_cpl should not be applied this way */
2372 SCM_SETCAR (ls
, before
);
2373 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2375 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2376 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2377 SCM g_n_s
= compute_getters_n_setters (slots
);
2378 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2379 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2385 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2387 SCM tmp
= scm_from_locale_symbol (name
);
2389 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2393 : scm_list_1 (super
),
2399 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2402 create_standard_classes (void)
2405 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2406 scm_from_locale_symbol ("specializers"),
2408 scm_from_locale_symbol ("code-table"));
2409 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2411 k_slot_definition
));
2412 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2413 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2417 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2418 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2421 scm_list_3 (scm_from_locale_symbol ("used-by"),
2424 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2427 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2430 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2433 /* Foreign class slot classes */
2434 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2435 scm_class_class
, scm_class_top
, SCM_EOL
);
2436 make_stdcls (&scm_class_protected
, "<protected-slot>",
2437 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2438 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2439 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2440 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2441 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2442 make_stdcls (&scm_class_self
, "<self-slot>",
2444 scm_class_read_only
,
2446 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2448 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2450 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2452 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2454 make_stdcls (&scm_class_scm
, "<scm-slot>",
2455 scm_class_class
, scm_class_protected
, SCM_EOL
);
2456 make_stdcls (&scm_class_int
, "<int-slot>",
2457 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2458 make_stdcls (&scm_class_float
, "<float-slot>",
2459 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2460 make_stdcls (&scm_class_double
, "<double-slot>",
2461 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2463 /* Continue initialization of class <class> */
2465 slots
= build_class_class_slots ();
2466 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2467 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2468 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2469 compute_getters_n_setters (slots
));
2471 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2472 scm_class_class
, scm_class_class
,
2473 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2476 scm_list_3 (scm_from_locale_symbol ("destructor"),
2478 scm_class_opaque
)));
2479 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2480 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2481 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2483 /* scm_class_generic functions classes */
2484 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2485 scm_class_class
, scm_class_class
, SCM_EOL
);
2486 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2487 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2488 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2489 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2490 make_stdcls (&scm_class_operator_with_setter_class
,
2491 "<operator-with-setter-class>",
2492 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2493 make_stdcls (&scm_class_method
, "<method>",
2494 scm_class_class
, scm_class_object
, method_slots
);
2495 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2496 scm_class_class
, scm_class_method
, SCM_EOL
);
2497 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2498 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2499 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2500 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2501 make_stdcls (&scm_class_applicable
, "<applicable>",
2502 scm_class_class
, scm_class_top
, SCM_EOL
);
2503 make_stdcls (&scm_class_entity
, "<entity>",
2504 scm_class_entity_class
,
2505 scm_list_2 (scm_class_object
, scm_class_applicable
),
2507 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2508 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2509 make_stdcls (&scm_class_generic
, "<generic>",
2510 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2511 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2512 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2513 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2514 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2515 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2516 scm_class_entity_class
,
2517 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2519 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2520 make_stdcls (&scm_class_accessor
, "<accessor>",
2521 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2522 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2523 make_stdcls (&scm_class_extended_generic_with_setter
,
2524 "<extended-generic-with-setter>",
2525 scm_class_entity_class
,
2526 scm_list_2 (scm_class_generic_with_setter
,
2527 scm_class_extended_generic
),
2529 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2530 SCM_CLASSF_PURE_GENERIC
);
2531 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2532 scm_class_entity_class
,
2533 scm_list_2 (scm_class_accessor
,
2534 scm_class_extended_generic_with_setter
),
2536 fix_cpl (scm_class_extended_accessor
,
2537 scm_class_extended_generic
, scm_class_generic
);
2538 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2540 /* Primitive types classes */
2541 make_stdcls (&scm_class_boolean
, "<boolean>",
2542 scm_class_class
, scm_class_top
, SCM_EOL
);
2543 make_stdcls (&scm_class_char
, "<char>",
2544 scm_class_class
, scm_class_top
, SCM_EOL
);
2545 make_stdcls (&scm_class_list
, "<list>",
2546 scm_class_class
, scm_class_top
, SCM_EOL
);
2547 make_stdcls (&scm_class_pair
, "<pair>",
2548 scm_class_class
, scm_class_list
, SCM_EOL
);
2549 make_stdcls (&scm_class_null
, "<null>",
2550 scm_class_class
, scm_class_list
, SCM_EOL
);
2551 make_stdcls (&scm_class_string
, "<string>",
2552 scm_class_class
, scm_class_top
, SCM_EOL
);
2553 make_stdcls (&scm_class_symbol
, "<symbol>",
2554 scm_class_class
, scm_class_top
, SCM_EOL
);
2555 make_stdcls (&scm_class_vector
, "<vector>",
2556 scm_class_class
, scm_class_top
, SCM_EOL
);
2557 make_stdcls (&scm_class_number
, "<number>",
2558 scm_class_class
, scm_class_top
, SCM_EOL
);
2559 make_stdcls (&scm_class_complex
, "<complex>",
2560 scm_class_class
, scm_class_number
, SCM_EOL
);
2561 make_stdcls (&scm_class_real
, "<real>",
2562 scm_class_class
, scm_class_complex
, SCM_EOL
);
2563 make_stdcls (&scm_class_integer
, "<integer>",
2564 scm_class_class
, scm_class_real
, SCM_EOL
);
2565 make_stdcls (&scm_class_fraction
, "<fraction>",
2566 scm_class_class
, scm_class_real
, SCM_EOL
);
2567 make_stdcls (&scm_class_keyword
, "<keyword>",
2568 scm_class_class
, scm_class_top
, SCM_EOL
);
2569 make_stdcls (&scm_class_unknown
, "<unknown>",
2570 scm_class_class
, scm_class_top
, SCM_EOL
);
2571 make_stdcls (&scm_class_procedure
, "<procedure>",
2572 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2573 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2574 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2575 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2576 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2577 make_stdcls (&scm_class_port
, "<port>",
2578 scm_class_class
, scm_class_top
, SCM_EOL
);
2579 make_stdcls (&scm_class_input_port
, "<input-port>",
2580 scm_class_class
, scm_class_port
, SCM_EOL
);
2581 make_stdcls (&scm_class_output_port
, "<output-port>",
2582 scm_class_class
, scm_class_port
, SCM_EOL
);
2583 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2585 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2589 /**********************************************************************
2593 **********************************************************************/
2596 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2602 sprintf (buffer
, template, type_name
);
2603 name
= scm_from_locale_symbol (buffer
);
2606 name
= SCM_GOOPS_UNBOUND
;
2608 class = scm_permanent_object (scm_basic_make_class (applicablep
2609 ? scm_class_procedure_class
2615 /* Only define name if doesn't already exist. */
2616 if (!SCM_GOOPS_UNBOUNDP (name
)
2617 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2618 DEFVAR (name
, class);
2623 scm_make_extended_class (char const *type_name
, int applicablep
)
2625 return make_class_from_template ("<%s>",
2627 scm_list_1 (applicablep
2628 ? scm_class_applicable
2634 scm_i_inherit_applicable (SCM c
)
2636 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2638 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2639 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2640 /* patch scm_class_applicable into direct-supers */
2641 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2642 if (scm_is_false (top
))
2643 dsupers
= scm_append (scm_list_2 (dsupers
,
2644 scm_list_1 (scm_class_applicable
)));
2647 SCM_SETCAR (top
, scm_class_applicable
);
2648 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2650 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2651 /* patch scm_class_applicable into cpl */
2652 top
= scm_c_memq (scm_class_top
, cpl
);
2653 if (scm_is_false (top
))
2657 SCM_SETCAR (top
, scm_class_applicable
);
2658 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2660 /* add class to direct-subclasses of scm_class_applicable */
2661 SCM_SET_SLOT (scm_class_applicable
,
2662 scm_si_direct_subclasses
,
2663 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2664 scm_si_direct_subclasses
)));
2669 create_smob_classes (void)
2673 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2674 for (i
= 0; i
< 255; ++i
)
2675 scm_smob_class
[i
] = 0;
2677 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2679 for (i
= 0; i
< scm_numsmob
; ++i
)
2680 if (!scm_smob_class
[i
])
2681 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2682 scm_smobs
[i
].apply
!= 0);
2686 scm_make_port_classes (long ptobnum
, char *type_name
)
2688 SCM c
, class = make_class_from_template ("<%s-port>",
2690 scm_list_1 (scm_class_port
),
2692 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2693 = make_class_from_template ("<%s-input-port>",
2695 scm_list_2 (class, scm_class_input_port
),
2697 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2698 = make_class_from_template ("<%s-output-port>",
2700 scm_list_2 (class, scm_class_output_port
),
2702 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2704 = make_class_from_template ("<%s-input-output-port>",
2706 scm_list_2 (class, scm_class_input_output_port
),
2708 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2709 SCM_SET_SLOT (c
, scm_si_cpl
,
2710 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2714 create_port_classes (void)
2718 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2719 for (i
= 0; i
< 3 * 256; ++i
)
2720 scm_port_class
[i
] = 0;
2722 for (i
= 0; i
< scm_numptob
; ++i
)
2723 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2727 make_struct_class (void *closure SCM_UNUSED
,
2728 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2730 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2731 SCM_SET_STRUCT_TABLE_CLASS (data
,
2732 scm_make_extended_class
2733 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2734 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2735 return SCM_UNSPECIFIED
;
2739 create_struct_classes (void)
2741 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2744 /**********************************************************************
2748 **********************************************************************/
2753 if (!goops_loaded_p
)
2754 scm_c_resolve_module ("oop goops");
2759 scm_make_foreign_object (SCM
class, SCM initargs
)
2760 #define FUNC_NAME s_scm_make
2762 void * (*constructor
) (SCM
)
2763 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2764 if (constructor
== 0)
2765 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2766 return scm_wrap_object (class, constructor (initargs
));
2772 scm_free_foreign_object (SCM
*class, SCM
*data
)
2774 size_t (*destructor
) (void *)
2775 = (size_t (*) (void *)) class[scm_si_destructor
];
2776 return destructor (data
);
2780 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2781 void * (*constructor
) (SCM initargs
),
2782 size_t (*destructor
) (void *))
2785 name
= scm_from_locale_symbol (s_name
);
2786 if (scm_is_null (supers
))
2787 supers
= scm_list_1 (scm_class_foreign_object
);
2788 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2789 scm_sys_inherit_magic_x (class, supers
);
2791 if (destructor
!= 0)
2793 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2794 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2798 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2801 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2802 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2807 SCM_SYMBOL (sym_o
, "o");
2808 SCM_SYMBOL (sym_x
, "x");
2810 SCM_KEYWORD (k_accessor
, "accessor");
2811 SCM_KEYWORD (k_getter
, "getter");
2814 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2816 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2821 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2822 SCM (*getter
) (SCM obj
),
2823 SCM (*setter
) (SCM obj
, SCM x
),
2824 char *accessor_name
)
2827 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2828 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2829 setter
? setter
: default_setter
);
2831 /* Dirk:FIXME:: The following two expressions make use of the fact that
2832 * the memoizer will accept a subr-object in the place of a function.
2833 * This is not guaranteed to stay this way. */
2834 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2836 scm_list_2 (get
, sym_o
)),
2838 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2839 scm_list_2 (sym_o
, sym_x
),
2840 scm_list_3 (set
, sym_o
, sym_x
)),
2844 SCM name
= scm_from_locale_symbol (slot_name
);
2845 SCM aname
= scm_from_locale_symbol (accessor_name
);
2846 SCM gf
= scm_ensure_accessor (aname
);
2847 SCM slot
= scm_list_5 (name
,
2850 setter
? k_accessor
: k_getter
,
2852 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2857 scm_add_method (scm_setter (gf
),
2858 scm_make (scm_list_5 (scm_class_accessor_method
,
2860 scm_list_2 (class, scm_class_top
),
2865 SCM_SET_SLOT (class, scm_si_slots
,
2866 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2867 scm_list_1 (slot
))));
2869 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2870 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1));
2871 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2872 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2873 scm_list_1 (gns
))));
2874 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2881 scm_wrap_object (SCM
class, void *data
)
2883 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2891 scm_wrap_component (SCM
class, SCM container
, void *data
)
2893 SCM obj
= scm_wrap_object (class, data
);
2894 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2900 SCM_SETCDR (handle
, container
);
2905 scm_ensure_accessor (SCM name
)
2907 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2908 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2910 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2911 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2912 k_name
, name
, k_setter
, gf
));
2917 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2920 scm_add_method (SCM gf
, SCM m
)
2922 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2927 * Debugging utilities
2930 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2932 "Return @code{#t} if @var{obj} is a pure generic.")
2933 #define FUNC_NAME s_scm_pure_generic_p
2935 return scm_from_bool (SCM_PUREGENERICP (obj
));
2939 #endif /* GUILE_DEBUG */
2945 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2947 "Announce that GOOPS is loaded and perform initialization\n"
2948 "on the C level which depends on the loaded GOOPS modules.")
2949 #define FUNC_NAME s_scm_sys_goops_loaded
2952 var_compute_applicable_methods
=
2953 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2955 setup_extended_primitive_generics ();
2956 return SCM_UNSPECIFIED
;
2960 SCM scm_module_goops
;
2963 scm_init_goops_builtins (void)
2965 scm_module_goops
= scm_current_module ();
2966 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2968 /* Not really necessary right now, but who knows...
2970 scm_permanent_object (scm_module_goops
);
2971 scm_permanent_object (scm_goops_lookup_closure
);
2973 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2974 (scm_from_int (37)));
2976 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2978 #include "libguile/goops.x"
2980 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2982 hell
= scm_malloc (hell_size
);
2983 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2985 create_basic_classes ();
2986 create_standard_classes ();
2987 create_smob_classes ();
2988 create_struct_classes ();
2989 create_port_classes ();
2992 SCM name
= scm_from_locale_symbol ("no-applicable-method");
2993 scm_no_applicable_method
2994 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2997 DEFVAR (name
, scm_no_applicable_method
);
3000 return SCM_UNSPECIFIED
;
3006 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3007 scm_init_goops_builtins
);