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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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/debug.h"
32 #include "libguile/dynl.h"
33 #include "libguile/dynwind.h"
34 #include "libguile/eval.h"
35 #include "libguile/hashtab.h"
36 #include "libguile/keywords.h"
37 #include "libguile/macros.h"
38 #include "libguile/modules.h"
39 #include "libguile/objects.h"
40 #include "libguile/ports.h"
41 #include "libguile/procprop.h"
42 #include "libguile/random.h"
43 #include "libguile/root.h"
44 #include "libguile/smob.h"
45 #include "libguile/strings.h"
46 #include "libguile/strports.h"
47 #include "libguile/vectors.h"
48 #include "libguile/weaks.h"
50 #include "libguile/validate.h"
51 #include "libguile/goops.h"
53 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
55 #define DEFVAR(v, val) \
56 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
58 /* Temporary hack until we get the new module system */
59 /*fixme* Should optimize by keeping track of the variable object itself */
60 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
63 /* Fixme: Should use already interned symbols */
65 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
67 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
69 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
71 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
74 /* Class redefinition protocol:
76 A class is represented by a heap header h1 which points to a
77 malloc:ed memory block m1.
79 When a new version of a class is created, a new header h2 and
80 memory block m2 are allocated. The headers h1 and h2 then switch
81 pointers so that h1 refers to m2 and h2 to m1. In this way, names
82 bound to h1 will point to the new class at the same time as h2 will
83 be a handle which the GC will us to free m1.
85 The `redefined' slot of m1 will be set to point to h1. An old
86 instance will have it's class pointer (the CAR of the heap header)
87 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
88 the class modification and the new class pointer can be found via
92 /* The following definition is located in libguile/objects.h:
93 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
96 #define TEST_CHANGE_CLASS(obj, class) \
98 class = SCM_CLASS_OF (obj); \
99 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
101 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
102 class = SCM_CLASS_OF (obj); \
106 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
107 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
109 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
110 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
112 static int goops_loaded_p
= 0;
113 static scm_t_rstate
*goops_rstate
;
115 static SCM scm_goops_lookup_closure
;
117 /* Some classes are defined in libguile/objects.c. */
118 SCM scm_class_top
, scm_class_object
, scm_class_class
;
119 SCM scm_class_applicable
;
120 SCM scm_class_entity
, scm_class_entity_with_setter
;
121 SCM scm_class_generic
, scm_class_generic_with_setter
;
122 SCM scm_class_accessor
;
123 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
124 SCM scm_class_extended_accessor
;
125 SCM scm_class_method
;
126 SCM scm_class_simple_method
, scm_class_accessor_method
;
127 SCM scm_class_procedure_class
;
128 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
129 SCM scm_class_entity_class
;
130 SCM scm_class_number
, scm_class_list
;
131 SCM scm_class_keyword
;
132 SCM scm_class_port
, scm_class_input_output_port
;
133 SCM scm_class_input_port
, scm_class_output_port
;
134 SCM scm_class_foreign_class
, scm_class_foreign_object
;
135 SCM scm_class_foreign_slot
;
136 SCM scm_class_self
, scm_class_protected
;
137 SCM scm_class_opaque
, scm_class_read_only
;
138 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
140 SCM scm_class_int
, scm_class_float
, scm_class_double
;
142 SCM_SYMBOL (scm_sym_define_public
, "define-public");
144 static SCM
scm_make_unbound (void);
145 static SCM
scm_unbound_p (SCM obj
);
146 static SCM
scm_assert_bound (SCM value
, SCM obj
);
147 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
148 static SCM
scm_sys_goops_loaded (void);
150 /******************************************************************************
154 * This version doesn't fully handle multiple-inheritance. It serves
155 * only for booting classes and will be overloaded in Scheme
157 ******************************************************************************/
160 map (SCM (*proc
) (SCM
), SCM ls
)
162 if (scm_is_null (ls
))
166 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
169 while (!scm_is_null (ls
))
171 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
183 while (!scm_is_null (ls
))
185 SCM el
= SCM_CAR (ls
);
186 if (scm_is_false (scm_c_memq (el
, res
)))
187 res
= scm_cons (el
, res
);
194 compute_cpl (SCM
class)
197 return CALL_GF1 ("compute-cpl", class);
200 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
201 SCM ls
= scm_append (scm_acons (class, supers
,
202 map (compute_cpl
, supers
)));
203 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
207 /******************************************************************************
211 ******************************************************************************/
214 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
222 if (!scm_is_symbol (tmp
))
223 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
225 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
226 res
= scm_cons (SCM_CAR (l
), res
);
227 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
230 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
234 build_slots_list (SCM dslots
, SCM cpl
)
236 register SCM res
= dslots
;
238 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
239 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
240 scm_si_direct_slots
),
243 /* res contains a list of slots. Remove slots which appears more than once */
244 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
251 while (!scm_is_null (ls
))
253 if (!scm_is_pair (SCM_CAR (ls
)))
254 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
261 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
263 "Return a list consisting of the names of all slots belonging to\n"
264 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
266 #define FUNC_NAME s_scm_sys_compute_slots
268 SCM_VALIDATE_CLASS (1, class);
269 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
270 SCM_SLOT (class, scm_si_cpl
));
275 /******************************************************************************
277 * compute-getters-n-setters
279 * This version doesn't handle slot options. It serves only for booting
280 * classes and will be overloaded in Scheme.
282 ******************************************************************************/
284 SCM_KEYWORD (k_init_value
, "init-value");
285 SCM_KEYWORD (k_init_thunk
, "init-thunk");
288 compute_getters_n_setters (SCM slots
)
294 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
296 SCM init
= SCM_BOOL_F
;
297 SCM options
= SCM_CDAR (slots
);
298 if (!scm_is_null (options
))
300 init
= scm_get_keyword (k_init_value
, options
, 0);
303 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
305 scm_list_2 (scm_sym_quote
,
310 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
312 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
314 scm_from_int (i
++))),
316 cdrloc
= SCM_CDRLOC (*cdrloc
);
321 /******************************************************************************
325 ******************************************************************************/
327 /*fixme* Manufacture keywords in advance */
329 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
333 for (i
= 0; i
!= len
; i
+= 2)
335 SCM obj
= SCM_CAR (l
);
337 if (!SCM_KEYWORDP (obj
))
338 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
339 else if (scm_is_eq (obj
, key
))
345 return default_value
;
349 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
350 (SCM key
, SCM l
, SCM default_value
),
351 "Determine an associated value for the keyword @var{key} from\n"
352 "the list @var{l}. The list @var{l} has to consist of an even\n"
353 "number of elements, where, starting with the first, every\n"
354 "second element is a keyword, followed by its associated value.\n"
355 "If @var{l} does not hold a value for @var{key}, the value\n"
356 "@var{default_value} is returned.")
357 #define FUNC_NAME s_scm_get_keyword
361 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
362 len
= scm_ilength (l
);
363 if (len
< 0 || len
% 2 == 1)
364 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
366 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
371 SCM_KEYWORD (k_init_keyword
, "init-keyword");
373 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
374 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
376 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
377 (SCM obj
, SCM initargs
),
378 "Initialize the object @var{obj} with the given arguments\n"
380 #define FUNC_NAME s_scm_sys_initialize_object
382 SCM tmp
, get_n_set
, slots
;
383 SCM
class = SCM_CLASS_OF (obj
);
386 SCM_VALIDATE_INSTANCE (1, obj
);
387 n_initargs
= scm_ilength (initargs
);
388 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
390 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
391 slots
= SCM_SLOT (class, scm_si_slots
);
393 /* See for each slot how it must be initialized */
395 !scm_is_null (slots
);
396 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
398 SCM slot_name
= SCM_CAR (slots
);
401 if (!scm_is_null (SCM_CDR (slot_name
)))
403 /* This slot admits (perhaps) to be initialized at creation time */
404 long n
= scm_ilength (SCM_CDR (slot_name
));
405 if (n
& 1) /* odd or -1 */
406 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
407 scm_list_1 (slot_name
));
408 tmp
= scm_i_get_keyword (k_init_keyword
,
413 slot_name
= SCM_CAR (slot_name
);
416 /* an initarg was provided for this slot */
417 if (!SCM_KEYWORDP (tmp
))
418 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
420 slot_value
= scm_i_get_keyword (tmp
,
429 /* set slot to provided value */
430 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
433 /* set slot to its :init-form if it exists */
434 tmp
= SCM_CADAR (get_n_set
);
435 if (scm_is_true (tmp
))
437 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
438 if (SCM_GOOPS_UNBOUNDP (slot_value
))
440 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
441 set_slot_value (class,
444 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
454 /* NOTE: The following macros are interdependent with code
455 * in goops.scm:compute-getters-n-setters
457 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
458 (SCM_I_INUMP (SCM_CDDR (gns)) \
459 || (scm_is_pair (SCM_CDDR (gns)) \
460 && scm_is_pair (SCM_CDDDR (gns)) \
461 && scm_is_pair (SCM_CDDDDR (gns))))
462 #define SCM_GNS_INDEX(gns) \
463 (SCM_I_INUMP (SCM_CDDR (gns)) \
464 ? SCM_I_INUM (SCM_CDDR (gns)) \
465 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
466 #define SCM_GNS_SIZE(gns) \
467 (SCM_I_INUMP (SCM_CDDR (gns)) \
469 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
471 SCM_KEYWORD (k_class
, "class");
472 SCM_KEYWORD (k_allocation
, "allocation");
473 SCM_KEYWORD (k_instance
, "instance");
475 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
478 #define FUNC_NAME s_scm_sys_prep_layout_x
480 SCM slots
, getters_n_setters
, nfields
;
481 unsigned long int n
, i
;
485 SCM_VALIDATE_INSTANCE (1, class);
486 slots
= SCM_SLOT (class, scm_si_slots
);
487 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
488 nfields
= SCM_SLOT (class, scm_si_nfields
);
489 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
490 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
491 scm_list_1 (nfields
));
492 n
= 2 * SCM_I_INUM (nfields
);
493 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
494 && SCM_SUBCLASSP (class, scm_class_class
))
495 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
496 scm_list_1 (nfields
));
498 layout
= scm_i_make_string (n
, &s
);
500 while (scm_is_pair (getters_n_setters
))
502 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
505 int len
, index
, size
;
508 if (i
>= n
|| !scm_is_pair (slots
))
511 /* extract slot type */
512 len
= scm_ilength (SCM_CDAR (slots
));
513 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
514 len
, SCM_BOOL_F
, FUNC_NAME
);
515 /* determine slot GC protection and access mode */
516 if (scm_is_false (type
))
523 if (!SCM_CLASSP (type
))
524 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
525 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
527 if (SCM_SUBCLASSP (type
, scm_class_self
))
529 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
534 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
536 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
548 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
549 if (index
!= (i
>> 1))
551 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
559 slots
= SCM_CDR (slots
);
560 getters_n_setters
= SCM_CDR (getters_n_setters
);
562 if (!scm_is_null (slots
))
565 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
567 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
568 return SCM_UNSPECIFIED
;
572 static void prep_hashsets (SCM
);
574 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
575 (SCM
class, SCM dsupers
),
577 #define FUNC_NAME s_scm_sys_inherit_magic_x
581 SCM_VALIDATE_INSTANCE (1, class);
582 while (!scm_is_null (ls
))
584 SCM_ASSERT (scm_is_pair (ls
)
585 && SCM_INSTANCEP (SCM_CAR (ls
)),
589 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
592 flags
&= SCM_CLASSF_INHERIT
;
593 if (flags
& SCM_CLASSF_ENTITY
)
594 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
597 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
600 * We could avoid calling scm_gc_malloc in the allocation code
601 * (in which case the following two lines are needed). Instead
602 * we make 0-slot instances non-light, so that the light case
603 * can be handled without special cases.
606 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
608 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
610 /* NOTE: The following depends on scm_struct_i_size. */
611 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
612 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
615 SCM_SET_CLASS_FLAGS (class, flags
);
617 prep_hashsets (class);
619 return SCM_UNSPECIFIED
;
624 prep_hashsets (SCM
class)
628 for (i
= 0; i
< 7; ++i
)
629 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
632 /******************************************************************************/
635 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
637 SCM z
, cpl
, slots
, nfields
, g_n_s
;
639 /* Allocate one instance */
640 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
642 /* Initialize its slots */
643 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
644 cpl
= compute_cpl (z
);
645 slots
= build_slots_list (maplist (dslots
), cpl
);
646 nfields
= scm_from_int (scm_ilength (slots
));
647 g_n_s
= compute_getters_n_setters (slots
);
649 SCM_SET_SLOT (z
, scm_si_name
, name
);
650 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
651 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
652 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
653 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
654 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
655 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
656 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
657 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
658 SCM_SET_SLOT (z
, scm_si_environment
,
659 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
661 /* Add this class in the direct-subclasses slot of dsupers */
664 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
665 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
666 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
667 scm_si_direct_subclasses
)));
670 /* Support for the underlying structs: */
671 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
672 ? (SCM_CLASSF_GOOPS_OR_VALID
673 | SCM_CLASSF_OPERATOR
675 : class == scm_class_operator_class
676 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
677 : SCM_CLASSF_GOOPS_OR_VALID
));
682 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
684 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
685 scm_sys_inherit_magic_x (z
, dsupers
);
686 scm_sys_prep_layout_x (z
);
690 /******************************************************************************/
692 SCM_SYMBOL (sym_layout
, "layout");
693 SCM_SYMBOL (sym_vcell
, "vcell");
694 SCM_SYMBOL (sym_vtable
, "vtable");
695 SCM_SYMBOL (sym_print
, "print");
696 SCM_SYMBOL (sym_procedure
, "procedure");
697 SCM_SYMBOL (sym_setter
, "setter");
698 SCM_SYMBOL (sym_redefined
, "redefined");
699 SCM_SYMBOL (sym_h0
, "h0");
700 SCM_SYMBOL (sym_h1
, "h1");
701 SCM_SYMBOL (sym_h2
, "h2");
702 SCM_SYMBOL (sym_h3
, "h3");
703 SCM_SYMBOL (sym_h4
, "h4");
704 SCM_SYMBOL (sym_h5
, "h5");
705 SCM_SYMBOL (sym_h6
, "h6");
706 SCM_SYMBOL (sym_h7
, "h7");
707 SCM_SYMBOL (sym_name
, "name");
708 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
709 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
710 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
711 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
712 SCM_SYMBOL (sym_cpl
, "cpl");
713 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
714 SCM_SYMBOL (sym_slots
, "slots");
715 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
716 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
717 SCM_SYMBOL (sym_nfields
, "nfields");
718 SCM_SYMBOL (sym_environment
, "environment");
722 build_class_class_slots ()
725 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
726 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
727 scm_list_1 (sym_print
),
728 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
729 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
730 scm_list_1 (sym_redefined
),
731 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
732 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
733 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
734 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
735 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
736 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
737 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
738 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
739 scm_list_1 (sym_name
),
740 scm_list_1 (sym_direct_supers
),
741 scm_list_1 (sym_direct_slots
),
742 scm_list_1 (sym_direct_subclasses
),
743 scm_list_1 (sym_direct_methods
),
744 scm_list_1 (sym_cpl
),
745 scm_list_1 (sym_default_slot_definition_class
),
746 scm_list_1 (sym_slots
),
747 scm_list_1 (sym_getters_n_setters
),
748 scm_list_1 (sym_keyword_access
),
749 scm_list_1 (sym_nfields
),
750 scm_list_1 (sym_environment
),
755 create_basic_classes (void)
757 /* SCM slots_of_class = build_class_class_slots (); */
759 /**** <scm_class_class> ****/
760 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
761 + 2 * scm_vtable_offset_user
);
762 SCM name
= scm_from_locale_symbol ("<class>");
763 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
766 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
767 | SCM_CLASSF_METACLASS
));
769 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
770 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
771 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
772 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
773 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
774 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
775 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
776 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
777 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
778 compute_getters_n_setters (slots_of_class)); */
779 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
780 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
781 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
783 prep_hashsets (scm_class_class
);
785 DEFVAR(name
, scm_class_class
);
787 /**** <scm_class_top> ****/
788 name
= scm_from_locale_symbol ("<top>");
789 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
794 DEFVAR(name
, scm_class_top
);
796 /**** <scm_class_object> ****/
797 name
= scm_from_locale_symbol ("<object>");
798 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
800 scm_list_1 (scm_class_top
),
803 DEFVAR (name
, scm_class_object
);
805 /* <top> <object> and <class> were partially initialized. Correct them here */
806 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
808 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
809 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
812 /******************************************************************************/
814 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
816 "Return @code{#t} if @var{obj} is an instance.")
817 #define FUNC_NAME s_scm_instance_p
819 return scm_from_bool (SCM_INSTANCEP (obj
));
824 /******************************************************************************
826 * Meta object accessors
828 ******************************************************************************/
829 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
831 "Return the class name of @var{obj}.")
832 #define FUNC_NAME s_scm_class_name
834 SCM_VALIDATE_CLASS (1, obj
);
835 return scm_slot_ref (obj
, sym_name
);
839 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
841 "Return the direct superclasses of the class @var{obj}.")
842 #define FUNC_NAME s_scm_class_direct_supers
844 SCM_VALIDATE_CLASS (1, obj
);
845 return scm_slot_ref (obj
, sym_direct_supers
);
849 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
851 "Return the direct slots of the class @var{obj}.")
852 #define FUNC_NAME s_scm_class_direct_slots
854 SCM_VALIDATE_CLASS (1, obj
);
855 return scm_slot_ref (obj
, sym_direct_slots
);
859 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
861 "Return the direct subclasses of the class @var{obj}.")
862 #define FUNC_NAME s_scm_class_direct_subclasses
864 SCM_VALIDATE_CLASS (1, obj
);
865 return scm_slot_ref(obj
, sym_direct_subclasses
);
869 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
871 "Return the direct methods of the class @var{obj}")
872 #define FUNC_NAME s_scm_class_direct_methods
874 SCM_VALIDATE_CLASS (1, obj
);
875 return scm_slot_ref (obj
, sym_direct_methods
);
879 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
881 "Return the class precedence list of the class @var{obj}.")
882 #define FUNC_NAME s_scm_class_precedence_list
884 SCM_VALIDATE_CLASS (1, obj
);
885 return scm_slot_ref (obj
, sym_cpl
);
889 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
891 "Return the slot list of the class @var{obj}.")
892 #define FUNC_NAME s_scm_class_slots
894 SCM_VALIDATE_CLASS (1, obj
);
895 return scm_slot_ref (obj
, sym_slots
);
899 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
901 "Return the environment of the class @var{obj}.")
902 #define FUNC_NAME s_scm_class_environment
904 SCM_VALIDATE_CLASS (1, obj
);
905 return scm_slot_ref(obj
, sym_environment
);
910 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
912 "Return the name of the generic function @var{obj}.")
913 #define FUNC_NAME s_scm_generic_function_name
915 SCM_VALIDATE_GENERIC (1, obj
);
916 return scm_procedure_property (obj
, scm_sym_name
);
920 SCM_SYMBOL (sym_methods
, "methods");
921 SCM_SYMBOL (sym_extended_by
, "extended-by");
922 SCM_SYMBOL (sym_extends
, "extends");
925 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
927 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
928 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
929 while (!scm_is_null (gfs
))
931 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
938 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
940 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
942 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
943 while (!scm_is_null (gfs
))
945 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
946 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
955 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
957 "Return the methods of the generic function @var{obj}.")
958 #define FUNC_NAME s_scm_generic_function_methods
961 SCM_VALIDATE_GENERIC (1, obj
);
962 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
963 methods
= fold_downward_gf_methods (methods
, obj
);
964 return scm_append (methods
);
968 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
970 "Return the generic function for the method @var{obj}.")
971 #define FUNC_NAME s_scm_method_generic_function
973 SCM_VALIDATE_METHOD (1, obj
);
974 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
978 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
980 "Return specializers of the method @var{obj}.")
981 #define FUNC_NAME s_scm_method_specializers
983 SCM_VALIDATE_METHOD (1, obj
);
984 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
988 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
990 "Return the procedure of the method @var{obj}.")
991 #define FUNC_NAME s_scm_method_procedure
993 SCM_VALIDATE_METHOD (1, obj
);
994 return scm_slot_ref (obj
, sym_procedure
);
998 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1000 "Return the slot definition of the accessor @var{obj}.")
1001 #define FUNC_NAME s_scm_accessor_method_slot_definition
1003 SCM_VALIDATE_ACCESSOR (1, obj
);
1004 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1008 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1010 "Internal GOOPS magic---don't use this function!")
1011 #define FUNC_NAME s_scm_sys_tag_body
1013 return scm_cons (SCM_IM_LAMBDA
, body
);
1017 /******************************************************************************
1019 * S l o t a c c e s s
1021 ******************************************************************************/
1023 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1025 "Return the unbound value.")
1026 #define FUNC_NAME s_scm_make_unbound
1028 return SCM_GOOPS_UNBOUND
;
1032 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1034 "Return @code{#t} if @var{obj} is unbound.")
1035 #define FUNC_NAME s_scm_unbound_p
1037 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1041 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1042 (SCM value
, SCM obj
),
1043 "Return @var{value} if it is bound, and invoke the\n"
1044 "@var{slot-unbound} method of @var{obj} if it is not.")
1045 #define FUNC_NAME s_scm_assert_bound
1047 if (SCM_GOOPS_UNBOUNDP (value
))
1048 return CALL_GF1 ("slot-unbound", obj
);
1053 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1054 (SCM obj
, SCM index
),
1055 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1056 "the value from @var{obj}.")
1057 #define FUNC_NAME s_scm_at_assert_bound_ref
1059 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1060 if (SCM_GOOPS_UNBOUNDP (value
))
1061 return CALL_GF1 ("slot-unbound", obj
);
1066 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1067 (SCM obj
, SCM index
),
1068 "Return the slot value with index @var{index} from @var{obj}.")
1069 #define FUNC_NAME s_scm_sys_fast_slot_ref
1071 unsigned long int i
;
1073 SCM_VALIDATE_INSTANCE (1, obj
);
1074 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1075 return SCM_SLOT (obj
, i
);
1079 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1080 (SCM obj
, SCM index
, SCM value
),
1081 "Set the slot with index @var{index} in @var{obj} to\n"
1083 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1085 unsigned long int i
;
1087 SCM_VALIDATE_INSTANCE (1, obj
);
1088 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1090 SCM_SET_SLOT (obj
, i
, value
);
1092 return SCM_UNSPECIFIED
;
1097 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1098 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1103 /* In the future, this function will return the effective slot
1104 * definition associated with SLOT_NAME. Now it just returns some of
1105 * the information which will be stored in the effective slot
1110 slot_definition_using_name (SCM
class, SCM slot_name
)
1112 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1113 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1114 if (SCM_CAAR (slots
) == slot_name
)
1115 return SCM_CAR (slots
);
1120 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1122 SCM access
= SCM_CDDR (slotdef
);
1124 * - access is an integer (the offset of this slot in the slots vector)
1125 * - otherwise (car access) is the getter function to apply
1127 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1128 * we can just assume fixnums here.
1130 if (SCM_I_INUMP (access
))
1131 return SCM_SLOT (obj
, SCM_I_INUM (access
));
1134 /* We must evaluate (apply (car access) (list obj))
1135 * where (car access) is known to be a closure of arity 1 */
1136 register SCM code
, env
;
1138 code
= SCM_CAR (access
);
1139 if (!SCM_CLOSUREP (code
))
1140 return SCM_SUBRF (code
) (obj
);
1141 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1144 /* Evaluate the closure body */
1145 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1150 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1152 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1153 if (scm_is_true (slotdef
))
1154 return get_slot_value (class, obj
, slotdef
);
1156 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1160 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1162 SCM access
= SCM_CDDR (slotdef
);
1164 * - access is an integer (the offset of this slot in the slots vector)
1165 * - otherwise (cadr access) is the setter function to apply
1167 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1168 * we can just assume fixnums here.
1170 if (SCM_I_INUMP (access
))
1171 SCM_SET_SLOT (obj
, SCM_I_INUM (access
), value
);
1174 /* We must evaluate (apply (cadr l) (list obj value))
1175 * where (cadr l) is known to be a closure of arity 2 */
1176 register SCM code
, env
;
1178 code
= SCM_CADR (access
);
1179 if (!SCM_CLOSUREP (code
))
1180 SCM_SUBRF (code
) (obj
, value
);
1183 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1184 scm_list_2 (obj
, value
),
1186 /* Evaluate the closure body */
1187 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1190 return SCM_UNSPECIFIED
;
1194 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1196 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1197 if (scm_is_true (slotdef
))
1198 return set_slot_value (class, obj
, slotdef
, value
);
1200 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1204 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1208 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1209 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1215 /* ======================================== */
1217 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1218 (SCM
class, SCM obj
, SCM slot_name
),
1220 #define FUNC_NAME s_scm_slot_ref_using_class
1224 SCM_VALIDATE_CLASS (1, class);
1225 SCM_VALIDATE_INSTANCE (2, obj
);
1226 SCM_VALIDATE_SYMBOL (3, slot_name
);
1228 res
= get_slot_value_using_name (class, obj
, slot_name
);
1229 if (SCM_GOOPS_UNBOUNDP (res
))
1230 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1236 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1237 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1239 #define FUNC_NAME s_scm_slot_set_using_class_x
1241 SCM_VALIDATE_CLASS (1, class);
1242 SCM_VALIDATE_INSTANCE (2, obj
);
1243 SCM_VALIDATE_SYMBOL (3, slot_name
);
1245 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1250 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1251 (SCM
class, SCM obj
, SCM slot_name
),
1253 #define FUNC_NAME s_scm_slot_bound_using_class_p
1255 SCM_VALIDATE_CLASS (1, class);
1256 SCM_VALIDATE_INSTANCE (2, obj
);
1257 SCM_VALIDATE_SYMBOL (3, slot_name
);
1259 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1265 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1266 (SCM
class, SCM obj
, SCM slot_name
),
1268 #define FUNC_NAME s_scm_slot_exists_using_class_p
1270 SCM_VALIDATE_CLASS (1, class);
1271 SCM_VALIDATE_INSTANCE (2, obj
);
1272 SCM_VALIDATE_SYMBOL (3, slot_name
);
1273 return test_slot_existence (class, obj
, slot_name
);
1278 /* ======================================== */
1280 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1281 (SCM obj
, SCM slot_name
),
1282 "Return the value from @var{obj}'s slot with the name\n"
1284 #define FUNC_NAME s_scm_slot_ref
1288 SCM_VALIDATE_INSTANCE (1, obj
);
1289 TEST_CHANGE_CLASS (obj
, class);
1291 res
= get_slot_value_using_name (class, obj
, slot_name
);
1292 if (SCM_GOOPS_UNBOUNDP (res
))
1293 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1298 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1299 (SCM obj
, SCM slot_name
, SCM value
),
1300 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1301 #define FUNC_NAME s_scm_slot_set_x
1305 SCM_VALIDATE_INSTANCE (1, obj
);
1306 TEST_CHANGE_CLASS(obj
, class);
1308 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1312 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1314 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1315 (SCM obj
, SCM slot_name
),
1316 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1318 #define FUNC_NAME s_scm_slot_bound_p
1322 SCM_VALIDATE_INSTANCE (1, obj
);
1323 TEST_CHANGE_CLASS(obj
, class);
1325 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1333 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1334 (SCM obj
, SCM slot_name
),
1335 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1336 #define FUNC_NAME s_scm_slot_exists_p
1340 SCM_VALIDATE_INSTANCE (1, obj
);
1341 SCM_VALIDATE_SYMBOL (2, slot_name
);
1342 TEST_CHANGE_CLASS (obj
, class);
1344 return test_slot_existence (class, obj
, slot_name
);
1349 /******************************************************************************
1351 * %allocate-instance (the low level instance allocation primitive)
1353 ******************************************************************************/
1355 static void clear_method_cache (SCM
);
1358 wrap_init (SCM
class, SCM
*m
, long n
)
1362 /* Set all slots to unbound */
1363 for (i
= 0; i
< n
; i
++)
1364 m
[i
] = SCM_GOOPS_UNBOUND
;
1366 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1368 (scm_t_bits
) m
, 0, 0);
1371 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1372 (SCM
class, SCM initargs
),
1373 "Create a new instance of class @var{class} and initialize it\n"
1374 "from the arguments @var{initargs}.")
1375 #define FUNC_NAME s_scm_sys_allocate_instance
1380 SCM_VALIDATE_CLASS (1, class);
1382 /* Most instances */
1383 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1385 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1386 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1387 return wrap_init (class, m
, n
);
1390 /* Foreign objects */
1391 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1392 return scm_make_foreign_object (class, initargs
);
1394 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1397 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1399 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1401 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1402 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1403 /* Generic functions */
1404 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1406 SCM gf
= wrap_init (class, m
, n
);
1407 clear_method_cache (gf
);
1411 return wrap_init (class, m
, n
);
1415 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1419 /* allocate class object */
1420 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1422 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1423 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1424 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1426 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1427 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1428 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1429 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1434 /* Non-light instances */
1436 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1437 return wrap_init (class, m
, n
);
1442 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1443 (SCM obj
, SCM setter
),
1445 #define FUNC_NAME s_scm_sys_set_object_setter_x
1447 SCM_ASSERT (SCM_STRUCTP (obj
)
1448 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1449 || SCM_I_ENTITYP (obj
)),
1453 if (SCM_I_ENTITYP (obj
))
1454 SCM_SET_ENTITY_SETTER (obj
, setter
);
1456 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1457 return SCM_UNSPECIFIED
;
1461 /******************************************************************************
1463 * %modify-instance (used by change-class to modify in place)
1465 ******************************************************************************/
1467 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1470 #define FUNC_NAME s_scm_sys_modify_instance
1472 SCM_VALIDATE_INSTANCE (1, old
);
1473 SCM_VALIDATE_INSTANCE (2, new);
1475 /* Exchange the data contained in old and new. We exchange rather than
1476 * scratch the old value with new to be correct with GC.
1477 * See "Class redefinition protocol above".
1481 SCM car
= SCM_CAR (old
);
1482 SCM cdr
= SCM_CDR (old
);
1483 SCM_SETCAR (old
, SCM_CAR (new));
1484 SCM_SETCDR (old
, SCM_CDR (new));
1485 SCM_SETCAR (new, car
);
1486 SCM_SETCDR (new, cdr
);
1489 return SCM_UNSPECIFIED
;
1493 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1496 #define FUNC_NAME s_scm_sys_modify_class
1498 SCM_VALIDATE_CLASS (1, old
);
1499 SCM_VALIDATE_CLASS (2, new);
1503 SCM car
= SCM_CAR (old
);
1504 SCM cdr
= SCM_CDR (old
);
1505 SCM_SETCAR (old
, SCM_CAR (new));
1506 SCM_SETCDR (old
, SCM_CDR (new));
1507 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1508 SCM_SETCAR (new, car
);
1509 SCM_SETCDR (new, cdr
);
1510 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1513 return SCM_UNSPECIFIED
;
1517 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1520 #define FUNC_NAME s_scm_sys_invalidate_class
1522 SCM_VALIDATE_CLASS (1, class);
1523 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1524 return SCM_UNSPECIFIED
;
1528 /* When instances change class, they finally get a new body, but
1529 * before that, they go through purgatory in hell. Odd as it may
1530 * seem, this data structure saves us from eternal suffering in
1531 * infinite recursions.
1534 static scm_t_bits
**hell
;
1535 static long n_hell
= 1; /* one place for the evil one himself */
1536 static long hell_size
= 4;
1537 static SCM hell_mutex
;
1543 for (i
= 1; i
< n_hell
; ++i
)
1544 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1550 go_to_hell (void *o
)
1552 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1553 scm_lock_mutex (hell_mutex
);
1554 if (n_hell
== hell_size
)
1556 long new_size
= 2 * hell_size
;
1557 hell
= scm_realloc (hell
, new_size
);
1558 hell_size
= new_size
;
1560 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1561 scm_unlock_mutex (hell_mutex
);
1565 go_to_heaven (void *o
)
1567 scm_lock_mutex (hell_mutex
);
1568 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1569 scm_unlock_mutex (hell_mutex
);
1573 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1576 purgatory (void *args
)
1578 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1579 SCM_PACK ((scm_t_bits
) args
));
1582 /* This function calls the generic function change-class for all
1583 * instances which aren't currently undergoing class change.
1587 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1590 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1591 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1592 (void *) SCM_UNPACK (obj
));
1595 /******************************************************************************
1601 * GGG E N E R I C F U N C T I O N S
1603 * This implementation provides
1604 * - generic functions (with class specializers)
1607 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1609 ******************************************************************************/
1611 SCM_KEYWORD (k_name
, "name");
1613 SCM_SYMBOL (sym_no_method
, "no-method");
1615 static SCM list_of_no_method
;
1617 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1621 scm_make_method_cache (SCM gf
)
1623 return scm_list_5 (SCM_IM_DISPATCH
,
1626 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1632 clear_method_cache (SCM gf
)
1634 SCM cache
= scm_make_method_cache (gf
);
1635 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1636 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1639 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1642 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1645 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1646 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1647 if (scm_is_true (used_by
))
1649 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1650 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1651 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1652 clear_method_cache (gf
);
1653 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1654 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1657 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1658 /* The sign of n is a flag indicating rest args. */
1659 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1661 return SCM_UNSPECIFIED
;
1665 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1668 #define FUNC_NAME s_scm_generic_capability_p
1670 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1671 proc
, SCM_ARG1
, FUNC_NAME
);
1672 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1678 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1681 #define FUNC_NAME s_scm_enable_primitive_generic_x
1683 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1684 while (!scm_is_null (subrs
))
1686 SCM subr
= SCM_CAR (subrs
);
1687 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1688 subr
, SCM_ARGn
, FUNC_NAME
);
1689 *SCM_SUBR_GENERIC (subr
)
1690 = scm_make (scm_list_3 (scm_class_generic
,
1693 subrs
= SCM_CDR (subrs
);
1695 return SCM_UNSPECIFIED
;
1699 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1702 #define FUNC_NAME s_scm_primitive_generic_generic
1704 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1706 if (!*SCM_SUBR_GENERIC (subr
))
1707 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1708 return *SCM_SUBR_GENERIC (subr
);
1710 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1714 typedef struct t_extension
{
1715 struct t_extension
*next
;
1720 static t_extension
*extensions
= 0;
1722 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1725 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1730 if (!*SCM_SUBR_GENERIC (extended
))
1731 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1732 gf
= *SCM_SUBR_GENERIC (extended
);
1733 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1735 SCM_SNAME (extension
));
1736 *SCM_SUBR_GENERIC (extension
) = gext
;
1740 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1741 t_extension
**loc
= &extensions
;
1742 /* Make sure that extensions are placed before their own
1743 * extensions in the extensions list. O(N^2) algorithm, but
1744 * extensions of primitive generics are rare.
1746 while (*loc
&& extension
!= (*loc
)->extended
)
1747 loc
= &(*loc
)->next
;
1749 e
->extended
= extended
;
1750 e
->extension
= extension
;
1756 setup_extended_primitive_generics ()
1760 t_extension
*e
= extensions
;
1761 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1762 extensions
= e
->next
;
1767 /******************************************************************************
1769 * Protocol for calling a generic fumction
1770 * This protocol is roughly equivalent to (parameter are a little bit different
1771 * for efficiency reasons):
1773 * + apply-generic (gf args)
1774 * + compute-applicable-methods (gf args ...)
1775 * + sort-applicable-methods (methods args)
1776 * + apply-methods (gf methods args)
1778 * apply-methods calls make-next-method to build the "continuation" of a a
1779 * method. Applying a next-method will call apply-next-method which in
1780 * turn will call apply again to call effectively the following method.
1782 ******************************************************************************/
1785 applicablep (SCM actual
, SCM formal
)
1787 /* We already know that the cpl is well formed. */
1788 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1792 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1794 register SCM s1
, s2
;
1798 * m1 and m2 can have != length (i.e. one can be one element longer than the
1799 * other when we have a dotted parameter list). For instance, with the call
1802 * (define-method M (a . l) ....)
1803 * (define-method M (a) ....)
1805 * we consider that the second method is more specific.
1807 * BTW, targs is an array of types. We don't need it's size since
1808 * we already know that m1 and m2 are applicable (no risk to go past
1809 * the end of this array).
1812 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1813 if (scm_is_null(s1
)) return 1;
1814 if (scm_is_null(s2
)) return 0;
1815 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1816 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1818 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1819 if (cs1
== SCM_CAR(l
))
1821 if (cs2
== SCM_CAR(l
))
1824 return 0;/* should not occur! */
1827 return 0; /* should not occur! */
1830 #define BUFFSIZE 32 /* big enough for most uses */
1833 scm_i_vector2list (SCM l
, long len
)
1836 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1838 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1839 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1845 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1848 SCM
*v
, vector
= SCM_EOL
;
1849 SCM buffer
[BUFFSIZE
];
1850 SCM save
= method_list
;
1852 /* For reasonably sized method_lists we can try to avoid all the
1853 * consing and reorder the list in place...
1854 * This idea is due to David McClain <Dave_McClain@msn.com>
1856 if (size
<= BUFFSIZE
)
1858 for (i
= 0; i
< size
; i
++)
1860 buffer
[i
] = SCM_CAR (method_list
);
1861 method_list
= SCM_CDR (method_list
);
1867 /* Too many elements in method_list to keep everything locally */
1868 vector
= scm_i_vector2list (save
, size
);
1871 This is a new vector. Don't worry about the write barrier.
1872 We're not allocating elements in this routine, so this should
1875 v
= SCM_WRITABLE_VELTS (vector
);
1878 /* Use a simple shell sort since it is generally faster than qsort on
1879 * small vectors (which is probably mostly the case when we have to
1880 * sort a list of applicable methods).
1882 for (incr
= size
/ 2; incr
; incr
/= 2)
1884 for (i
= incr
; i
< size
; i
++)
1886 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1888 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1892 SCM tmp
= v
[j
+ incr
];
1900 if (size
<= BUFFSIZE
)
1902 /* We did it in locally, so restore the original list (reordered) in-place */
1903 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1905 SCM_SETCAR (method_list
, *v
);
1906 method_list
= SCM_CDR (method_list
);
1910 /* If we are here, that's that we did it the hard way... */
1911 return scm_vector_to_list (vector
);
1915 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1919 SCM l
, fl
, applicable
= SCM_EOL
;
1921 SCM buffer
[BUFFSIZE
];
1926 /* Build the list of arguments types */
1927 if (len
>= BUFFSIZE
) {
1928 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1929 /* NOTE: Using pointers to malloced memory won't work if we
1930 1. have preemtive threading, and,
1931 2. have a GC which moves objects. */
1932 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1935 note that we don't have to work to reset the generation
1936 count. TMP is a new vector anyway, and it is found
1943 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
1944 *p
++ = scm_class_of (SCM_CAR (args
));
1946 /* Build a list of all applicable methods */
1947 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
1949 fl
= SPEC_OF (SCM_CAR (l
));
1950 /* Only accept accessors which match exactly in first arg. */
1951 if (SCM_ACCESSORP (SCM_CAR (l
))
1952 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
1954 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1956 if (SCM_INSTANCEP (fl
)
1957 /* We have a dotted argument list */
1958 || (i
>= len
&& scm_is_null (fl
)))
1959 { /* both list exhausted */
1960 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1966 || !applicablep (types
[i
], SCM_CAR (fl
)))
1975 CALL_GF2 ("no-applicable-method", gf
, save
);
1976 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1980 scm_remember_upto_here_1 (tmp
);
1983 : sort_applicable_methods (applicable
, count
, types
));
1987 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1990 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1993 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1994 #define FUNC_NAME s_sys_compute_applicable_methods
1997 SCM_VALIDATE_GENERIC (1, gf
);
1998 n
= scm_ilength (args
);
1999 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2000 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2004 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2005 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
));
2008 lock_cache_mutex (void *m
)
2010 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2011 scm_lock_mutex (mutex
);
2015 unlock_cache_mutex (void *m
)
2017 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2018 scm_unlock_mutex (mutex
);
2022 call_memoize_method (void *a
)
2024 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2025 SCM gf
= SCM_CAR (args
);
2026 SCM x
= SCM_CADR (args
);
2027 /* First check if another thread has inserted a method between
2028 * the cache miss and locking the mutex.
2030 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2031 if (scm_is_true (cmethod
))
2033 /*fixme* Use scm_apply */
2034 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2038 scm_memoize_method (SCM x
, SCM args
)
2040 SCM gf
= SCM_CAR (scm_last_pair (x
));
2041 return scm_internal_dynamic_wind (
2043 call_memoize_method
,
2045 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2046 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2049 /******************************************************************************
2051 * A simple make (which will be redefined later in Scheme)
2052 * This version handles only creation of gf, methods and classes (no instances)
2054 * Since this code will disappear when Goops will be fully booted,
2055 * no precaution is taken to be efficient.
2057 ******************************************************************************/
2059 SCM_KEYWORD (k_setter
, "setter");
2060 SCM_KEYWORD (k_specializers
, "specializers");
2061 SCM_KEYWORD (k_procedure
, "procedure");
2062 SCM_KEYWORD (k_dsupers
, "dsupers");
2063 SCM_KEYWORD (k_slots
, "slots");
2064 SCM_KEYWORD (k_gf
, "generic-function");
2066 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2068 "Make a new object. @var{args} must contain the class and\n"
2069 "all necessary initialization information.")
2070 #define FUNC_NAME s_scm_make
2073 long len
= scm_ilength (args
);
2075 if (len
<= 0 || (len
& 1) == 0)
2076 SCM_WRONG_NUM_ARGS ();
2078 class = SCM_CAR(args
);
2079 args
= SCM_CDR(args
);
2081 if (class == scm_class_generic
|| class == scm_class_accessor
)
2083 z
= scm_make_struct (class, SCM_INUM0
,
2084 scm_list_5 (SCM_EOL
,
2089 scm_set_procedure_property_x (z
, scm_sym_name
,
2090 scm_get_keyword (k_name
,
2093 clear_method_cache (z
);
2094 if (class == scm_class_accessor
)
2096 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2097 if (scm_is_true (setter
))
2098 scm_sys_set_object_setter_x (z
, setter
);
2103 z
= scm_sys_allocate_instance (class, args
);
2105 if (class == scm_class_method
2106 || class == scm_class_simple_method
2107 || class == scm_class_accessor_method
)
2109 SCM_SET_SLOT (z
, scm_si_generic_function
,
2110 scm_i_get_keyword (k_gf
,
2115 SCM_SET_SLOT (z
, scm_si_specializers
,
2116 scm_i_get_keyword (k_specializers
,
2121 SCM_SET_SLOT (z
, scm_si_procedure
,
2122 scm_i_get_keyword (k_procedure
,
2127 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2131 /* In all the others case, make a new class .... No instance here */
2132 SCM_SET_SLOT (z
, scm_si_name
,
2133 scm_i_get_keyword (k_name
,
2136 scm_from_locale_symbol ("???"),
2138 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2139 scm_i_get_keyword (k_dsupers
,
2144 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2145 scm_i_get_keyword (k_slots
,
2156 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2159 #define FUNC_NAME s_scm_find_method
2162 long len
= scm_ilength (l
);
2165 SCM_WRONG_NUM_ARGS ();
2167 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2168 SCM_VALIDATE_GENERIC (1, gf
);
2169 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2170 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2172 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2176 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2177 (SCM m1
, SCM m2
, SCM targs
),
2179 #define FUNC_NAME s_scm_sys_method_more_specific_p
2184 SCM_VALIDATE_METHOD (1, m1
);
2185 SCM_VALIDATE_METHOD (2, m2
);
2186 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2188 /* Verify that all the arguments of targs are classes and place them in a vector*/
2189 v
= scm_c_make_vector (len
, SCM_EOL
);
2191 for (i
= 0, l
= targs
; !scm_is_null (l
); i
++, l
= SCM_CDR (l
)) {
2192 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2193 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2195 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2201 /******************************************************************************
2205 ******************************************************************************/
2208 fix_cpl (SCM c
, SCM before
, SCM after
)
2210 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2211 SCM ls
= scm_c_memq (after
, cpl
);
2212 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2213 if (scm_is_false (ls
))
2214 /* if this condition occurs, fix_cpl should not be applied this way */
2216 SCM_SETCAR (ls
, before
);
2217 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2219 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2220 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2221 SCM g_n_s
= compute_getters_n_setters (slots
);
2222 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2223 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2229 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2231 SCM tmp
= scm_from_locale_symbol (name
);
2233 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2237 : scm_list_1 (super
),
2243 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2246 create_standard_classes (void)
2249 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2250 scm_from_locale_symbol ("specializers"),
2252 scm_from_locale_symbol ("code-table"));
2253 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2255 k_slot_definition
));
2256 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2257 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2261 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2262 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2265 scm_list_3 (scm_from_locale_symbol ("used-by"),
2268 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2271 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2274 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2277 /* Foreign class slot classes */
2278 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2279 scm_class_class
, scm_class_top
, SCM_EOL
);
2280 make_stdcls (&scm_class_protected
, "<protected-slot>",
2281 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2282 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2283 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2284 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2285 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2286 make_stdcls (&scm_class_self
, "<self-slot>",
2288 scm_class_read_only
,
2290 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2292 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2294 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2296 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2298 make_stdcls (&scm_class_scm
, "<scm-slot>",
2299 scm_class_class
, scm_class_protected
, SCM_EOL
);
2300 make_stdcls (&scm_class_int
, "<int-slot>",
2301 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2302 make_stdcls (&scm_class_float
, "<float-slot>",
2303 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2304 make_stdcls (&scm_class_double
, "<double-slot>",
2305 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2307 /* Continue initialization of class <class> */
2309 slots
= build_class_class_slots ();
2310 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2311 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2312 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2313 compute_getters_n_setters (slots
));
2315 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2316 scm_class_class
, scm_class_class
,
2317 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2320 scm_list_3 (scm_from_locale_symbol ("destructor"),
2322 scm_class_opaque
)));
2323 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2324 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2325 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2327 /* scm_class_generic functions classes */
2328 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2329 scm_class_class
, scm_class_class
, SCM_EOL
);
2330 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2331 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2332 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2333 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2334 make_stdcls (&scm_class_operator_with_setter_class
,
2335 "<operator-with-setter-class>",
2336 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2337 make_stdcls (&scm_class_method
, "<method>",
2338 scm_class_class
, scm_class_object
, method_slots
);
2339 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2340 scm_class_class
, scm_class_method
, SCM_EOL
);
2341 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2342 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2343 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2344 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2345 make_stdcls (&scm_class_applicable
, "<applicable>",
2346 scm_class_class
, scm_class_top
, SCM_EOL
);
2347 make_stdcls (&scm_class_entity
, "<entity>",
2348 scm_class_entity_class
,
2349 scm_list_2 (scm_class_object
, scm_class_applicable
),
2351 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2352 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2353 make_stdcls (&scm_class_generic
, "<generic>",
2354 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2355 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2356 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2357 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2358 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2359 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2360 scm_class_entity_class
,
2361 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2363 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2364 make_stdcls (&scm_class_accessor
, "<accessor>",
2365 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2366 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2367 make_stdcls (&scm_class_extended_generic_with_setter
,
2368 "<extended-generic-with-setter>",
2369 scm_class_entity_class
,
2370 scm_list_2 (scm_class_generic_with_setter
,
2371 scm_class_extended_generic
),
2373 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2374 SCM_CLASSF_PURE_GENERIC
);
2375 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2376 scm_class_entity_class
,
2377 scm_list_2 (scm_class_accessor
,
2378 scm_class_extended_generic_with_setter
),
2380 fix_cpl (scm_class_extended_accessor
,
2381 scm_class_extended_generic
, scm_class_generic
);
2382 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2384 /* Primitive types classes */
2385 make_stdcls (&scm_class_boolean
, "<boolean>",
2386 scm_class_class
, scm_class_top
, SCM_EOL
);
2387 make_stdcls (&scm_class_char
, "<char>",
2388 scm_class_class
, scm_class_top
, SCM_EOL
);
2389 make_stdcls (&scm_class_list
, "<list>",
2390 scm_class_class
, scm_class_top
, SCM_EOL
);
2391 make_stdcls (&scm_class_pair
, "<pair>",
2392 scm_class_class
, scm_class_list
, SCM_EOL
);
2393 make_stdcls (&scm_class_null
, "<null>",
2394 scm_class_class
, scm_class_list
, SCM_EOL
);
2395 make_stdcls (&scm_class_string
, "<string>",
2396 scm_class_class
, scm_class_top
, SCM_EOL
);
2397 make_stdcls (&scm_class_symbol
, "<symbol>",
2398 scm_class_class
, scm_class_top
, SCM_EOL
);
2399 make_stdcls (&scm_class_vector
, "<vector>",
2400 scm_class_class
, scm_class_top
, SCM_EOL
);
2401 make_stdcls (&scm_class_number
, "<number>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_complex
, "<complex>",
2404 scm_class_class
, scm_class_number
, SCM_EOL
);
2405 make_stdcls (&scm_class_real
, "<real>",
2406 scm_class_class
, scm_class_complex
, SCM_EOL
);
2407 make_stdcls (&scm_class_integer
, "<integer>",
2408 scm_class_class
, scm_class_real
, SCM_EOL
);
2409 make_stdcls (&scm_class_fraction
, "<fraction>",
2410 scm_class_class
, scm_class_real
, SCM_EOL
);
2411 make_stdcls (&scm_class_keyword
, "<keyword>",
2412 scm_class_class
, scm_class_top
, SCM_EOL
);
2413 make_stdcls (&scm_class_unknown
, "<unknown>",
2414 scm_class_class
, scm_class_top
, SCM_EOL
);
2415 make_stdcls (&scm_class_procedure
, "<procedure>",
2416 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2417 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2418 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2419 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2420 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2421 make_stdcls (&scm_class_port
, "<port>",
2422 scm_class_class
, scm_class_top
, SCM_EOL
);
2423 make_stdcls (&scm_class_input_port
, "<input-port>",
2424 scm_class_class
, scm_class_port
, SCM_EOL
);
2425 make_stdcls (&scm_class_output_port
, "<output-port>",
2426 scm_class_class
, scm_class_port
, SCM_EOL
);
2427 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2429 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2433 /**********************************************************************
2437 **********************************************************************/
2440 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2446 sprintf (buffer
, template, type_name
);
2447 name
= scm_from_locale_symbol (buffer
);
2450 name
= SCM_GOOPS_UNBOUND
;
2452 class = scm_permanent_object (scm_basic_make_class (applicablep
2453 ? scm_class_procedure_class
2459 /* Only define name if doesn't already exist. */
2460 if (!SCM_GOOPS_UNBOUNDP (name
)
2461 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2462 DEFVAR (name
, class);
2467 scm_make_extended_class (char const *type_name
, int applicablep
)
2469 return make_class_from_template ("<%s>",
2471 scm_list_1 (applicablep
2472 ? scm_class_applicable
2478 scm_i_inherit_applicable (SCM c
)
2480 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2482 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2483 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2484 /* patch scm_class_applicable into direct-supers */
2485 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2486 if (scm_is_false (top
))
2487 dsupers
= scm_append (scm_list_2 (dsupers
,
2488 scm_list_1 (scm_class_applicable
)));
2491 SCM_SETCAR (top
, scm_class_applicable
);
2492 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2494 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2495 /* patch scm_class_applicable into cpl */
2496 top
= scm_c_memq (scm_class_top
, cpl
);
2497 if (scm_is_false (top
))
2501 SCM_SETCAR (top
, scm_class_applicable
);
2502 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2504 /* add class to direct-subclasses of scm_class_applicable */
2505 SCM_SET_SLOT (scm_class_applicable
,
2506 scm_si_direct_subclasses
,
2507 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2508 scm_si_direct_subclasses
)));
2513 create_smob_classes (void)
2517 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2518 for (i
= 0; i
< 255; ++i
)
2519 scm_smob_class
[i
] = 0;
2521 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2523 for (i
= 0; i
< scm_numsmob
; ++i
)
2524 if (!scm_smob_class
[i
])
2525 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2526 scm_smobs
[i
].apply
!= 0);
2530 scm_make_port_classes (long ptobnum
, char *type_name
)
2532 SCM c
, class = make_class_from_template ("<%s-port>",
2534 scm_list_1 (scm_class_port
),
2536 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2537 = make_class_from_template ("<%s-input-port>",
2539 scm_list_2 (class, scm_class_input_port
),
2541 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2542 = make_class_from_template ("<%s-output-port>",
2544 scm_list_2 (class, scm_class_output_port
),
2546 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2548 = make_class_from_template ("<%s-input-output-port>",
2550 scm_list_2 (class, scm_class_input_output_port
),
2552 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2553 SCM_SET_SLOT (c
, scm_si_cpl
,
2554 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2558 create_port_classes (void)
2562 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2563 for (i
= 0; i
< 3 * 256; ++i
)
2564 scm_port_class
[i
] = 0;
2566 for (i
= 0; i
< scm_numptob
; ++i
)
2567 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2571 make_struct_class (void *closure SCM_UNUSED
,
2572 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2574 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2575 SCM_SET_STRUCT_TABLE_CLASS (data
,
2576 scm_make_extended_class
2577 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2578 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2579 return SCM_UNSPECIFIED
;
2583 create_struct_classes (void)
2585 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2588 /**********************************************************************
2592 **********************************************************************/
2597 if (!goops_loaded_p
)
2598 scm_c_resolve_module ("oop goops");
2603 scm_make_foreign_object (SCM
class, SCM initargs
)
2604 #define FUNC_NAME s_scm_make
2606 void * (*constructor
) (SCM
)
2607 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2608 if (constructor
== 0)
2609 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2610 return scm_wrap_object (class, constructor (initargs
));
2616 scm_free_foreign_object (SCM
*class, SCM
*data
)
2618 size_t (*destructor
) (void *)
2619 = (size_t (*) (void *)) class[scm_si_destructor
];
2620 return destructor (data
);
2624 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2625 void * (*constructor
) (SCM initargs
),
2626 size_t (*destructor
) (void *))
2629 name
= scm_from_locale_symbol (s_name
);
2630 if (scm_is_null (supers
))
2631 supers
= scm_list_1 (scm_class_foreign_object
);
2632 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2633 scm_sys_inherit_magic_x (class, supers
);
2635 if (destructor
!= 0)
2637 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2638 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2642 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2643 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2646 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2647 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2652 SCM_SYMBOL (sym_o
, "o");
2653 SCM_SYMBOL (sym_x
, "x");
2655 SCM_KEYWORD (k_accessor
, "accessor");
2656 SCM_KEYWORD (k_getter
, "getter");
2659 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2661 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2666 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2667 SCM (*getter
) (SCM obj
),
2668 SCM (*setter
) (SCM obj
, SCM x
),
2669 char *accessor_name
)
2672 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2673 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2674 setter
? setter
: default_setter
);
2676 /* Dirk:FIXME:: The following two expressions make use of the fact that
2677 * the memoizer will accept a subr-object in the place of a function.
2678 * This is not guaranteed to stay this way. */
2679 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2681 scm_list_2 (get
, sym_o
)),
2683 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2684 scm_list_2 (sym_o
, sym_x
),
2685 scm_list_3 (set
, sym_o
, sym_x
)),
2689 SCM name
= scm_from_locale_symbol (slot_name
);
2690 SCM aname
= scm_from_locale_symbol (accessor_name
);
2691 SCM gf
= scm_ensure_accessor (aname
);
2692 SCM slot
= scm_list_5 (name
,
2695 setter
? k_accessor
: k_getter
,
2697 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2702 scm_add_method (scm_setter (gf
),
2703 scm_make (scm_list_5 (scm_class_accessor_method
,
2705 scm_list_2 (class, scm_class_top
),
2710 SCM_SET_SLOT (class, scm_si_slots
,
2711 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2712 scm_list_1 (slot
))));
2714 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2715 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1));
2716 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2717 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2718 scm_list_1 (gns
))));
2719 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2726 scm_wrap_object (SCM
class, void *data
)
2728 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2736 scm_wrap_component (SCM
class, SCM container
, void *data
)
2738 SCM obj
= scm_wrap_object (class, data
);
2739 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2745 SCM_SETCDR (handle
, container
);
2750 scm_ensure_accessor (SCM name
)
2752 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2753 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2755 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2756 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2757 k_name
, name
, k_setter
, gf
));
2762 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2765 scm_add_method (SCM gf
, SCM m
)
2767 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2772 * Debugging utilities
2775 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2777 "Return @code{#t} if @var{obj} is a pure generic.")
2778 #define FUNC_NAME s_scm_pure_generic_p
2780 return scm_from_bool (SCM_PUREGENERICP (obj
));
2784 #endif /* GUILE_DEBUG */
2790 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2792 "Announce that GOOPS is loaded and perform initialization\n"
2793 "on the C level which depends on the loaded GOOPS modules.")
2794 #define FUNC_NAME s_scm_sys_goops_loaded
2797 var_compute_applicable_methods
=
2798 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2800 setup_extended_primitive_generics ();
2801 return SCM_UNSPECIFIED
;
2805 SCM scm_module_goops
;
2808 scm_init_goops_builtins (void)
2810 scm_module_goops
= scm_current_module ();
2811 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2813 /* Not really necessary right now, but who knows...
2815 scm_permanent_object (scm_module_goops
);
2816 scm_permanent_object (scm_goops_lookup_closure
);
2818 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2819 (scm_from_int (37)));
2821 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2823 #include "libguile/goops.x"
2825 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2827 hell
= scm_malloc (hell_size
);
2828 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2830 create_basic_classes ();
2831 create_standard_classes ();
2832 create_smob_classes ();
2833 create_struct_classes ();
2834 create_port_classes ();
2837 SCM name
= scm_from_locale_symbol ("no-applicable-method");
2838 scm_no_applicable_method
2839 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2842 DEFVAR (name
, scm_no_applicable_method
);
2845 return SCM_UNSPECIFIED
;
2851 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2852 scm_init_goops_builtins
);