1 /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
43 /* This software is a derivative work of other copyrighted softwares; the
44 * copyright notices of these softwares are placed in the file COPYRIGHTS
46 * This file is based upon stklos.c from the STk distribution by
47 * Erick Gallesio <eg@unice.fr>.
52 #include "libguile/_scm.h"
53 #include "libguile/alist.h"
54 #include "libguile/debug.h"
55 #include "libguile/dynl.h"
56 #include "libguile/dynwind.h"
57 #include "libguile/eval.h"
58 #include "libguile/hashtab.h"
59 #include "libguile/keywords.h"
60 #include "libguile/macros.h"
61 #include "libguile/modules.h"
62 #include "libguile/objects.h"
63 #include "libguile/ports.h"
64 #include "libguile/procprop.h"
65 #include "libguile/random.h"
66 #include "libguile/root.h"
67 #include "libguile/smob.h"
68 #include "libguile/strings.h"
69 #include "libguile/strports.h"
70 #include "libguile/vectors.h"
71 #include "libguile/weaks.h"
73 #include "libguile/validate.h"
74 #include "libguile/goops.h"
76 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
78 #define DEFVAR(v,val) \
79 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
81 /* Temporary hack until we get the new module system */
82 /*fixme* Should optimize by keeping track of the variable object itself */
83 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
86 /* Fixme: Should use already interned symbols */
87 #define CALL_GF1(name,a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
89 #define CALL_GF2(name,a,b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
91 #define CALL_GF3(name,a,b,c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
93 #define CALL_GF4(name,a,b,c,d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
96 /* Class redefinition protocol:
98 A class is represented by a heap header h1 which points to a
99 malloc:ed memory block m1.
101 When a new version of a class is created, a new header h2 and
102 memory block m2 are allocated. The headers h1 and h2 then switch
103 pointers so that h1 refers to m2 and h2 to m1. In this way, names
104 bound to h1 will point to the new class at the same time as h2 will
105 be a handle which the GC will us to free m1.
107 The `redefined' slot of m1 will be set to point to h1. An old
108 instance will have it's class pointer (the CAR of the heap header)
109 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
110 the class modification and the new class pointer can be found via
114 /* The following definition is located in libguile/objects.h:
115 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
118 #define TEST_CHANGE_CLASS(obj, class) \
120 class = SCM_CLASS_OF (obj); \
121 if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
122 CALL_GF3 ("change-object-class", \
123 obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
126 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
127 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
129 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
130 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
132 static int goops_loaded_p
= 0;
133 static scm_t_rstate
*goops_rstate
;
135 static SCM scm_goops_lookup_closure
;
137 /* Some classes are defined in libguile/objects.c. */
138 SCM scm_class_top
, scm_class_object
, scm_class_class
;
139 SCM scm_class_entity
, scm_class_entity_with_setter
;
140 SCM scm_class_generic
, scm_class_generic_with_setter
, scm_class_method
;
141 SCM scm_class_simple_method
, scm_class_accessor
;
142 SCM scm_class_procedure_class
;
143 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
144 SCM scm_class_entity_class
;
145 SCM scm_class_number
, scm_class_list
;
146 SCM scm_class_keyword
;
147 SCM scm_class_port
, scm_class_input_output_port
;
148 SCM scm_class_input_port
, scm_class_output_port
;
149 SCM scm_class_foreign_class
, scm_class_foreign_object
;
150 SCM scm_class_foreign_slot
;
151 SCM scm_class_self
, scm_class_protected
;
152 SCM scm_class_opaque
, scm_class_read_only
;
153 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
155 SCM scm_class_int
, scm_class_float
, scm_class_double
;
157 SCM_SYMBOL (scm_sym_define_public
, "define-public");
159 static SCM
scm_make_unbound (void);
160 static SCM
scm_unbound_p (SCM obj
);
161 static SCM
scm_assert_bound (SCM value
, SCM obj
);
162 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
163 static SCM
scm_sys_goops_loaded (void);
165 /******************************************************************************
169 * This version doesn't handle multiple-inheritance. It serves only for
170 * booting classes and will be overloaded in Scheme
172 ******************************************************************************/
176 compute_cpl (SCM supers
, SCM res
)
178 return (SCM_NULLP (supers
)
180 : compute_cpl (SCM_SLOT (SCM_CAR (supers
), scm_si_direct_supers
),
181 scm_cons (SCM_CAR (supers
), res
)));
186 map (SCM (*proc
) (SCM
), SCM ls
)
191 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
194 while (SCM_NIMP (ls
))
196 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
208 while (SCM_NIMP (ls
))
210 SCM el
= SCM_CAR (ls
);
211 if (SCM_FALSEP (scm_c_memq (el
, res
)))
212 res
= scm_cons (el
, res
);
219 compute_cpl (SCM
class)
222 return CALL_GF1 ("compute-cpl", class);
225 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
226 SCM ls
= scm_append (scm_acons (class, supers
,
227 map (compute_cpl
, supers
)));
228 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
232 /******************************************************************************
236 ******************************************************************************/
239 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
247 if (!SCM_SYMBOLP (tmp
))
248 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
250 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
251 res
= scm_cons (SCM_CAR (l
), res
);
252 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
255 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
259 build_slots_list (SCM dslots
, SCM cpl
)
261 register SCM res
= dslots
;
263 for (cpl
= SCM_CDR(cpl
); SCM_NNULLP(cpl
); cpl
= SCM_CDR(cpl
))
264 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
265 scm_si_direct_slots
),
268 /* res contains a list of slots. Remove slots which appears more than once */
269 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
276 while (SCM_NIMP (ls
))
278 if (!SCM_CONSP (SCM_CAR (ls
)))
279 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
286 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
288 "Return a list consisting of the names of all slots belonging to\n"
289 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
291 #define FUNC_NAME s_scm_sys_compute_slots
293 SCM_VALIDATE_CLASS (1, class);
294 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
295 SCM_SLOT (class, scm_si_cpl
));
300 /******************************************************************************
302 * compute-getters-n-setters
304 * This version doesn't handle slot options. It serves only for booting
305 * classes and will be overloaded in Scheme.
307 ******************************************************************************/
309 SCM_KEYWORD (k_init_value
, "init-value");
310 SCM_KEYWORD (k_init_thunk
, "init-thunk");
313 compute_getters_n_setters (SCM slots
)
319 for ( ; SCM_NNULLP(slots
); slots
= SCM_CDR(slots
))
321 SCM init
= SCM_BOOL_F
;
322 SCM options
= SCM_CDAR (slots
);
323 if (SCM_NNULLP (options
))
325 init
= scm_get_keyword (k_init_value
, options
, 0);
327 init
= scm_closure (scm_list_2 (SCM_EOL
, init
), SCM_EOL
);
329 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
331 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
335 cdrloc
= SCM_CDRLOC (*cdrloc
);
340 /******************************************************************************
344 ******************************************************************************/
346 /*fixme* Manufacture keywords in advance */
348 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
352 for (i
= 0; i
!= len
; i
+= 2)
354 SCM obj
= SCM_CAR (l
);
356 if (!SCM_KEYWORDP (obj
))
357 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
358 else if (SCM_EQ_P (obj
, key
))
364 return default_value
;
368 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
369 (SCM key
, SCM l
, SCM default_value
),
370 "Determine an associated value for the keyword @var{key} from\n"
371 "the list @var{l}. The list @var{l} has to consist of an even\n"
372 "number of elements, where, starting with the first, every\n"
373 "second element is a keyword, followed by its associated value.\n"
374 "If @var{l} does not hold a value for @var{key}, the value\n"
375 "@var{default_value} is returned.")
376 #define FUNC_NAME s_scm_get_keyword
380 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
381 len
= scm_ilength (l
);
382 if (len
< 0 || len
% 2 == 1)
383 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
385 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
390 SCM_KEYWORD (k_init_keyword
, "init-keyword");
392 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
393 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
395 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
396 (SCM obj
, SCM initargs
),
397 "Initialize the object @var{obj} with the given arguments\n"
399 #define FUNC_NAME s_scm_sys_initialize_object
401 SCM tmp
, get_n_set
, slots
;
402 SCM
class = SCM_CLASS_OF (obj
);
405 SCM_VALIDATE_INSTANCE (1, obj
);
406 n_initargs
= scm_ilength (initargs
);
407 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
409 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
410 slots
= SCM_SLOT (class, scm_si_slots
);
412 /* See for each slot how it must be initialized */
415 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
417 SCM slot_name
= SCM_CAR (slots
);
420 if (SCM_NIMP (SCM_CDR (slot_name
)))
422 /* This slot admits (perhaps) to be initialized at creation time */
423 long n
= scm_ilength (SCM_CDR (slot_name
));
424 if (n
& 1) /* odd or -1 */
425 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
426 scm_list_1 (slot_name
));
427 tmp
= scm_i_get_keyword (k_init_keyword
,
432 slot_name
= SCM_CAR (slot_name
);
435 /* an initarg was provided for this slot */
436 if (!SCM_KEYWORDP (tmp
))
437 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
439 slot_value
= scm_i_get_keyword (tmp
,
448 /* set slot to provided value */
449 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
452 /* set slot to its :init-form if it exists */
453 tmp
= SCM_CADAR (get_n_set
);
454 if (tmp
!= SCM_BOOL_F
)
456 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
457 if (SCM_GOOPS_UNBOUNDP (slot_value
))
459 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
460 set_slot_value (class,
463 scm_eval_body (SCM_CDR (SCM_CODE (tmp
)),
475 SCM_KEYWORD (k_class
, "class");
477 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
480 #define FUNC_NAME s_scm_sys_prep_layout_x
484 SCM nfields
, slots
, type
;
486 SCM_VALIDATE_INSTANCE (1, class);
487 slots
= SCM_SLOT (class, scm_si_slots
);
488 nfields
= SCM_SLOT (class, scm_si_nfields
);
489 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
490 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
491 scm_list_1 (nfields
));
492 n
= 2 * SCM_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 s
= n
> 0 ? scm_must_malloc (n
, FUNC_NAME
) : 0;
499 for (i
= 0; i
< n
; i
+= 2)
501 if (!SCM_CONSP (slots
))
502 SCM_MISC_ERROR ("to few slot definitions", SCM_EOL
);
503 len
= scm_ilength (SCM_CDAR (slots
));
504 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
), len
, SCM_BOOL_F
,
506 if (SCM_NIMP (type
) && SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
508 if (SCM_SUBCLASSP (type
, scm_class_self
))
510 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
515 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
517 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
529 slots
= SCM_CDR (slots
);
531 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
534 return SCM_UNSPECIFIED
;
538 static void prep_hashsets (SCM
);
540 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
541 (SCM
class, SCM dsupers
),
543 #define FUNC_NAME s_scm_sys_inherit_magic_x
547 SCM_VALIDATE_INSTANCE (1, class);
548 while (SCM_NNULLP (ls
))
550 SCM_ASSERT (SCM_CONSP (ls
)
551 && SCM_INSTANCEP (SCM_CAR (ls
)),
555 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
558 flags
&= SCM_CLASSF_INHERIT
;
559 if (flags
& SCM_CLASSF_ENTITY
)
560 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
563 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
566 * We could avoid calling scm_must_malloc in the allocation code
567 * (in which case the following two lines are needed). Instead
568 * we make 0-slot instances non-light, so that the light case
569 * can be handled without special cases.
572 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
574 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
576 /* NOTE: The following depends on scm_struct_i_size. */
577 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
578 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
581 SCM_SET_CLASS_FLAGS (class, flags
);
583 prep_hashsets (class);
585 return SCM_UNSPECIFIED
;
590 prep_hashsets (SCM
class)
594 for (i
= 0; i
< 7; ++i
)
595 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
598 /******************************************************************************/
601 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
603 SCM z
, cpl
, slots
, nfields
, g_n_s
;
605 /* Allocate one instance */
606 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
608 /* Initialize its slots */
610 cpl
= compute_cpl (dsupers
, scm_list_1 (z
));
612 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
613 cpl
= compute_cpl (z
);
614 slots
= build_slots_list (maplist (dslots
), cpl
);
615 nfields
= SCM_MAKINUM (scm_ilength (slots
));
616 g_n_s
= compute_getters_n_setters (slots
);
618 SCM_SET_SLOT (z
, scm_si_name
, name
);
619 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
620 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
621 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
622 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
623 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
624 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
625 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
626 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
627 SCM_SET_SLOT (z
, scm_si_environment
,
628 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
630 /* Add this class in the direct-subclasses slot of dsupers */
633 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
634 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
635 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
636 scm_si_direct_subclasses
)));
639 /* Support for the underlying structs: */
640 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
641 ? (SCM_CLASSF_GOOPS_OR_VALID
642 | SCM_CLASSF_OPERATOR
644 : class == scm_class_operator_class
645 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
646 : SCM_CLASSF_GOOPS_OR_VALID
));
651 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
653 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
654 scm_sys_inherit_magic_x (z
, dsupers
);
655 scm_sys_prep_layout_x (z
);
659 /******************************************************************************/
662 build_class_class_slots ()
665 scm_cons (scm_list_3 (scm_str2symbol ("layout"),
667 scm_class_protected_read_only
),
668 scm_cons (scm_list_3 (scm_str2symbol ("vcell"),
671 scm_cons (scm_list_3 (scm_str2symbol ("vtable"),
674 scm_cons (scm_str2symbol ("print"),
675 scm_cons (scm_list_3 (scm_str2symbol ("procedure"),
677 scm_class_protected_opaque
),
678 scm_cons (scm_list_3 (scm_str2symbol ("setter"),
680 scm_class_protected_opaque
),
681 scm_cons (scm_str2symbol ("redefined"),
682 scm_cons (scm_list_3 (scm_str2symbol ("h0"),
685 scm_cons (scm_list_3 (scm_str2symbol ("h1"),
688 scm_cons (scm_list_3 (scm_str2symbol ("h2"),
691 scm_cons (scm_list_3 (scm_str2symbol ("h3"),
694 scm_cons (scm_list_3 (scm_str2symbol ("h4"),
697 scm_cons (scm_list_3 (scm_str2symbol ("h5"),
700 scm_cons (scm_list_3 (scm_str2symbol ("h6"),
703 scm_cons (scm_list_3 (scm_str2symbol ("h7"),
706 scm_cons (scm_str2symbol ("name"),
707 scm_cons (scm_str2symbol ("direct-supers"),
708 scm_cons (scm_str2symbol ("direct-slots"),
709 scm_cons (scm_str2symbol ("direct-subclasses"),
710 scm_cons (scm_str2symbol ("direct-methods"),
711 scm_cons (scm_str2symbol ("cpl"),
712 scm_cons (scm_str2symbol ("default-slot-definition-class"),
713 scm_cons (scm_str2symbol ("slots"),
714 scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */
715 scm_cons (scm_str2symbol ("keyword-access"),
716 scm_cons (scm_str2symbol ("nfields"),
717 scm_cons (scm_str2symbol ("environment"),
718 SCM_EOL
))))))))))))))))))))))))))));
722 create_basic_classes (void)
724 /* SCM slots_of_class = build_class_class_slots (); */
726 /**** <scm_class_class> ****/
727 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
728 + 2 * scm_vtable_offset_user
);
729 SCM name
= scm_str2symbol ("<class>");
730 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
733 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
734 | SCM_CLASSF_METACLASS
));
736 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
737 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
738 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
739 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
740 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
741 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
742 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
743 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
744 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
745 compute_getters_n_setters (slots_of_class)); */
746 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
747 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
748 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
750 prep_hashsets (scm_class_class
);
752 DEFVAR(name
, scm_class_class
);
754 /**** <scm_class_top> ****/
755 name
= scm_str2symbol ("<top>");
756 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
761 DEFVAR(name
, scm_class_top
);
763 /**** <scm_class_object> ****/
764 name
= scm_str2symbol ("<object>");
765 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
767 scm_list_1 (scm_class_top
),
770 DEFVAR (name
, scm_class_object
);
772 /* <top> <object> and <class> were partially initialized. Correct them here */
773 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
775 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
776 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
779 /******************************************************************************/
781 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
783 "Return @code{#t} if @var{obj} is an instance.")
784 #define FUNC_NAME s_scm_instance_p
786 return SCM_BOOL (SCM_INSTANCEP (obj
));
791 /******************************************************************************
793 * Meta object accessors
795 ******************************************************************************/
796 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
798 "Return the class name of @var{obj}.")
799 #define FUNC_NAME s_scm_class_name
801 SCM_VALIDATE_CLASS (1, obj
);
802 return scm_slot_ref (obj
, scm_str2symbol ("name"));
806 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
808 "Return the direct superclasses of the class @var{obj}.")
809 #define FUNC_NAME s_scm_class_direct_supers
811 SCM_VALIDATE_CLASS (1, obj
);
812 return scm_slot_ref (obj
, scm_str2symbol ("direct-supers"));
816 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
818 "Return the direct slots of the class @var{obj}.")
819 #define FUNC_NAME s_scm_class_direct_slots
821 SCM_VALIDATE_CLASS (1, obj
);
822 return scm_slot_ref (obj
, scm_str2symbol ("direct-slots"));
826 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
828 "Return the direct subclasses of the class @var{obj}.")
829 #define FUNC_NAME s_scm_class_direct_subclasses
831 SCM_VALIDATE_CLASS (1, obj
);
832 return scm_slot_ref(obj
, scm_str2symbol ("direct-subclasses"));
836 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
838 "Return the direct methods of the class @var{obj}")
839 #define FUNC_NAME s_scm_class_direct_methods
841 SCM_VALIDATE_CLASS (1, obj
);
842 return scm_slot_ref (obj
, scm_str2symbol ("direct-methods"));
846 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
848 "Return the class precedence list of the class @var{obj}.")
849 #define FUNC_NAME s_scm_class_precedence_list
851 SCM_VALIDATE_CLASS (1, obj
);
852 return scm_slot_ref (obj
, scm_str2symbol ("cpl"));
856 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
858 "Return the slot list of the class @var{obj}.")
859 #define FUNC_NAME s_scm_class_slots
861 SCM_VALIDATE_CLASS (1, obj
);
862 return scm_slot_ref (obj
, scm_str2symbol ("slots"));
866 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
868 "Return the environment of the class @var{obj}.")
869 #define FUNC_NAME s_scm_class_environment
871 SCM_VALIDATE_CLASS (1, obj
);
872 return scm_slot_ref(obj
, scm_str2symbol ("environment"));
877 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
879 "Return the name of the generic function @var{obj}.")
880 #define FUNC_NAME s_scm_generic_function_name
882 SCM_VALIDATE_GENERIC (1, obj
);
883 return scm_procedure_property (obj
, scm_sym_name
);
887 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
889 "Return the methods of the generic function @var{obj}.")
890 #define FUNC_NAME s_scm_generic_function_methods
892 SCM_VALIDATE_GENERIC (1, obj
);
893 return scm_slot_ref (obj
, scm_str2symbol ("methods"));
898 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
900 "Return the generic function fot the method @var{obj}.")
901 #define FUNC_NAME s_scm_method_generic_function
903 SCM_VALIDATE_METHOD (1, obj
);
904 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
908 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
910 "Return specializers of the method @var{obj}.")
911 #define FUNC_NAME s_scm_method_specializers
913 SCM_VALIDATE_METHOD (1, obj
);
914 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
918 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
920 "Return the procedure of the method @var{obj}.")
921 #define FUNC_NAME s_scm_method_procedure
923 SCM_VALIDATE_METHOD (1, obj
);
924 return scm_slot_ref (obj
, scm_str2symbol ("procedure"));
928 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
930 "Return the slot definition of the accessor @var{obj}.")
931 #define FUNC_NAME s_scm_accessor_method_slot_definition
933 SCM_VALIDATE_ACCESSOR (1, obj
);
934 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
938 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
940 "Internal GOOPS magic---don't use this function!")
941 #define FUNC_NAME s_scm_sys_tag_body
943 return scm_cons (SCM_IM_LAMBDA
, body
);
947 /******************************************************************************
949 * S l o t a c c e s s
951 ******************************************************************************/
953 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
955 "Return the unbound value.")
956 #define FUNC_NAME s_scm_make_unbound
958 return SCM_GOOPS_UNBOUND
;
962 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
964 "Return @code{#t} if @var{obj} is unbound.")
965 #define FUNC_NAME s_scm_unbound_p
967 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
971 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
972 (SCM value
, SCM obj
),
973 "Return @var{value} if it is bound, and invoke the\n"
974 "@var{slot-unbound} method of @var{obj} if it is not.")
975 #define FUNC_NAME s_scm_assert_bound
977 if (SCM_GOOPS_UNBOUNDP (value
))
978 return CALL_GF1 ("slot-unbound", obj
);
983 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
984 (SCM obj
, SCM index
),
985 "Like @code{assert-bound}, but use @var{index} for accessing\n"
986 "the value from @var{obj}.")
987 #define FUNC_NAME s_scm_at_assert_bound_ref
989 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
990 if (SCM_GOOPS_UNBOUNDP (value
))
991 return CALL_GF1 ("slot-unbound", obj
);
996 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
997 (SCM obj
, SCM index
),
998 "Return the slot value with index @var{index} from @var{obj}.")
999 #define FUNC_NAME s_scm_sys_fast_slot_ref
1003 SCM_VALIDATE_INSTANCE (1, obj
);
1004 SCM_VALIDATE_INUM (2, index
);
1005 i
= SCM_INUM (index
);
1007 SCM_ASSERT_RANGE (2, index
, i
>= 0 && i
< SCM_NUMBER_OF_SLOTS (obj
));
1008 return scm_at_assert_bound_ref (obj
, index
);
1012 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1013 (SCM obj
, SCM index
, SCM value
),
1014 "Set the slot with index @var{index} in @var{obj} to\n"
1016 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1020 SCM_VALIDATE_INSTANCE (1, obj
);
1021 SCM_VALIDATE_INUM (2, index
);
1022 i
= SCM_INUM (index
);
1023 SCM_ASSERT_RANGE (2, index
, i
>= 0 && i
< SCM_NUMBER_OF_SLOTS (obj
));
1024 SCM_SET_SLOT (obj
, i
, value
);
1026 return SCM_UNSPECIFIED
;
1033 /* In the future, this function will return the effective slot
1034 * definition associated with SLOT_NAME. Now it just returns some of
1035 * the information which will be stored in the effective slot
1040 slot_definition_using_name (SCM
class, SCM slot_name
)
1042 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1043 for (; SCM_NIMP (slots
); slots
= SCM_CDR (slots
))
1044 if (SCM_CAAR (slots
) == slot_name
)
1045 return SCM_CAR (slots
);
1050 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1052 SCM access
= SCM_CDDR (slotdef
);
1054 * - access is an integer (the offset of this slot in the slots vector)
1055 * - otherwise (car access) is the getter function to apply
1057 if (SCM_INUMP (access
))
1058 return SCM_SLOT (obj
, SCM_INUM (access
));
1061 /* We must evaluate (apply (car access) (list obj))
1062 * where (car access) is known to be a closure of arity 1 */
1063 register SCM code
, env
;
1065 code
= SCM_CAR (access
);
1066 if (!SCM_CLOSUREP (code
))
1067 return SCM_SUBRF (code
) (obj
);
1068 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1071 /* Evaluate the closure body */
1072 return scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1077 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1079 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1080 if (SCM_NFALSEP (slotdef
))
1081 return get_slot_value (class, obj
, slotdef
);
1083 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1087 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1089 SCM access
= SCM_CDDR (slotdef
);
1091 * - access is an integer (the offset of this slot in the slots vector)
1092 * - otherwise (cadr access) is the setter function to apply
1094 if (SCM_INUMP (access
))
1095 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1098 /* We must evaluate (apply (cadr l) (list obj value))
1099 * where (cadr l) is known to be a closure of arity 2 */
1100 register SCM code
, env
;
1102 code
= SCM_CADR (access
);
1103 if (!SCM_CLOSUREP (code
))
1104 SCM_SUBRF (code
) (obj
, value
);
1107 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1108 scm_list_2 (obj
, value
),
1110 /* Evaluate the closure body */
1111 scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1114 return SCM_UNSPECIFIED
;
1118 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1120 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1121 if (SCM_NFALSEP (slotdef
))
1122 return set_slot_value (class, obj
, slotdef
, value
);
1124 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1128 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1132 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1133 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1139 /* ======================================== */
1141 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1142 (SCM
class, SCM obj
, SCM slot_name
),
1144 #define FUNC_NAME s_scm_slot_ref_using_class
1148 SCM_VALIDATE_CLASS (1, class);
1149 SCM_VALIDATE_INSTANCE (2, obj
);
1150 SCM_VALIDATE_SYMBOL (3, slot_name
);
1152 res
= get_slot_value_using_name (class, obj
, slot_name
);
1153 if (SCM_GOOPS_UNBOUNDP (res
))
1154 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1160 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1161 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1163 #define FUNC_NAME s_scm_slot_set_using_class_x
1165 SCM_VALIDATE_CLASS (1, class);
1166 SCM_VALIDATE_INSTANCE (2, obj
);
1167 SCM_VALIDATE_SYMBOL (3, slot_name
);
1169 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1174 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1175 (SCM
class, SCM obj
, SCM slot_name
),
1177 #define FUNC_NAME s_scm_slot_bound_using_class_p
1179 SCM_VALIDATE_CLASS (1, class);
1180 SCM_VALIDATE_INSTANCE (2, obj
);
1181 SCM_VALIDATE_SYMBOL (3, slot_name
);
1183 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1189 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1190 (SCM
class, SCM obj
, SCM slot_name
),
1192 #define FUNC_NAME s_scm_slot_exists_using_class_p
1194 SCM_VALIDATE_CLASS (1, class);
1195 SCM_VALIDATE_INSTANCE (2, obj
);
1196 SCM_VALIDATE_SYMBOL (3, slot_name
);
1197 return test_slot_existence (class, obj
, slot_name
);
1202 /* ======================================== */
1204 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1205 (SCM obj
, SCM slot_name
),
1206 "Return the value from @var{obj}'s slot with the name\n"
1208 #define FUNC_NAME s_scm_slot_ref
1212 SCM_VALIDATE_INSTANCE (1, obj
);
1213 TEST_CHANGE_CLASS (obj
, class);
1215 res
= get_slot_value_using_name (class, obj
, slot_name
);
1216 if (SCM_GOOPS_UNBOUNDP (res
))
1217 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1222 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1223 (SCM obj
, SCM slot_name
, SCM value
),
1224 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1225 #define FUNC_NAME s_scm_slot_set_x
1229 SCM_VALIDATE_INSTANCE (1, obj
);
1230 TEST_CHANGE_CLASS(obj
, class);
1232 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1236 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1238 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1239 (SCM obj
, SCM slot_name
),
1240 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1242 #define FUNC_NAME s_scm_slot_bound_p
1246 SCM_VALIDATE_INSTANCE (1, obj
);
1247 TEST_CHANGE_CLASS(obj
, class);
1249 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1257 SCM_DEFINE (scm_slots_exists_p
, "slot-exists?", 2, 0, 0,
1258 (SCM obj
, SCM slot_name
),
1259 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1260 #define FUNC_NAME s_scm_slots_exists_p
1264 SCM_VALIDATE_INSTANCE (1, obj
);
1265 SCM_VALIDATE_SYMBOL (2, slot_name
);
1266 TEST_CHANGE_CLASS (obj
, class);
1268 return test_slot_existence (class, obj
, slot_name
);
1273 /******************************************************************************
1275 * %allocate-instance (the low level instance allocation primitive)
1277 ******************************************************************************/
1279 static void clear_method_cache (SCM
);
1282 wrap_init (SCM
class, SCM
*m
, long n
)
1287 /* Set all slots to unbound */
1288 for (i
= 0; i
< n
; i
++)
1289 m
[i
] = SCM_GOOPS_UNBOUND
;
1292 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
1293 SCM_SET_CELL_WORD_1 (z
, m
);
1294 SCM_SET_CELL_WORD_0 (z
, (scm_t_bits
) SCM_STRUCT_DATA (class)
1295 | scm_tc3_cons_gloc
);
1300 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1301 (SCM
class, SCM initargs
),
1302 "Create a new instance of class @var{class} and initialize it\n"
1303 "from the arguments @var{initargs}.")
1304 #define FUNC_NAME s_scm_sys_allocate_instance
1309 SCM_VALIDATE_CLASS (1, class);
1311 /* Most instances */
1312 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1314 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1315 m
= (SCM
*) scm_must_malloc (n
* sizeof (SCM
), "instance");
1316 return wrap_init (class, m
, n
);
1319 /* Foreign objects */
1320 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1321 return scm_make_foreign_object (class, initargs
);
1323 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1326 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1328 m
= (SCM
*) scm_alloc_struct (n
,
1329 scm_struct_entity_n_extra_words
,
1331 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1332 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1333 /* Generic functions */
1334 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1336 SCM gf
= wrap_init (class, m
, n
);
1337 clear_method_cache (gf
);
1341 return wrap_init (class, m
, n
);
1345 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1349 /* allocate class object */
1350 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1352 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1353 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1354 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1356 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1357 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1358 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1359 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1364 /* Non-light instances */
1366 m
= (SCM
*) scm_alloc_struct (n
,
1367 scm_struct_n_extra_words
,
1369 return wrap_init (class, m
, n
);
1374 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1375 (SCM obj
, SCM setter
),
1377 #define FUNC_NAME s_scm_sys_set_object_setter_x
1379 SCM_ASSERT (SCM_STRUCTP (obj
)
1380 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1381 || SCM_I_ENTITYP (obj
)),
1385 if (SCM_I_ENTITYP (obj
))
1386 SCM_SET_ENTITY_SETTER (obj
, setter
);
1388 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1389 return SCM_UNSPECIFIED
;
1393 /******************************************************************************
1395 * %modify-instance (used by change-class to modify in place)
1397 ******************************************************************************/
1399 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1402 #define FUNC_NAME s_scm_sys_modify_instance
1404 SCM_VALIDATE_INSTANCE (1, old
);
1405 SCM_VALIDATE_INSTANCE (2, new);
1407 /* Exchange the data contained in old and new. We exchange rather than
1408 * scratch the old value with new to be correct with GC.
1409 * See "Class redefinition protocol above".
1413 SCM car
= SCM_CAR (old
);
1414 SCM cdr
= SCM_CDR (old
);
1415 SCM_SETCAR (old
, SCM_CAR (new));
1416 SCM_SETCDR (old
, SCM_CDR (new));
1417 SCM_SETCAR (new, car
);
1418 SCM_SETCDR (new, cdr
);
1421 return SCM_UNSPECIFIED
;
1425 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1428 #define FUNC_NAME s_scm_sys_modify_class
1430 SCM_VALIDATE_CLASS (1, old
);
1431 SCM_VALIDATE_CLASS (2, new);
1435 SCM car
= SCM_CAR (old
);
1436 SCM cdr
= SCM_CDR (old
);
1437 SCM_SETCAR (old
, SCM_CAR (new));
1438 SCM_SETCDR (old
, SCM_CDR (new));
1439 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1440 SCM_SETCAR (new, car
);
1441 SCM_SETCDR (new, cdr
);
1442 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1445 return SCM_UNSPECIFIED
;
1449 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1452 #define FUNC_NAME s_scm_sys_invalidate_class
1454 SCM_VALIDATE_CLASS (1, class);
1455 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1456 return SCM_UNSPECIFIED
;
1460 /* When instances change class, they finally get a new body, but
1461 * before that, they go through purgatory in hell. Odd as it may
1462 * seem, this data structure saves us from eternal suffering in
1463 * infinite recursions.
1466 static scm_t_bits
**hell
;
1467 static long n_hell
= 1; /* one place for the evil one himself */
1468 static long hell_size
= 4;
1470 static scm_t_mutex hell_mutex
;
1477 for (i
= 1; i
< n_hell
; ++i
)
1478 if (SCM_INST (o
) == hell
[i
])
1484 go_to_hell (void *o
)
1488 scm_mutex_lock (&hell_mutex
);
1490 if (n_hell
== hell_size
)
1492 long new_size
= 2 * hell_size
;
1493 hell
= scm_must_realloc (hell
, hell_size
, new_size
, "hell");
1494 hell_size
= new_size
;
1496 hell
[n_hell
++] = SCM_INST (obj
);
1498 scm_mutex_unlock (&hell_mutex
);
1503 go_to_heaven (void *o
)
1506 scm_mutex_lock (&hell_mutex
);
1508 hell
[burnin ((SCM
) o
)] = hell
[--n_hell
];
1510 scm_mutex_unlock (&hell_mutex
);
1515 purgatory (void *args
)
1517 return scm_apply_0 (GETVAR (scm_str2symbol ("change-class")), (SCM
) args
);
1521 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1524 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1525 (void *) scm_list_2 (obj
, new_class
),
1529 /******************************************************************************
1535 * GGG E N E R I C F U N C T I O N S
1537 * This implementation provides
1538 * - generic functions (with class specializers)
1541 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1543 ******************************************************************************/
1545 SCM_KEYWORD (k_name
, "name");
1547 SCM_SYMBOL (sym_no_method
, "no-method");
1549 static SCM list_of_no_method
;
1551 SCM_SYMBOL (scm_sym_args
, "args");
1554 scm_make_method_cache (SCM gf
)
1556 return scm_list_5 (SCM_IM_DISPATCH
,
1559 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1565 clear_method_cache (SCM gf
)
1567 SCM cache
= scm_make_method_cache (gf
);
1568 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1569 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1572 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1575 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1578 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1579 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1580 if (SCM_NFALSEP (used_by
))
1582 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1583 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1584 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1585 clear_method_cache (gf
);
1586 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1587 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1590 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1591 /* The sign of n is a flag indicating rest args. */
1592 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1594 return SCM_UNSPECIFIED
;
1598 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1601 #define FUNC_NAME s_scm_generic_capability_p
1603 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc
)),
1604 proc
, SCM_ARG1
, FUNC_NAME
);
1605 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1611 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1614 #define FUNC_NAME s_scm_enable_primitive_generic_x
1616 while (SCM_NIMP (subrs
))
1618 SCM subr
= SCM_CAR (subrs
);
1619 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1620 subr
, SCM_ARGn
, FUNC_NAME
);
1621 *SCM_SUBR_GENERIC (subr
)
1622 = scm_make (scm_list_3 (scm_class_generic
,
1625 subrs
= SCM_CDR (subrs
);
1627 return SCM_UNSPECIFIED
;
1631 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1634 #define FUNC_NAME s_scm_primitive_generic_generic
1636 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1638 SCM gf
= *SCM_SUBR_GENERIC (subr
);
1642 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1646 /******************************************************************************
1648 * Protocol for calling a generic fumction
1649 * This protocol is roughly equivalent to (parameter are a little bit different
1650 * for efficiency reasons):
1652 * + apply-generic (gf args)
1653 * + compute-applicable-methods (gf args ...)
1654 * + sort-applicable-methods (methods args)
1655 * + apply-methods (gf methods args)
1657 * apply-methods calls make-next-method to build the "continuation" of a a
1658 * method. Applying a next-method will call apply-next-method which in
1659 * turn will call apply again to call effectively the following method.
1661 ******************************************************************************/
1664 applicablep (SCM actual
, SCM formal
)
1666 /* We already know that the cpl is well formed. */
1667 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1671 more_specificp (SCM m1
, SCM m2
, SCM
*targs
)
1673 register SCM s1
, s2
;
1677 * m1 and m2 can have != length (i.e. one can be one element longer than the
1678 * other when we have a dotted parameter list). For instance, with the call
1681 * (define-method M (a . l) ....)
1682 * (define-method M (a) ....)
1684 * we consider that the second method is more specific.
1686 * BTW, targs is an array of types. We don't need it's size since
1687 * we already know that m1 and m2 are applicable (no risk to go past
1688 * the end of this array).
1691 for (i
=0,s1
=SPEC_OF(m1
),s2
=SPEC_OF(m2
); ; i
++,s1
=SCM_CDR(s1
),s2
=SCM_CDR(s2
)) {
1692 if (SCM_NULLP(s1
)) return 1;
1693 if (SCM_NULLP(s2
)) return 0;
1694 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1695 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1697 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1698 if (cs1
== SCM_CAR(l
))
1700 if (cs2
== SCM_CAR(l
))
1703 return 0;/* should not occur! */
1706 return 0; /* should not occur! */
1709 #define BUFFSIZE 32 /* big enough for most uses */
1712 scm_i_vector2list (SCM l
, long len
)
1715 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1717 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1718 SCM_VELTS (z
)[j
] = SCM_CAR (l
);
1724 sort_applicable_methods (SCM method_list
, long size
, SCM
*targs
)
1727 SCM
*v
, vector
= SCM_EOL
;
1728 SCM buffer
[BUFFSIZE
];
1729 SCM save
= method_list
;
1731 /* For reasonably sized method_lists we can try to avoid all the
1732 * consing and reorder the list in place...
1733 * This idea is due to David McClain <Dave_McClain@msn.com>
1735 if (size
<= BUFFSIZE
)
1737 for (i
= 0; i
< size
; i
++)
1739 buffer
[i
] = SCM_CAR (method_list
);
1740 method_list
= SCM_CDR (method_list
);
1746 /* Too many elements in method_list to keep everything locally */
1747 vector
= scm_i_vector2list (save
, size
);
1748 v
= SCM_VELTS (vector
);
1751 /* Use a simple shell sort since it is generally faster than qsort on
1752 * small vectors (which is probably mostly the case when we have to
1753 * sort a list of applicable methods).
1755 for (incr
= size
/ 2; incr
; incr
/= 2)
1757 for (i
= incr
; i
< size
; i
++)
1759 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1761 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1765 SCM tmp
= v
[j
+ incr
];
1773 if (size
<= BUFFSIZE
)
1775 /* We did it in locally, so restore the original list (reordered) in-place */
1776 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1778 SCM_SETCAR (method_list
, *v
);
1779 method_list
= SCM_CDR (method_list
);
1783 /* If we are here, that's that we did it the hard way... */
1784 return scm_vector_to_list (vector
);
1788 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1792 SCM l
, fl
, applicable
= SCM_EOL
;
1794 SCM buffer
[BUFFSIZE
], *types
, *p
;
1797 /* Build the list of arguments types */
1798 if (len
>= BUFFSIZE
) {
1799 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1800 /* NOTE: Using pointers to malloced memory won't work if we
1801 1. have preemtive threading, and,
1802 2. have a GC which moves objects. */
1803 types
= p
= SCM_VELTS(tmp
);
1808 for ( ; SCM_NNULLP (args
); args
= SCM_CDR (args
))
1809 *p
++ = scm_class_of (SCM_CAR (args
));
1811 /* Build a list of all applicable methods */
1812 for (l
= SCM_SLOT (gf
, scm_si_methods
); SCM_NNULLP (l
); l
= SCM_CDR (l
))
1814 fl
= SPEC_OF (SCM_CAR (l
));
1815 /* Only accept accessors which match exactly in first arg. */
1816 if (SCM_ACCESSORP (SCM_CAR (l
))
1817 && (SCM_IMP (fl
) || types
[0] != SCM_CAR (fl
)))
1819 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1821 if (SCM_INSTANCEP (fl
)
1822 /* We have a dotted argument list */
1823 || (i
>= len
&& SCM_NULLP (fl
)))
1824 { /* both list exhausted */
1825 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1831 || !applicablep (types
[i
], SCM_CAR (fl
)))
1840 CALL_GF2 ("no-applicable-method", gf
, save
);
1841 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1846 : sort_applicable_methods (applicable
, count
, types
));
1850 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1853 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1856 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1857 #define FUNC_NAME s_sys_compute_applicable_methods
1860 SCM_VALIDATE_GENERIC (1, gf
);
1861 n
= scm_ilength (args
);
1862 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1863 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1867 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1868 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
));
1870 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1873 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1874 #define FUNC_NAME s_atslot_ref
1876 SCM x
= SCM_CDR (xorig
);
1877 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1878 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1879 return scm_cons (SCM_IM_SLOT_REF
, x
);
1884 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1887 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1888 #define FUNC_NAME s_atslot_set_x
1890 SCM x
= SCM_CDR (xorig
);
1891 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1892 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1893 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1898 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1900 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1903 scm_m_atdispatch (SCM xorig
, SCM env
)
1904 #define FUNC_NAME s_atdispatch
1906 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1907 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
1909 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
1910 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
1912 n
= SCM_XEVALCAR (x
, env
);
1913 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
1914 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1916 v
= SCM_XEVALCAR (x
, env
);
1917 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
1919 gf
= SCM_XEVALCAR (x
, env
);
1920 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
1921 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1928 lock_cache_mutex (void *m
)
1930 SCM mutex
= (SCM
) m
;
1931 scm_lock_mutex (mutex
);
1935 unlock_cache_mutex (void *m
)
1937 SCM mutex
= (SCM
) m
;
1938 scm_unlock_mutex (mutex
);
1943 call_memoize_method (void *a
)
1946 SCM gf
= SCM_CAR (args
);
1947 SCM x
= SCM_CADR (args
);
1948 /* First check if another thread has inserted a method between
1949 * the cache miss and locking the mutex.
1951 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
1952 if (SCM_NIMP (cmethod
))
1954 /*fixme* Use scm_apply */
1955 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
1959 scm_memoize_method (SCM x
, SCM args
)
1961 SCM gf
= SCM_CAR (scm_last_pair (x
));
1963 return scm_internal_dynamic_wind (lock_cache_mutex
,
1964 call_memoize_method
,
1966 (void *) scm_cons2 (gf
, x
, args
),
1967 (void *) SCM_SLOT (gf
, scm_si_cache_mutex
));
1969 return call_memoize_method ((void *) scm_cons2 (gf
, x
, args
));
1973 /******************************************************************************
1975 * A simple make (which will be redefined later in Scheme)
1976 * This version handles only creation of gf, methods and classes (no instances)
1978 * Since this code will disappear when Goops will be fully booted,
1979 * no precaution is taken to be efficient.
1981 ******************************************************************************/
1983 SCM_KEYWORD (k_setter
, "setter");
1984 SCM_KEYWORD (k_specializers
, "specializers");
1985 SCM_KEYWORD (k_procedure
, "procedure");
1986 SCM_KEYWORD (k_dsupers
, "dsupers");
1987 SCM_KEYWORD (k_slots
, "slots");
1988 SCM_KEYWORD (k_gf
, "generic-function");
1990 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
1992 "Make a new object. @var{args} must contain the class and\n"
1993 "all necessary initialization information.")
1994 #define FUNC_NAME s_scm_make
1997 long len
= scm_ilength (args
);
1999 if (len
<= 0 || (len
& 1) == 0)
2000 SCM_WRONG_NUM_ARGS ();
2002 class = SCM_CAR(args
);
2003 args
= SCM_CDR(args
);
2005 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
2008 z
= scm_make_struct (class, SCM_INUM0
,
2009 scm_list_4 (SCM_EOL
,
2012 scm_make_mutex ()));
2014 z
= scm_make_struct (class, SCM_INUM0
,
2015 scm_list_3 (SCM_EOL
, SCM_INUM0
, SCM_BOOL_F
));
2017 scm_set_procedure_property_x (z
, scm_sym_name
,
2018 scm_get_keyword (k_name
,
2021 clear_method_cache (z
);
2022 if (class == scm_class_generic_with_setter
)
2024 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2025 if (SCM_NIMP (setter
))
2026 scm_sys_set_object_setter_x (z
, setter
);
2031 z
= scm_sys_allocate_instance (class, args
);
2033 if (class == scm_class_method
2034 || class == scm_class_simple_method
2035 || class == scm_class_accessor
)
2037 SCM_SET_SLOT (z
, scm_si_generic_function
,
2038 scm_i_get_keyword (k_gf
,
2043 SCM_SET_SLOT (z
, scm_si_specializers
,
2044 scm_i_get_keyword (k_specializers
,
2049 SCM_SET_SLOT (z
, scm_si_procedure
,
2050 scm_i_get_keyword (k_procedure
,
2055 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2059 /* In all the others case, make a new class .... No instance here */
2060 SCM_SET_SLOT (z
, scm_si_name
,
2061 scm_i_get_keyword (k_name
,
2064 scm_str2symbol ("???"),
2066 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2067 scm_i_get_keyword (k_dsupers
,
2072 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2073 scm_i_get_keyword (k_slots
,
2084 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2087 #define FUNC_NAME s_scm_find_method
2090 long len
= scm_ilength (l
);
2093 SCM_WRONG_NUM_ARGS ();
2095 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2096 SCM_VALIDATE_GENERIC (1, gf
);
2097 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2098 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2100 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2104 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2105 (SCM m1
, SCM m2
, SCM targs
),
2107 #define FUNC_NAME s_scm_sys_method_more_specific_p
2112 SCM_VALIDATE_METHOD (1, m1
);
2113 SCM_VALIDATE_METHOD (2, m2
);
2114 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2116 /* Verify that all the arguments of targs are classes and place them in a vector*/
2117 v
= scm_c_make_vector (len
, SCM_EOL
);
2119 for (i
=0, l
=targs
; SCM_NNULLP(l
); i
++, l
=SCM_CDR(l
)) {
2120 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2121 SCM_VELTS(v
)[i
] = SCM_CAR(l
);
2123 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2129 /******************************************************************************
2133 ******************************************************************************/
2137 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2139 SCM tmp
= scm_str2symbol (name
);
2141 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2145 : scm_list_1 (super
),
2151 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2154 create_standard_classes (void)
2157 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2158 scm_str2symbol ("specializers"),
2159 scm_str2symbol ("procedure"),
2160 scm_str2symbol ("code-table"));
2161 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2163 k_slot_definition
));
2165 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2167 SCM mutex_slot
= SCM_BOOL_F
;
2169 SCM gf_slots
= scm_list_4 (scm_str2symbol ("methods"),
2170 scm_list_3 (scm_str2symbol ("n-specialized"),
2173 scm_list_3 (scm_str2symbol ("used-by"),
2176 scm_list_3 (scm_str2symbol ("cache-mutex"),
2178 scm_closure (scm_list_2 (SCM_EOL
,
2182 /* Foreign class slot classes */
2183 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2184 scm_class_class
, scm_class_top
, SCM_EOL
);
2185 make_stdcls (&scm_class_protected
, "<protected-slot>",
2186 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2187 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2188 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2189 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2190 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2191 make_stdcls (&scm_class_self
, "<self-slot>",
2193 scm_list_2 (scm_class_foreign_slot
, scm_class_read_only
),
2195 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2197 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2199 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2201 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2203 make_stdcls (&scm_class_scm
, "<scm-slot>",
2204 scm_class_class
, scm_class_protected
, SCM_EOL
);
2205 make_stdcls (&scm_class_int
, "<int-slot>",
2206 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2207 make_stdcls (&scm_class_float
, "<float-slot>",
2208 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2209 make_stdcls (&scm_class_double
, "<double-slot>",
2210 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2212 /* Continue initialization of class <class> */
2214 slots
= build_class_class_slots ();
2215 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2216 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2217 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2218 compute_getters_n_setters (slots
));
2220 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2221 scm_class_class
, scm_class_class
,
2222 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2225 scm_list_3 (scm_str2symbol ("destructor"),
2227 scm_class_opaque
)));
2228 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2229 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2230 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2232 /* scm_class_generic functions classes */
2233 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2234 scm_class_class
, scm_class_class
, SCM_EOL
);
2235 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2236 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2237 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2238 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2239 make_stdcls (&scm_class_operator_with_setter_class
,
2240 "<operator-with-setter-class>",
2241 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2242 make_stdcls (&scm_class_method
, "<method>",
2243 scm_class_class
, scm_class_object
, method_slots
);
2244 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2245 scm_class_class
, scm_class_method
, SCM_EOL
);
2246 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2247 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2248 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2249 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2250 make_stdcls (&scm_class_entity
, "<entity>",
2251 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2252 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2253 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2254 make_stdcls (&scm_class_generic
, "<generic>",
2255 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2256 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2257 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2258 scm_class_entity_class
,
2259 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2262 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2263 SCM_SET_SLOT (scm_class_generic_with_setter
, scm_si_cpl
,
2264 scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter
,
2266 SCM_SLOT (scm_class_entity_with_setter
,
2270 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2272 /* Primitive types classes */
2273 make_stdcls (&scm_class_boolean
, "<boolean>",
2274 scm_class_class
, scm_class_top
, SCM_EOL
);
2275 make_stdcls (&scm_class_char
, "<char>",
2276 scm_class_class
, scm_class_top
, SCM_EOL
);
2277 make_stdcls (&scm_class_list
, "<list>",
2278 scm_class_class
, scm_class_top
, SCM_EOL
);
2279 make_stdcls (&scm_class_pair
, "<pair>",
2280 scm_class_class
, scm_class_list
, SCM_EOL
);
2281 make_stdcls (&scm_class_null
, "<null>",
2282 scm_class_class
, scm_class_list
, SCM_EOL
);
2283 make_stdcls (&scm_class_string
, "<string>",
2284 scm_class_class
, scm_class_top
, SCM_EOL
);
2285 make_stdcls (&scm_class_symbol
, "<symbol>",
2286 scm_class_class
, scm_class_top
, SCM_EOL
);
2287 make_stdcls (&scm_class_vector
, "<vector>",
2288 scm_class_class
, scm_class_top
, SCM_EOL
);
2289 make_stdcls (&scm_class_number
, "<number>",
2290 scm_class_class
, scm_class_top
, SCM_EOL
);
2291 make_stdcls (&scm_class_complex
, "<complex>",
2292 scm_class_class
, scm_class_number
, SCM_EOL
);
2293 make_stdcls (&scm_class_real
, "<real>",
2294 scm_class_class
, scm_class_complex
, SCM_EOL
);
2295 make_stdcls (&scm_class_integer
, "<integer>",
2296 scm_class_class
, scm_class_real
, SCM_EOL
);
2297 make_stdcls (&scm_class_keyword
, "<keyword>",
2298 scm_class_class
, scm_class_top
, SCM_EOL
);
2299 make_stdcls (&scm_class_unknown
, "<unknown>",
2300 scm_class_class
, scm_class_top
, SCM_EOL
);
2301 make_stdcls (&scm_class_procedure
, "<procedure>",
2302 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2303 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2304 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2305 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2306 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2307 make_stdcls (&scm_class_port
, "<port>",
2308 scm_class_class
, scm_class_top
, SCM_EOL
);
2309 make_stdcls (&scm_class_input_port
, "<input-port>",
2310 scm_class_class
, scm_class_port
, SCM_EOL
);
2311 make_stdcls (&scm_class_output_port
, "<output-port>",
2312 scm_class_class
, scm_class_port
, SCM_EOL
);
2313 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2315 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2319 /**********************************************************************
2323 **********************************************************************/
2326 make_class_from_template (char *template, char *type_name
, SCM supers
)
2332 sprintf (buffer
, template, type_name
);
2333 name
= scm_str2symbol (buffer
);
2336 name
= SCM_GOOPS_UNBOUND
;
2338 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2343 /* Only define name if doesn't already exist. */
2344 if (!SCM_GOOPS_UNBOUNDP (name
)
2345 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2346 DEFVAR (name
, class);
2351 scm_make_extended_class (char *type_name
)
2353 return make_class_from_template ("<%s>",
2355 scm_list_1 (scm_class_top
));
2359 create_smob_classes (void)
2363 scm_smob_class
= (SCM
*) malloc (255 * sizeof (SCM
));
2364 for (i
= 0; i
< 255; ++i
)
2365 scm_smob_class
[i
] = 0;
2367 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2368 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2369 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2370 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2372 for (i
= 0; i
< scm_numsmob
; ++i
)
2373 if (!scm_smob_class
[i
])
2374 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2378 scm_make_port_classes (long ptobnum
, char *type_name
)
2380 SCM c
, class = make_class_from_template ("<%s-port>",
2382 scm_list_1 (scm_class_port
));
2383 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2384 = make_class_from_template ("<%s-input-port>",
2386 scm_list_2 (class, scm_class_input_port
));
2387 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2388 = make_class_from_template ("<%s-output-port>",
2390 scm_list_2 (class, scm_class_output_port
));
2391 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2393 = make_class_from_template ("<%s-input-output-port>",
2395 scm_list_2 (class, scm_class_input_output_port
));
2396 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2397 SCM_SET_SLOT (c
, scm_si_cpl
,
2398 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2402 create_port_classes (void)
2406 scm_port_class
= (SCM
*) malloc (3 * 256 * sizeof (SCM
));
2407 for (i
= 0; i
< 3 * 256; ++i
)
2408 scm_port_class
[i
] = 0;
2410 for (i
= 0; i
< scm_numptob
; ++i
)
2411 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2415 make_struct_class (void *closure SCM_UNUSED
, SCM key SCM_UNUSED
,
2416 SCM data
, SCM prev SCM_UNUSED
)
2418 if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2419 SCM_SET_STRUCT_TABLE_CLASS (data
,
2420 scm_make_extended_class
2421 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2422 return SCM_UNSPECIFIED
;
2426 create_struct_classes (void)
2428 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2431 /**********************************************************************
2435 **********************************************************************/
2440 if (!goops_loaded_p
)
2441 scm_c_resolve_module ("oop goops");
2446 scm_make_foreign_object (SCM
class, SCM initargs
)
2447 #define FUNC_NAME s_scm_make
2449 void * (*constructor
) (SCM
)
2450 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2451 if (constructor
== 0)
2452 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2453 return scm_wrap_object (class, constructor (initargs
));
2459 scm_free_foreign_object (SCM
*class, SCM
*data
)
2461 size_t (*destructor
) (void *)
2462 = (size_t (*) (void *)) class[scm_si_destructor
];
2463 return destructor (data
);
2467 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2468 void * (*constructor
) (SCM initargs
),
2469 size_t (*destructor
) (void *))
2472 name
= scm_str2symbol (s_name
);
2473 if (SCM_IMP (supers
))
2474 supers
= scm_list_1 (scm_class_foreign_object
);
2475 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2476 scm_sys_inherit_magic_x (class, supers
);
2478 if (destructor
!= 0)
2480 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2481 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2485 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2486 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2489 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2490 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2495 SCM_SYMBOL (sym_o
, "o");
2496 SCM_SYMBOL (sym_x
, "x");
2498 SCM_KEYWORD (k_accessor
, "accessor");
2499 SCM_KEYWORD (k_getter
, "getter");
2502 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2504 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2509 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2510 SCM (*getter
) (SCM obj
),
2511 SCM (*setter
) (SCM obj
, SCM x
),
2512 char *accessor_name
)
2515 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2516 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2517 setter
? setter
: default_setter
);
2518 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2519 scm_list_2 (get
, sym_o
)),
2521 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2522 scm_list_3 (set
, sym_o
, sym_x
)),
2525 SCM name
= scm_str2symbol (slot_name
);
2526 SCM aname
= scm_str2symbol (accessor_name
);
2527 SCM gf
= scm_ensure_accessor (aname
);
2528 SCM slot
= scm_list_5 (name
,
2531 setter
? k_accessor
: k_getter
,
2533 SCM gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2535 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor
,
2540 scm_add_method (scm_setter (gf
),
2541 scm_make (scm_list_5 (scm_class_accessor
,
2543 scm_list_2 (class, scm_class_top
),
2548 SCM_SET_SLOT (class, scm_si_slots
,
2549 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2550 scm_list_1 (slot
))));
2551 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2552 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2553 scm_list_1 (gns
))));
2557 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2559 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2564 scm_wrap_object (SCM
class, void *data
)
2568 SCM_SETCDR (z
, (SCM
) data
);
2569 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
2570 SCM_SETCAR (z
, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc
);
2577 scm_wrap_component (SCM
class, SCM container
, void *data
)
2579 SCM obj
= scm_wrap_object (class, data
);
2580 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2586 SCM_SETCDR (handle
, container
);
2591 scm_ensure_accessor (SCM name
)
2593 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2594 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2596 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2597 gf
= scm_make (scm_list_5 (scm_class_generic_with_setter
,
2598 k_name
, name
, k_setter
, gf
));
2603 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2606 scm_add_method (SCM gf
, SCM m
)
2608 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2613 * Debugging utilities
2616 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2618 "Return @code{#t} if @var{obj} is a pure generic.")
2619 #define FUNC_NAME s_scm_pure_generic_p
2621 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2625 #endif /* GUILE_DEBUG */
2631 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2633 "Announce that GOOPS is loaded and perform initialization\n"
2634 "on the C level which depends on the loaded GOOPS modules.")
2635 #define FUNC_NAME s_scm_sys_goops_loaded
2638 var_compute_applicable_methods
=
2639 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2641 return SCM_UNSPECIFIED
;
2645 SCM scm_module_goops
;
2648 scm_init_goops_builtins (void)
2650 scm_module_goops
= scm_current_module ();
2651 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2653 /* Not really necessary right now, but who knows...
2655 scm_permanent_object (scm_module_goops
);
2656 scm_permanent_object (scm_goops_lookup_closure
);
2658 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2659 (SCM_MAKINUM (37)));
2661 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2663 #ifndef SCM_MAGIC_SNARFER
2664 #include "libguile/goops.x"
2667 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2669 hell
= scm_must_malloc (hell_size
, "hell");
2671 scm_mutex_init (&hell_mutex
);
2674 create_basic_classes ();
2675 create_standard_classes ();
2676 create_smob_classes ();
2677 create_struct_classes ();
2678 create_port_classes ();
2681 SCM name
= scm_str2symbol ("no-applicable-method");
2682 scm_no_applicable_method
2683 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2686 DEFVAR (name
, scm_no_applicable_method
);
2689 return SCM_UNSPECIFIED
;
2695 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2696 scm_init_goops_builtins
);