1 /* Copyright (C) 1998, 1999, 2000 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/smob.h"
67 #include "libguile/strings.h"
68 #include "libguile/strports.h"
69 #include "libguile/vectors.h"
70 #include "libguile/weaks.h"
72 #include "libguile/validate.h"
73 #include "libguile/goops.h"
75 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
77 #define DEFVAR(v,val) \
78 { scm_i_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \
79 scm_top_level_env (scm_goops_lookup_closure)); }
80 /* Temporary hack until we get the new module system */
81 /*fixme* Should optimize by keeping track of the variable object itself */
82 #define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \
83 SCM_LIST2 ((v), SCM_BOOL_F), \
86 /* Fixme: Should use already interned symbols */
87 #define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \
88 SCM_LIST1 (a), SCM_EOL))
89 #define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \
90 SCM_LIST2 (a, b), SCM_EOL))
91 #define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \
92 SCM_LIST3 (a, b, c), SCM_EOL))
93 #define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \
94 SCM_LIST4 (a, b, c, d), SCM_EOL))
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 #define SCM_CLASS_REDEF(c) SCM_SLOT (c, scm_si_redefined)
115 /* The following definition is located in libguile/objects.h:
116 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
119 #define TEST_CHANGE_CLASS(obj, class) \
121 class = SCM_CLASS_OF (obj); \
122 if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
123 CALL_GF3 ("change-object-class", \
124 obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
127 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
128 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
130 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
131 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
133 static int goops_loaded_p
= 0;
134 static scm_rstate
*goops_rstate
;
136 static SCM scm_goops_lookup_closure
;
138 /* Some classes are defined in libguile/objects.c. */
139 SCM scm_class_top
, scm_class_object
, scm_class_class
;
140 SCM scm_class_entity
, scm_class_entity_with_setter
;
141 SCM scm_class_generic
, scm_class_generic_with_setter
, scm_class_method
;
142 SCM scm_class_simple_method
, scm_class_accessor
;
143 SCM scm_class_procedure_class
;
144 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
145 SCM scm_class_entity_class
;
146 SCM scm_class_number
, scm_class_list
;
147 SCM scm_class_keyword
;
148 SCM scm_class_port
, scm_class_input_output_port
;
149 SCM scm_class_input_port
, scm_class_output_port
;
150 SCM scm_class_foreign_class
, scm_class_foreign_object
;
151 SCM scm_class_foreign_slot
;
152 SCM scm_class_self
, scm_class_protected
;
153 SCM scm_class_opaque
, scm_class_read_only
;
154 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
156 SCM scm_class_int
, scm_class_float
, scm_class_double
;
158 SCM_SYMBOL (scm_sym_define_public
, "define-public");
160 static SCM
scm_make_unbound (void);
161 static SCM
scm_unbound_p (SCM obj
);
162 static SCM
scm_assert_bound (SCM value
, SCM obj
);
163 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
164 static SCM
scm_sys_goops_loaded (void);
166 /******************************************************************************
170 * This version doesn't handle multiple-inheritance. It serves only for
171 * booting classes and will be overaloaded in Scheme
173 ******************************************************************************/
177 compute_cpl (SCM supers
, SCM res
)
179 return (SCM_NULLP (supers
)
181 : compute_cpl (SCM_SLOT (SCM_CAR (supers
), scm_si_direct_supers
),
182 scm_cons (SCM_CAR (supers
), res
)));
187 map (SCM (*proc
) (SCM
), SCM ls
)
192 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
195 while (SCM_NIMP (ls
))
197 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
209 while (SCM_NIMP (ls
))
211 SCM el
= SCM_CAR (ls
);
212 if (SCM_FALSEP (scm_c_memq (el
, res
)))
213 res
= scm_cons (el
, res
);
220 compute_cpl (SCM
class)
223 return CALL_GF1 ("compute-cpl", class);
226 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
227 SCM ls
= scm_append (scm_acons (class, supers
,
228 map (compute_cpl
, supers
)));
229 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
233 /******************************************************************************
237 ******************************************************************************/
240 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
248 if (!SCM_SYMBOLP (tmp
))
249 scm_misc_error ("%compute-slots", "bad slot name ~S", SCM_LIST1 (tmp
));
251 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
252 res
= scm_cons (SCM_CAR (l
), res
);
253 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
256 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
260 build_slots_list (SCM dslots
, SCM cpl
)
262 register SCM res
= dslots
;
264 for (cpl
= SCM_CDR(cpl
); SCM_NNULLP(cpl
); cpl
= SCM_CDR(cpl
))
265 res
= scm_append (SCM_LIST2 (SCM_SLOT (SCM_CAR (cpl
), 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\n"
289 "to class CLASS, i. e. the slots of CLASS and of all of its\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 overaloaded 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_LIST2 (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
, int 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_LIST1 (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 KEY from the\n"
371 "list L. The list L has to consist of an even number of\n"
372 "elements, where, starting with the first, every second element\n"
373 "is a keyword, followed by its associated value. If L does not\n"
374 "hold a value for KEY, the value DEFAULT_VALUE is returned.")
375 #define FUNC_NAME s_scm_get_keyword
379 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
380 len
= scm_ilength (l
);
381 if (len
< 0 || len
% 2 == 1)
382 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", SCM_LIST1 (l
));
384 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
389 SCM_KEYWORD (k_init_keyword
, "init-keyword");
391 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
392 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
394 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
395 (SCM obj
, SCM initargs
),
396 "Initialize the object @var{obj} with the given arguments\n"
398 #define FUNC_NAME s_scm_sys_initialize_object
400 SCM tmp
, get_n_set
, slots
;
401 SCM
class = SCM_CLASS_OF (obj
);
404 SCM_VALIDATE_INSTANCE (1, obj
);
405 n_initargs
= scm_ilength (initargs
);
406 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
408 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
409 slots
= SCM_SLOT (class, scm_si_slots
);
411 /* See for each slot how it must be initialized */
414 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
416 SCM slot_name
= SCM_CAR (slots
);
419 if (SCM_NIMP (SCM_CDR (slot_name
)))
421 /* This slot admits (perhaps) to be initialized at creation time */
422 int n
= scm_ilength (SCM_CDR (slot_name
));
423 if (n
& 1) /* odd or -1 */
424 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
425 SCM_LIST1 (slot_name
));
426 tmp
= scm_i_get_keyword (k_init_keyword
,
431 slot_name
= SCM_CAR (slot_name
);
434 /* an initarg was provided for this slot */
435 if (!SCM_KEYWORDP (tmp
))
436 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
438 slot_value
= scm_i_get_keyword (tmp
,
447 /* set slot to provided value */
448 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
451 /* set slot to its :init-form if it exists */
452 tmp
= SCM_CADAR (get_n_set
);
453 if (tmp
!= SCM_BOOL_F
)
455 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
456 if (SCM_GOOPS_UNBOUNDP (slot_value
))
458 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
459 set_slot_value (class,
462 scm_eval_body (SCM_CDR (SCM_CODE (tmp
)),
474 SCM_KEYWORD (k_class
, "class");
476 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
479 #define FUNC_NAME s_scm_sys_prep_layout_x
483 SCM nfields
, slots
, type
;
485 SCM_VALIDATE_INSTANCE (1, class);
486 slots
= SCM_SLOT (class, scm_si_slots
);
487 nfields
= SCM_SLOT (class, scm_si_nfields
);
488 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
489 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
490 SCM_LIST1 (nfields
));
491 n
= 2 * SCM_INUM (nfields
);
492 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
493 && SCM_SUBCLASSP (class, scm_class_class
))
494 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
495 SCM_LIST1 (nfields
));
497 s
= n
> 0 ? scm_must_malloc (n
, FUNC_NAME
) : 0;
498 for (i
= 0; i
< n
; i
+= 2)
500 if (!SCM_CONSP (slots
))
501 SCM_MISC_ERROR ("to few slot definitions", SCM_EOL
);
502 len
= scm_ilength (SCM_CDAR (slots
));
503 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
), len
, SCM_BOOL_F
,
505 if (SCM_NIMP (type
) && SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
507 if (SCM_SUBCLASSP (type
, scm_class_self
))
509 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
514 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
516 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
528 slots
= SCM_CDR (slots
);
530 SCM_SLOT (class, scm_si_layout
) = scm_mem2symbol (s
, n
);
533 return SCM_UNSPECIFIED
;
537 static void prep_hashsets (SCM
);
539 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
540 (SCM
class, SCM dsupers
),
542 #define FUNC_NAME s_scm_sys_inherit_magic_x
546 SCM_VALIDATE_INSTANCE (1, class);
547 while (SCM_NNULLP (ls
))
549 SCM_ASSERT (SCM_CONSP (ls
)
550 && SCM_INSTANCEP (SCM_CAR (ls
)),
554 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
557 flags
&= SCM_CLASSF_INHERIT
;
558 if (flags
& SCM_CLASSF_ENTITY
)
559 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
562 int n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
565 * We could avoid calling scm_must_malloc in the allocation code
566 * (in which case the following two lines are needed). Instead
567 * we make 0-slot instances non-light, so that the light case
568 * can be handled without special cases.
571 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
573 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
575 /* NOTE: The following depends on scm_struct_i_size. */
576 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
577 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
580 SCM_SET_CLASS_FLAGS (class, flags
);
582 prep_hashsets (class);
584 return SCM_UNSPECIFIED
;
589 prep_hashsets (SCM
class)
593 for (i
= 0; i
< 7; ++i
)
594 SCM_SLOT (class, scm_si_hashsets
+ i
)
595 = SCM_PACK (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_LIST1(z
));
612 SCM_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_SLOT(z
, scm_si_name
) = name
;
619 SCM_SLOT(z
, scm_si_direct_slots
) = dslots
;
620 SCM_SLOT(z
, scm_si_direct_subclasses
) = SCM_EOL
;
621 SCM_SLOT(z
, scm_si_direct_methods
) = SCM_EOL
;
622 SCM_SLOT(z
, scm_si_cpl
) = cpl
;
623 SCM_SLOT(z
, scm_si_slots
) = slots
;
624 SCM_SLOT(z
, scm_si_nfields
) = nfields
;
625 SCM_SLOT(z
, scm_si_getters_n_setters
) = g_n_s
;
626 SCM_SLOT(z
, scm_si_redefined
) = SCM_BOOL_F
;
627 SCM_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_NNULLP(tmp
); tmp
= SCM_CDR(tmp
))
634 SCM_SLOT(SCM_CAR(tmp
), scm_si_direct_subclasses
)
635 = scm_cons(z
, SCM_SLOT(SCM_CAR(tmp
), scm_si_direct_subclasses
));
638 /* Support for the underlying structs: */
639 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
640 ? (SCM_CLASSF_GOOPS_OR_VALID
641 | SCM_CLASSF_OPERATOR
643 : class == scm_class_operator_class
644 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
645 : SCM_CLASSF_GOOPS_OR_VALID
));
650 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
652 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
653 scm_sys_inherit_magic_x (z
, dsupers
);
654 scm_sys_prep_layout_x (z
);
658 /******************************************************************************/
661 build_class_class_slots ()
664 scm_cons (SCM_LIST3 (scm_str2symbol ("layout"),
666 scm_class_protected_read_only
),
667 scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"),
670 scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"),
673 scm_cons (scm_str2symbol ("print"),
674 scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"),
676 scm_class_protected_opaque
),
677 scm_cons (SCM_LIST3 (scm_str2symbol ("setter"),
679 scm_class_protected_opaque
),
680 scm_cons (scm_str2symbol ("redefined"),
681 scm_cons (SCM_LIST3 (scm_str2symbol ("h0"),
684 scm_cons (SCM_LIST3 (scm_str2symbol ("h1"),
687 scm_cons (SCM_LIST3 (scm_str2symbol ("h2"),
690 scm_cons (SCM_LIST3 (scm_str2symbol ("h3"),
693 scm_cons (SCM_LIST3 (scm_str2symbol ("h4"),
696 scm_cons (SCM_LIST3 (scm_str2symbol ("h5"),
699 scm_cons (SCM_LIST3 (scm_str2symbol ("h6"),
702 scm_cons (SCM_LIST3 (scm_str2symbol ("h7"),
705 scm_cons (scm_str2symbol ("name"),
706 scm_cons (scm_str2symbol ("direct-supers"),
707 scm_cons (scm_str2symbol ("direct-slots"),
708 scm_cons (scm_str2symbol ("direct-subclasses"),
709 scm_cons (scm_str2symbol ("direct-methods"),
710 scm_cons (scm_str2symbol ("cpl"),
711 scm_cons (scm_str2symbol ("default-slot-definition-class"),
712 scm_cons (scm_str2symbol ("slots"),
713 scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */
714 scm_cons (scm_str2symbol ("keyword-access"),
715 scm_cons (scm_str2symbol ("nfields"),
716 scm_cons (scm_str2symbol ("environment"),
717 SCM_EOL
))))))))))))))))))))))))))));
721 create_basic_classes (void)
723 /* SCM slots_of_class = build_class_class_slots (); */
725 /**** <scm_class_class> ****/
726 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
727 + 2 * scm_vtable_offset_user
);
728 SCM name
= scm_str2symbol ("<class>");
729 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
732 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
733 | SCM_CLASSF_METACLASS
));
735 SCM_SLOT(scm_class_class
, scm_si_name
) = name
;
736 SCM_SLOT(scm_class_class
, scm_si_direct_supers
) = SCM_EOL
; /* will be changed */
737 /* SCM_SLOT(scm_class_class, scm_si_direct_slots) = slots_of_class; */
738 SCM_SLOT(scm_class_class
, scm_si_direct_subclasses
)= SCM_EOL
;
739 SCM_SLOT(scm_class_class
, scm_si_direct_methods
) = SCM_EOL
;
740 SCM_SLOT(scm_class_class
, scm_si_cpl
) = SCM_EOL
; /* will be changed */
741 /* SCM_SLOT(scm_class_class, scm_si_slots) = slots_of_class; */
742 SCM_SLOT(scm_class_class
, scm_si_nfields
) = SCM_MAKINUM (SCM_N_CLASS_SLOTS
);
743 /* SCM_SLOT(scm_class_class, scm_si_getters_n_setters)
744 = compute_getters_n_setters (slots_of_class); */
745 SCM_SLOT(scm_class_class
, scm_si_redefined
) = SCM_BOOL_F
;
746 SCM_SLOT(scm_class_class
, scm_si_environment
)
747 = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
);
749 prep_hashsets (scm_class_class
);
751 DEFVAR(name
, scm_class_class
);
753 /**** <scm_class_top> ****/
754 name
= scm_str2symbol ("<top>");
755 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
760 DEFVAR(name
, scm_class_top
);
762 /**** <scm_class_object> ****/
763 name
= scm_str2symbol ("<object>");
764 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
766 SCM_LIST1 (scm_class_top
),
769 DEFVAR (name
, scm_class_object
);
771 /* <top> <object> and <class> were partially initialized. Correct them here */
772 SCM_SLOT (scm_class_object
, scm_si_direct_subclasses
) = SCM_LIST1 (scm_class_class
);
774 SCM_SLOT (scm_class_class
, scm_si_direct_supers
) = SCM_LIST1 (scm_class_object
);
775 SCM_SLOT (scm_class_class
, scm_si_cpl
) = SCM_LIST3 (scm_class_class
, scm_class_object
, scm_class_top
);
778 /******************************************************************************/
780 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
782 "Return @code{#t} if @var{obj} is an instance.")
783 #define FUNC_NAME s_scm_instance_p
785 return SCM_BOOL (SCM_INSTANCEP (obj
));
790 /******************************************************************************
792 * Meta object accessors
794 ******************************************************************************/
795 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
797 "Return the class name of @var{obj}.")
798 #define FUNC_NAME s_scm_class_name
800 SCM_VALIDATE_CLASS (1, obj
);
801 return scm_slot_ref (obj
, scm_str2symbol ("name"));
805 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
807 "Return the direct superclasses of the class @var{obj}.")
808 #define FUNC_NAME s_scm_class_direct_supers
810 SCM_VALIDATE_CLASS (1, obj
);
811 return scm_slot_ref (obj
, scm_str2symbol ("direct-supers"));
815 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
817 "Return the direct slots of the class @var{obj}.")
818 #define FUNC_NAME s_scm_class_direct_slots
820 SCM_VALIDATE_CLASS (1, obj
);
821 return scm_slot_ref (obj
, scm_str2symbol ("direct-slots"));
825 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
827 "Return the direct subclasses of the class @var{obj}.")
828 #define FUNC_NAME s_scm_class_direct_subclasses
830 SCM_VALIDATE_CLASS (1, obj
);
831 return scm_slot_ref(obj
, scm_str2symbol ("direct-subclasses"));
835 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
837 "Return the direct methods of the class @var{obj}")
838 #define FUNC_NAME s_scm_class_direct_methods
840 SCM_VALIDATE_CLASS (1, obj
);
841 return scm_slot_ref (obj
, scm_str2symbol ("direct-methods"));
845 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
847 "Return the class precedence list of the class @var{obj}.")
848 #define FUNC_NAME s_scm_class_precedence_list
850 SCM_VALIDATE_CLASS (1, obj
);
851 return scm_slot_ref (obj
, scm_str2symbol ("cpl"));
855 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
857 "Return the slot list of the class @var{obj}.")
858 #define FUNC_NAME s_scm_class_slots
860 SCM_VALIDATE_CLASS (1, obj
);
861 return scm_slot_ref (obj
, scm_str2symbol ("slots"));
865 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
867 "Return the environment of the class @var{obj}.")
868 #define FUNC_NAME s_scm_class_environment
870 SCM_VALIDATE_CLASS (1, obj
);
871 return scm_slot_ref(obj
, scm_str2symbol ("environment"));
876 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
878 "Return the name of the generic function @var{obj}.")
879 #define FUNC_NAME s_scm_generic_function_name
881 SCM_VALIDATE_GENERIC (1, obj
);
882 return scm_procedure_property (obj
, scm_sym_name
);
886 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
888 "Return the methods of the generic function @var{obj}.")
889 #define FUNC_NAME s_scm_generic_function_methods
891 SCM_VALIDATE_GENERIC (1, obj
);
892 return scm_slot_ref (obj
, scm_str2symbol ("methods"));
897 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
899 "Return the generic function fot the method @var{obj}.")
900 #define FUNC_NAME s_scm_method_generic_function
902 SCM_VALIDATE_METHOD (1, obj
);
903 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
907 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
909 "Return specializers of the method @var{obj}.")
910 #define FUNC_NAME s_scm_method_specializers
912 SCM_VALIDATE_METHOD (1, obj
);
913 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
917 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
919 "Return the procedure of the method @var{obj}.")
920 #define FUNC_NAME s_scm_method_procedure
922 SCM_VALIDATE_METHOD (1, obj
);
923 return scm_slot_ref (obj
, scm_str2symbol ("procedure"));
927 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
929 "Return the slot definition of the accessor @var{obj}.")
930 #define FUNC_NAME s_scm_accessor_method_slot_definition
932 SCM_VALIDATE_ACCESSOR (1, obj
);
933 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
938 /******************************************************************************
940 * S l o t a c c e s s
942 ******************************************************************************/
944 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
946 "Return the unbound value.")
947 #define FUNC_NAME s_scm_make_unbound
949 return SCM_GOOPS_UNBOUND
;
953 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
955 "Return @code{#t} if @var{obj} is unbound.")
956 #define FUNC_NAME s_scm_unbound_p
958 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
962 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
963 (SCM value
, SCM obj
),
964 "Return @var{value} if it is bound, and invoke the\n"
965 "@var{slot-unbound} method of @var{obj} if it is not.")
966 #define FUNC_NAME s_scm_assert_bound
968 if (SCM_GOOPS_UNBOUNDP (value
))
969 return CALL_GF1 ("slot-unbound", obj
);
974 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
975 (SCM obj
, SCM index
),
976 "Like @code{assert-bound}, but use @var{index} for accessing\n"
977 "the value from @var{obj}.")
978 #define FUNC_NAME s_scm_at_assert_bound_ref
980 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
981 if (SCM_GOOPS_UNBOUNDP (value
))
982 return CALL_GF1 ("slot-unbound", obj
);
987 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
988 (SCM obj
, SCM index
),
989 "Return the slot value with index @var{index} from @var{obj}.")
990 #define FUNC_NAME s_scm_sys_fast_slot_ref
994 SCM_VALIDATE_INSTANCE (1, obj
);
995 SCM_VALIDATE_INUM (2, index
);
996 i
= SCM_INUM (index
);
998 SCM_ASSERT_RANGE (2, index
, i
>= 0 && i
< SCM_NUMBER_OF_SLOTS (obj
));
999 return scm_at_assert_bound_ref (obj
, index
);
1003 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1004 (SCM obj
, SCM index
, SCM value
),
1005 "Set the slot with index @var{index} in @var{obj} to\n"
1007 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1011 SCM_VALIDATE_INSTANCE (1, obj
);
1012 SCM_VALIDATE_INUM (2, index
);
1013 i
= SCM_INUM (index
);
1014 SCM_ASSERT_RANGE (2, index
, i
>= 0 && i
< SCM_NUMBER_OF_SLOTS (obj
));
1015 SCM_SLOT (obj
, i
) = value
;
1017 return SCM_UNSPECIFIED
;
1024 /* In the future, this function will return the effective slot
1025 * definition associated with SLOT_NAME. Now it just returns some of
1026 * the information which will be stored in the effective slot
1031 slot_definition_using_name (SCM
class, SCM slot_name
)
1033 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1034 for (; SCM_NIMP (slots
); slots
= SCM_CDR (slots
))
1035 if (SCM_CAAR (slots
) == slot_name
)
1036 return SCM_CAR (slots
);
1041 get_slot_value (SCM
class, SCM obj
, SCM slotdef
)
1043 SCM access
= SCM_CDDR (slotdef
);
1045 * - access is an integer (the offset of this slot in the slots vector)
1046 * - otherwise (car access) is the getter function to apply
1048 if (SCM_INUMP (access
))
1049 return SCM_SLOT (obj
, SCM_INUM (access
));
1052 /* We must evaluate (apply (car access) (list obj))
1053 * where (car access) is known to be a closure of arity 1 */
1054 register SCM code
, env
;
1056 code
= SCM_CAR (access
);
1057 if (!SCM_CLOSUREP (code
))
1058 return SCM_SUBRF (code
) (obj
);
1059 env
= SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code
)),
1062 /* Evaluate the closure body */
1063 return scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1068 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1070 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1071 if (SCM_NFALSEP (slotdef
))
1072 return get_slot_value (class, obj
, slotdef
);
1074 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1078 set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
)
1080 SCM access
= SCM_CDDR (slotdef
);
1082 * - access is an integer (the offset of this slot in the slots vector)
1083 * - otherwise (cadr access) is the setter function to apply
1085 if (SCM_INUMP (access
))
1086 SCM_SLOT (obj
, SCM_INUM (access
)) = value
;
1089 /* We must evaluate (apply (cadr l) (list obj value))
1090 * where (cadr l) is known to be a closure of arity 2 */
1091 register SCM code
, env
;
1093 code
= SCM_CADR (access
);
1094 if (!SCM_CLOSUREP (code
))
1095 SCM_SUBRF (code
) (obj
, value
);
1098 env
= SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code
)),
1099 SCM_LIST2 (obj
, value
),
1101 /* Evaluate the closure body */
1102 scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1105 return SCM_UNSPECIFIED
;
1109 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1111 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1112 if (SCM_NFALSEP (slotdef
))
1113 return set_slot_value (class, obj
, slotdef
, value
);
1115 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1119 test_slot_existence (SCM
class, SCM obj
, SCM slot_name
)
1123 for (l
= SCM_ACCESSORS_OF (obj
); SCM_NNULLP (l
); l
= SCM_CDR (l
))
1124 if (SCM_CAAR (l
) == slot_name
)
1130 /* ======================================== */
1132 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1133 (SCM
class, SCM obj
, SCM slot_name
),
1135 #define FUNC_NAME s_scm_slot_ref_using_class
1139 SCM_VALIDATE_CLASS (1, class);
1140 SCM_VALIDATE_INSTANCE (2, obj
);
1141 SCM_VALIDATE_SYMBOL (3, slot_name
);
1143 res
= get_slot_value_using_name (class, obj
, slot_name
);
1144 if (SCM_GOOPS_UNBOUNDP (res
))
1145 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1151 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1152 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1154 #define FUNC_NAME s_scm_slot_set_using_class_x
1156 SCM_VALIDATE_CLASS (1, class);
1157 SCM_VALIDATE_INSTANCE (2, obj
);
1158 SCM_VALIDATE_SYMBOL (3, slot_name
);
1160 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1165 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1166 (SCM
class, SCM obj
, SCM slot_name
),
1168 #define FUNC_NAME s_scm_slot_bound_using_class_p
1170 SCM_VALIDATE_CLASS (1, class);
1171 SCM_VALIDATE_INSTANCE (2, obj
);
1172 SCM_VALIDATE_SYMBOL (3, slot_name
);
1174 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1180 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1181 (SCM
class, SCM obj
, SCM slot_name
),
1183 #define FUNC_NAME s_scm_slot_exists_using_class_p
1185 SCM_VALIDATE_CLASS (1, class);
1186 SCM_VALIDATE_INSTANCE (2, obj
);
1187 SCM_VALIDATE_SYMBOL (3, slot_name
);
1188 return test_slot_existence (class, obj
, slot_name
);
1193 /* ======================================== */
1195 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1196 (SCM obj
, SCM slot_name
),
1197 "Return the value from @var{obj}'s slot with the name\n"
1199 #define FUNC_NAME s_scm_slot_ref
1203 SCM_VALIDATE_INSTANCE (1, obj
);
1204 TEST_CHANGE_CLASS (obj
, class);
1206 res
= get_slot_value_using_name (class, obj
, slot_name
);
1207 if (SCM_GOOPS_UNBOUNDP (res
))
1208 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1213 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1214 (SCM obj
, SCM slot_name
, SCM value
),
1215 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1216 #define FUNC_NAME s_scm_slot_set_x
1220 SCM_VALIDATE_INSTANCE (1, obj
);
1221 TEST_CHANGE_CLASS(obj
, class);
1223 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1227 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1229 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1230 (SCM obj
, SCM slot_name
),
1231 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1233 #define FUNC_NAME s_scm_slot_bound_p
1237 SCM_VALIDATE_INSTANCE (1, obj
);
1238 TEST_CHANGE_CLASS(obj
, class);
1240 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1248 SCM_DEFINE (scm_slots_exists_p
, "slot-exists?", 2, 0, 0,
1249 (SCM obj
, SCM slot_name
),
1250 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1251 #define FUNC_NAME s_scm_slots_exists_p
1255 SCM_VALIDATE_INSTANCE (1, obj
);
1256 SCM_VALIDATE_SYMBOL (2, slot_name
);
1257 TEST_CHANGE_CLASS (obj
, class);
1259 return test_slot_existence (class, obj
, slot_name
);
1264 /******************************************************************************
1266 * %allocate-instance (the low level instance allocation primitive)
1268 ******************************************************************************/
1270 static void clear_method_cache (SCM
);
1273 wrap_init (SCM
class, SCM
*m
, int n
)
1278 /* Set all slots to unbound */
1279 for (i
= 0; i
< n
; i
++)
1280 m
[i
] = SCM_GOOPS_UNBOUND
;
1283 SCM_SETCDR (z
, (SCM
) m
);
1284 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
1285 SCM_SETCAR (z
, (scm_bits_t
) SCM_STRUCT_DATA (class) | scm_tc3_cons_gloc
);
1290 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1291 (SCM
class, SCM initargs
),
1292 "Create a new instance of class @var{class} and initialize it\n"
1293 "from the arguments @var{initargs}.")
1294 #define FUNC_NAME s_scm_sys_allocate_instance
1299 SCM_VALIDATE_CLASS (1, class);
1301 /* Most instances */
1302 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1304 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1305 m
= (SCM
*) scm_must_malloc (n
* sizeof (SCM
), "instance");
1306 return wrap_init (class, m
, n
);
1309 /* Foreign objects */
1310 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1311 return scm_make_foreign_object (class, initargs
);
1313 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1316 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1318 m
= (SCM
*) scm_alloc_struct (n
,
1319 scm_struct_entity_n_extra_words
,
1321 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1322 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1323 /* Generic functions */
1324 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1326 SCM gf
= wrap_init (class, m
, n
);
1327 clear_method_cache (gf
);
1331 return wrap_init (class, m
, n
);
1335 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1339 /* allocate class object */
1340 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1342 SCM_SLOT (z
, scm_si_print
) = SCM_GOOPS_UNBOUND
;
1343 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1344 SCM_SLOT (z
, i
) = SCM_GOOPS_UNBOUND
;
1346 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1347 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1348 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1349 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1354 /* Non-light instances */
1356 m
= (SCM
*) scm_alloc_struct (n
,
1357 scm_struct_n_extra_words
,
1359 return wrap_init (class, m
, n
);
1364 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1365 (SCM obj
, SCM setter
),
1367 #define FUNC_NAME s_scm_sys_set_object_setter_x
1369 SCM_ASSERT (SCM_STRUCTP (obj
)
1370 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1371 || SCM_I_ENTITYP (obj
)),
1375 if (SCM_I_ENTITYP (obj
))
1376 SCM_SET_ENTITY_SETTER (obj
, setter
);
1378 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1379 return SCM_UNSPECIFIED
;
1383 /******************************************************************************
1385 * %modify-instance (used by change-class to modify in place)
1387 ******************************************************************************/
1389 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1392 #define FUNC_NAME s_scm_sys_modify_instance
1394 SCM_VALIDATE_INSTANCE (1, old
);
1395 SCM_VALIDATE_INSTANCE (2, new);
1397 /* Exchange the data contained in old and new. We exchange rather than
1398 * scratch the old value with new to be correct with GC.
1399 * See "Class redefinition protocol above".
1403 SCM car
= SCM_CAR (old
);
1404 SCM cdr
= SCM_CDR (old
);
1405 SCM_SETCAR (old
, SCM_CAR (new));
1406 SCM_SETCDR (old
, SCM_CDR (new));
1407 SCM_SETCAR (new, car
);
1408 SCM_SETCDR (new, cdr
);
1411 return SCM_UNSPECIFIED
;
1415 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1418 #define FUNC_NAME s_scm_sys_modify_class
1420 SCM_VALIDATE_CLASS (1, old
);
1421 SCM_VALIDATE_CLASS (2, new);
1425 SCM car
= SCM_CAR (old
);
1426 SCM cdr
= SCM_CDR (old
);
1427 SCM_SETCAR (old
, SCM_CAR (new));
1428 SCM_SETCDR (old
, SCM_CDR (new));
1429 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = old
;
1430 SCM_SETCAR (new, car
);
1431 SCM_SETCDR (new, cdr
);
1432 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = new;
1435 return SCM_UNSPECIFIED
;
1439 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1442 #define FUNC_NAME s_scm_sys_invalidate_class
1444 SCM_VALIDATE_CLASS (1, class);
1445 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1446 return SCM_UNSPECIFIED
;
1450 /* When instances change class, they finally get a new body, but
1451 * before that, they go through purgatory in hell. Odd as it may
1452 * seem, this data structure saves us from eternal suffering in
1453 * infinite recursions.
1457 static int n_hell
= 1; /* one place for the evil one himself */
1458 static int hell_size
= 4;
1460 static scm_mutex_t hell_mutex
;
1467 for (i
= 1; i
< n_hell
; ++i
)
1468 if (SCM_INST (o
) == hell
[i
])
1474 go_to_hell (void *o
)
1478 scm_mutex_lock (&hell_mutex
);
1480 if (n_hell
== hell_size
)
1482 int new_size
= 2 * hell_size
;
1483 hell
= scm_must_realloc (hell
, hell_size
, new_size
, "hell");
1484 hell_size
= new_size
;
1486 hell
[n_hell
++] = SCM_INST (obj
);
1488 scm_mutex_unlock (&hell_mutex
);
1493 go_to_heaven (void *o
)
1496 scm_mutex_lock (&hell_mutex
);
1498 hell
[burnin ((SCM
) o
)] = hell
[--n_hell
];
1500 scm_mutex_unlock (&hell_mutex
);
1505 purgatory (void *args
)
1507 return scm_apply (GETVAR (scm_str2symbol ("change-class")), (SCM
) args
, SCM_EOL
);
1511 scm_change_object_class (SCM obj
, SCM old_class
, SCM new_class
)
1514 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1515 (void *) SCM_LIST2 (obj
, new_class
),
1519 /******************************************************************************
1525 * GGG E N E R I C F U N C T I O N S
1527 * This implementation provides
1528 * - generic functions (with class specializers)
1531 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1533 ******************************************************************************/
1535 SCM_KEYWORD (k_name
, "name");
1537 SCM_SYMBOL (sym_no_method
, "no-method");
1539 static SCM list_of_no_method
;
1541 SCM_SYMBOL (scm_sym_args
, "args");
1544 scm_make_method_cache (SCM gf
)
1546 return SCM_LIST5 (SCM_IM_DISPATCH
, scm_sym_args
, SCM_MAKINUM (1),
1547 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1553 clear_method_cache (SCM gf
)
1555 SCM cache
= scm_make_method_cache (gf
);
1556 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1557 SCM_SLOT (gf
, scm_si_used_by
) = SCM_BOOL_F
;
1560 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1563 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1566 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1567 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1568 if (SCM_NFALSEP (used_by
))
1570 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1571 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1572 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1573 clear_method_cache (gf
);
1574 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1575 SCM_SLOT (SCM_CAR (methods
), scm_si_code_table
) = SCM_EOL
;
1578 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1579 /* The sign of n is a flag indicating rest args. */
1580 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1582 return SCM_UNSPECIFIED
;
1586 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1589 #define FUNC_NAME s_scm_generic_capability_p
1591 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc
)),
1592 proc
, SCM_ARG1
, FUNC_NAME
);
1593 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1599 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1602 #define FUNC_NAME s_scm_enable_primitive_generic_x
1604 while (SCM_NIMP (subrs
))
1606 SCM subr
= SCM_CAR (subrs
);
1607 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1608 subr
, SCM_ARGn
, FUNC_NAME
);
1609 *SCM_SUBR_GENERIC (subr
)
1610 = scm_make (SCM_LIST3 (scm_class_generic
,
1613 subrs
= SCM_CDR (subrs
);
1615 return SCM_UNSPECIFIED
;
1619 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1622 #define FUNC_NAME s_scm_primitive_generic_generic
1624 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1626 SCM gf
= *SCM_SUBR_GENERIC (subr
);
1630 return scm_wta (subr
, (char *) SCM_ARG1
, FUNC_NAME
);
1634 /******************************************************************************
1636 * Protocol for calling a generic fumction
1637 * This protocol is roughly equivalent to (parameter are a little bit different
1638 * for efficiency reasons):
1640 * + apply-generic (gf args)
1641 * + compute-applicable-methods (gf args ...)
1642 * + sort-applicable-methods (methods args)
1643 * + apply-methods (gf methods args)
1645 * apply-methods calls make-next-method to build the "continuation" of a a
1646 * method. Applying a next-method will call apply-next-method which in
1647 * turn will call apply again to call effectively the following method.
1649 ******************************************************************************/
1652 applicablep (SCM actual
, SCM formal
)
1654 /* We already know that the cpl is well formed. */
1655 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1659 more_specificp (SCM m1
, SCM m2
, SCM
*targs
)
1661 register SCM s1
, s2
;
1665 * m1 and m2 can have != length (i.e. one can be one element longer than the
1666 * other when we have a dotted parameter list). For instance, with the call
1669 * (define-method M (a . l) ....)
1670 * (define-method M (a) ....)
1672 * we consider that the second method is more specific.
1674 * BTW, targs is an array of types. We don't need it's size since
1675 * we already know that m1 and m2 are applicable (no risk to go past
1676 * the end of this array).
1679 for (i
=0,s1
=SPEC_OF(m1
),s2
=SPEC_OF(m2
); ; i
++,s1
=SCM_CDR(s1
),s2
=SCM_CDR(s2
)) {
1680 if (SCM_NULLP(s1
)) return 1;
1681 if (SCM_NULLP(s2
)) return 0;
1682 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1683 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1685 for (l
= SCM_SLOT(targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1686 if (cs1
== SCM_CAR(l
))
1688 if (cs2
== SCM_CAR(l
))
1691 return 0;/* should not occur! */
1694 return 0; /* should not occur! */
1697 #define BUFFSIZE 32 /* big enough for most uses */
1700 scm_i_vector2list (SCM l
, int len
)
1703 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1705 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1706 SCM_VELTS (z
)[j
] = SCM_CAR (l
);
1712 sort_applicable_methods (SCM method_list
, int size
, SCM
*targs
)
1715 SCM
*v
, vector
= SCM_EOL
;
1716 SCM buffer
[BUFFSIZE
];
1717 SCM save
= method_list
;
1719 /* For reasonably sized method_lists we can try to avoid all the
1720 * consing and reorder the list in place...
1721 * This idea is due to David McClain <Dave_McClain@msn.com>
1723 if (size
<= BUFFSIZE
)
1725 for (i
= 0; i
< size
; i
++)
1727 buffer
[i
] = SCM_CAR (method_list
);
1728 method_list
= SCM_CDR (method_list
);
1734 /* Too many elements in method_list to keep everything locally */
1735 vector
= scm_i_vector2list (save
, size
);
1736 v
= SCM_VELTS (vector
);
1739 /* Use a simple shell sort since it is generally faster than qsort on
1740 * small vectors (which is probably mostly the case when we have to
1741 * sort a list of applicable methods).
1743 for (incr
= size
/ 2; incr
; incr
/= 2)
1745 for (i
= incr
; i
< size
; i
++)
1747 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1749 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1753 SCM tmp
= v
[j
+ incr
];
1761 if (size
<= BUFFSIZE
)
1763 /* We did it in locally, so restore the original list (reordered) in-place */
1764 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1766 SCM_SETCAR (method_list
, *v
);
1767 method_list
= SCM_CDR (method_list
);
1771 /* If we are here, that's that we did it the hard way... */
1772 return scm_vector_to_list (vector
);
1776 scm_compute_applicable_methods (SCM gf
, SCM args
, int len
, int find_method_p
)
1780 SCM l
, fl
, applicable
= SCM_EOL
;
1782 SCM buffer
[BUFFSIZE
], *types
, *p
;
1785 /* Build the list of arguments types */
1786 if (len
>= BUFFSIZE
) {
1787 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1788 /* NOTE: Using pointers to malloced memory won't work if we
1789 1. have preemtive threading, and,
1790 2. have a GC which moves objects. */
1791 types
= p
= SCM_VELTS(tmp
);
1796 for ( ; SCM_NNULLP (args
); args
= SCM_CDR (args
))
1797 *p
++ = scm_class_of (SCM_CAR (args
));
1799 /* Build a list of all applicable methods */
1800 for (l
= SCM_SLOT (gf
, scm_si_methods
); SCM_NNULLP (l
); l
= SCM_CDR (l
))
1802 fl
= SPEC_OF (SCM_CAR (l
));
1803 /* Only accept accessors which match exactly in first arg. */
1804 if (SCM_ACCESSORP (SCM_CAR (l
))
1805 && (SCM_IMP (fl
) || types
[0] != SCM_CAR (fl
)))
1807 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1809 if (SCM_INSTANCEP (fl
)
1810 /* We have a dotted argument list */
1811 || (i
>= len
&& SCM_NULLP (fl
)))
1812 { /* both list exhausted */
1813 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1819 || !applicablep (types
[i
], SCM_CAR (fl
)))
1828 CALL_GF2 ("no-applicable-method", gf
, save
);
1829 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1834 : sort_applicable_methods (applicable
, count
, types
));
1838 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1841 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1844 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1845 #define FUNC_NAME s_sys_compute_applicable_methods
1848 SCM_VALIDATE_GENERIC (1, gf
);
1849 n
= scm_ilength (args
);
1850 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1851 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1855 SCM_VCELL_INIT (var_compute_applicable_methods
, "compute-applicable-methods", scm_make_gsubr (s_sys_compute_applicable_methods
, 2, 0, 0, scm_sys_compute_applicable_methods
));
1857 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1860 scm_m_atslot_ref (SCM xorig
, SCM env
)
1862 SCM x
= SCM_CDR (xorig
);
1863 SCM_ASSYNT (scm_ilength (x
) == 2, xorig
, scm_s_expression
, s_atslot_ref
);
1864 SCM_ASSYNT (SCM_INUMP (SCM_CADR (x
)), SCM_CADR (x
), SCM_ARG2
, s_atslot_ref
);
1865 return scm_cons (SCM_IM_SLOT_REF
, x
);
1868 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1871 scm_m_atslot_set_x (SCM xorig
, SCM env
)
1873 SCM x
= SCM_CDR (xorig
);
1874 SCM_ASSYNT (scm_ilength (x
) == 3, xorig
, scm_s_expression
, s_atslot_set_x
);
1875 SCM_ASSYNT (SCM_INUMP (SCM_CADR (x
)), SCM_CADR (x
), SCM_ARG2
, s_atslot_set_x
);
1876 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1879 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1881 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1884 scm_m_atdispatch (SCM xorig
, SCM env
)
1885 #define FUNC_NAME s_atdispatch
1887 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1888 SCM_ASSYNT (scm_ilength (x
) == 4, xorig
, scm_s_expression
, s_atdispatch
);
1890 SCM_ASSYNT (SCM_CONSP (args
) || SCM_SYMBOLP (args
),
1891 args
, SCM_ARG1
, s_atdispatch
);
1893 n
= SCM_XEVALCAR (x
, env
);
1894 SCM_ASSYNT (SCM_INUMP (n
), n
, SCM_ARG2
, s_atdispatch
);
1895 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1897 v
= SCM_XEVALCAR (x
, env
);
1898 SCM_ASSYNT (SCM_VECTORP (v
), v
, SCM_ARG3
, s_atdispatch
);
1900 gf
= SCM_XEVALCAR (x
, env
);
1901 SCM_ASSYNT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG4
, s_atdispatch
);
1902 return SCM_LIST5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1909 lock_cache_mutex (void *m
)
1911 SCM mutex
= (SCM
) m
;
1912 scm_lock_mutex (mutex
);
1916 unlock_cache_mutex (void *m
)
1918 SCM mutex
= (SCM
) m
;
1919 scm_unlock_mutex (mutex
);
1924 call_memoize_method (void *a
)
1927 SCM gf
= SCM_CAR (args
);
1928 SCM x
= SCM_CADR (args
);
1929 /* First check if another thread has inserted a method between
1930 * the cache miss and locking the mutex.
1932 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
1933 if (SCM_NIMP (cmethod
))
1935 /*fixme* Use scm_apply */
1936 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
1940 scm_memoize_method (SCM x
, SCM args
)
1942 SCM gf
= SCM_CAR (scm_last_pair (x
));
1944 return scm_internal_dynamic_wind (lock_cache_mutex
,
1945 call_memoize_method
,
1947 (void *) scm_cons2 (gf
, x
, args
),
1948 (void *) SCM_SLOT (gf
, scm_si_cache_mutex
));
1950 return call_memoize_method ((void *) scm_cons2 (gf
, x
, args
));
1954 /******************************************************************************
1956 * A simple make (which will be redefined later in Scheme)
1957 * This version handles only creation of gf, methods and classes (no instances)
1959 * Since this code will disappear when Goops will be fully booted,
1960 * no precaution is taken to be efficient.
1962 ******************************************************************************/
1964 SCM_KEYWORD (k_setter
, "setter");
1965 SCM_KEYWORD (k_specializers
, "specializers");
1966 SCM_KEYWORD (k_procedure
, "procedure");
1967 SCM_KEYWORD (k_dsupers
, "dsupers");
1968 SCM_KEYWORD (k_slots
, "slots");
1969 SCM_KEYWORD (k_gf
, "generic-function");
1971 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
1973 "Make a new object. @var{args} mist contain the class and\n"
1974 "all necessary initialization information.")
1975 #define FUNC_NAME s_scm_make
1978 int len
= scm_ilength (args
);
1980 if (len
<= 0 || (len
& 1) == 0)
1981 SCM_WRONG_NUM_ARGS ();
1983 class = SCM_CAR(args
);
1984 args
= SCM_CDR(args
);
1986 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
1989 z
= scm_make_struct (class, SCM_INUM0
,
1993 scm_make_mutex ()));
1995 z
= scm_make_struct (class, SCM_INUM0
,
1996 SCM_LIST3 (SCM_EOL
, SCM_INUM0
, SCM_BOOL_F
));
1998 scm_set_procedure_property_x (z
, scm_sym_name
,
1999 scm_get_keyword (k_name
,
2002 clear_method_cache (z
);
2003 if (class == scm_class_generic_with_setter
)
2005 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2006 if (SCM_NIMP (setter
))
2007 scm_sys_set_object_setter_x (z
, setter
);
2012 z
= scm_sys_allocate_instance (class, args
);
2014 if (class == scm_class_method
2015 || class == scm_class_simple_method
2016 || class == scm_class_accessor
)
2018 SCM_SLOT (z
, scm_si_generic_function
) =
2019 scm_i_get_keyword (k_gf
,
2024 SCM_SLOT (z
, scm_si_specializers
) =
2025 scm_i_get_keyword (k_specializers
,
2030 SCM_SLOT (z
, scm_si_procedure
) =
2031 scm_i_get_keyword (k_procedure
,
2036 SCM_SLOT (z
, scm_si_code_table
) = SCM_EOL
;
2040 /* In all the others case, make a new class .... No instance here */
2041 SCM_SLOT (z
, scm_si_name
) =
2042 scm_i_get_keyword (k_name
,
2045 scm_str2symbol ("???"),
2047 SCM_SLOT (z
, scm_si_direct_supers
) =
2048 scm_i_get_keyword (k_dsupers
,
2053 SCM_SLOT (z
, scm_si_direct_slots
) =
2054 scm_i_get_keyword (k_slots
,
2065 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2068 #define FUNC_NAME s_scm_find_method
2071 int len
= scm_ilength (l
);
2074 SCM_WRONG_NUM_ARGS ();
2076 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2077 SCM_VALIDATE_GENERIC (1, gf
);
2078 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2079 SCM_MISC_ERROR ("no methods for generic ~S", SCM_LIST1 (gf
));
2081 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2085 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2086 (SCM m1
, SCM m2
, SCM targs
),
2088 #define FUNC_NAME s_scm_sys_method_more_specific_p
2093 SCM_VALIDATE_METHOD (1, m1
);
2094 SCM_VALIDATE_METHOD (2, m2
);
2095 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2097 /* Verify that all the arguments of targs are classes and place them in a vector*/
2098 v
= scm_c_make_vector (len
, SCM_EOL
);
2100 for (i
=0, l
=targs
; SCM_NNULLP(l
); i
++, l
=SCM_CDR(l
)) {
2101 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2102 SCM_VELTS(v
)[i
] = SCM_CAR(l
);
2104 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2110 /******************************************************************************
2114 ******************************************************************************/
2118 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2120 SCM tmp
= scm_str2symbol (name
);
2122 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2126 : SCM_LIST1 (super
),
2132 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2135 create_standard_classes (void)
2138 SCM method_slots
= SCM_LIST4 (scm_str2symbol ("generic-function"),
2139 scm_str2symbol ("specializers"),
2140 scm_str2symbol ("procedure"),
2141 scm_str2symbol ("code-table"));
2142 SCM amethod_slots
= SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"),
2144 k_slot_definition
));
2146 SCM mutex_slot
= SCM_LIST1 (scm_str2symbol ("make-mutex"));
2148 SCM mutex_slot
= SCM_BOOL_F
;
2150 SCM gf_slots
= SCM_LIST4 (scm_str2symbol ("methods"),
2151 SCM_LIST3 (scm_str2symbol ("n-specialized"),
2154 SCM_LIST3 (scm_str2symbol ("used-by"),
2157 SCM_LIST3 (scm_str2symbol ("cache-mutex"),
2159 scm_closure (SCM_LIST2 (SCM_EOL
,
2163 /* Foreign class slot classes */
2164 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2165 scm_class_class
, scm_class_top
, SCM_EOL
);
2166 make_stdcls (&scm_class_protected
, "<protected-slot>",
2167 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2168 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2169 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2170 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2171 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2172 make_stdcls (&scm_class_self
, "<self-slot>",
2174 SCM_LIST2 (scm_class_foreign_slot
, scm_class_read_only
),
2176 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2178 SCM_LIST2 (scm_class_protected
, scm_class_opaque
),
2180 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2182 SCM_LIST2 (scm_class_protected
, scm_class_read_only
),
2184 make_stdcls (&scm_class_scm
, "<scm-slot>",
2185 scm_class_class
, scm_class_protected
, SCM_EOL
);
2186 make_stdcls (&scm_class_int
, "<int-slot>",
2187 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2188 make_stdcls (&scm_class_float
, "<float-slot>",
2189 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2190 make_stdcls (&scm_class_double
, "<double-slot>",
2191 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2193 /* Continue initialization of class <class> */
2195 slots
= build_class_class_slots ();
2196 SCM_SLOT (scm_class_class
, scm_si_direct_slots
) = slots
;
2197 SCM_SLOT (scm_class_class
, scm_si_slots
) = slots
;
2198 SCM_SLOT (scm_class_class
, scm_si_getters_n_setters
)
2199 = compute_getters_n_setters (slots
);
2201 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2202 scm_class_class
, scm_class_class
,
2203 SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"),
2206 SCM_LIST3 (scm_str2symbol ("destructor"),
2208 scm_class_opaque
)));
2209 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2210 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2211 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2213 /* scm_class_generic functions classes */
2214 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2215 scm_class_class
, scm_class_class
, SCM_EOL
);
2216 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2217 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2218 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2219 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2220 make_stdcls (&scm_class_operator_with_setter_class
,
2221 "<operator-with-setter-class>",
2222 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2223 make_stdcls (&scm_class_method
, "<method>",
2224 scm_class_class
, scm_class_object
, method_slots
);
2225 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2226 scm_class_class
, scm_class_method
, SCM_EOL
);
2227 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2228 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2229 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2230 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2231 make_stdcls (&scm_class_entity
, "<entity>",
2232 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2233 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2234 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2235 make_stdcls (&scm_class_generic
, "<generic>",
2236 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2237 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2238 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2239 scm_class_entity_class
,
2240 SCM_LIST2 (scm_class_generic
, scm_class_entity_with_setter
),
2243 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2244 SCM_SLOT (scm_class_generic_with_setter
, scm_si_cpl
) =
2245 scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter
,
2247 SCM_SLOT (scm_class_entity_with_setter
,
2251 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2253 /* Primitive types classes */
2254 make_stdcls (&scm_class_boolean
, "<boolean>",
2255 scm_class_class
, scm_class_top
, SCM_EOL
);
2256 make_stdcls (&scm_class_char
, "<char>",
2257 scm_class_class
, scm_class_top
, SCM_EOL
);
2258 make_stdcls (&scm_class_list
, "<list>",
2259 scm_class_class
, scm_class_top
, SCM_EOL
);
2260 make_stdcls (&scm_class_pair
, "<pair>",
2261 scm_class_class
, scm_class_list
, SCM_EOL
);
2262 make_stdcls (&scm_class_null
, "<null>",
2263 scm_class_class
, scm_class_list
, SCM_EOL
);
2264 make_stdcls (&scm_class_string
, "<string>",
2265 scm_class_class
, scm_class_top
, SCM_EOL
);
2266 make_stdcls (&scm_class_symbol
, "<symbol>",
2267 scm_class_class
, scm_class_top
, SCM_EOL
);
2268 make_stdcls (&scm_class_vector
, "<vector>",
2269 scm_class_class
, scm_class_top
, SCM_EOL
);
2270 make_stdcls (&scm_class_number
, "<number>",
2271 scm_class_class
, scm_class_top
, SCM_EOL
);
2272 make_stdcls (&scm_class_complex
, "<complex>",
2273 scm_class_class
, scm_class_number
, SCM_EOL
);
2274 make_stdcls (&scm_class_real
, "<real>",
2275 scm_class_class
, scm_class_complex
, SCM_EOL
);
2276 make_stdcls (&scm_class_integer
, "<integer>",
2277 scm_class_class
, scm_class_real
, SCM_EOL
);
2278 make_stdcls (&scm_class_keyword
, "<keyword>",
2279 scm_class_class
, scm_class_top
, SCM_EOL
);
2280 make_stdcls (&scm_class_unknown
, "<unknown>",
2281 scm_class_class
, scm_class_top
, SCM_EOL
);
2282 make_stdcls (&scm_class_procedure
, "<procedure>",
2283 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2284 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2285 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2286 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2287 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2288 make_stdcls (&scm_class_port
, "<port>",
2289 scm_class_class
, scm_class_top
, SCM_EOL
);
2290 make_stdcls (&scm_class_input_port
, "<input-port>",
2291 scm_class_class
, scm_class_port
, SCM_EOL
);
2292 make_stdcls (&scm_class_output_port
, "<output-port>",
2293 scm_class_class
, scm_class_port
, SCM_EOL
);
2294 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2296 SCM_LIST2 (scm_class_input_port
, scm_class_output_port
),
2300 /**********************************************************************
2304 **********************************************************************/
2307 make_class_from_template (char *template, char *type_name
, SCM supers
)
2313 sprintf (buffer
, template, type_name
);
2314 name
= scm_str2symbol (buffer
);
2317 name
= SCM_GOOPS_UNBOUND
;
2319 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2324 /* Only define name if doesn't already exist. */
2325 if (!SCM_GOOPS_UNBOUNDP (name
)
2326 && SCM_FALSEP (scm_apply (scm_goops_lookup_closure
,
2327 SCM_LIST2 (name
, SCM_BOOL_F
),
2330 /* Make sure we add the binding in the GOOPS module.
2331 * This kludge is needed until DEFVAR ceases to use `define-public'
2332 * or `define-public' ceases to use `current-module'.
2334 SCM old_module
= scm_set_current_module (scm_module_goops
);
2335 DEFVAR (name
, class);
2336 scm_set_current_module (old_module
);
2342 scm_make_extended_class (char *type_name
)
2344 return make_class_from_template ("<%s>",
2346 SCM_LIST1 (scm_class_top
));
2350 create_smob_classes (void)
2354 scm_smob_class
= (SCM
*) malloc (255 * sizeof (SCM
));
2355 for (i
= 0; i
< 255; ++i
)
2356 scm_smob_class
[i
] = 0;
2358 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2359 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2360 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2361 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2363 for (i
= 0; i
< scm_numsmob
; ++i
)
2364 if (!scm_smob_class
[i
])
2365 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2369 scm_make_port_classes (int ptobnum
, char *type_name
)
2371 SCM c
, class = make_class_from_template ("<%s-port>",
2373 SCM_LIST1 (scm_class_port
));
2374 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2375 = make_class_from_template ("<%s-input-port>",
2377 SCM_LIST2 (class, scm_class_input_port
));
2378 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2379 = make_class_from_template ("<%s-output-port>",
2381 SCM_LIST2 (class, scm_class_output_port
));
2382 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2384 = make_class_from_template ("<%s-input-output-port>",
2387 scm_class_input_output_port
));
2388 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2389 SCM_SLOT (c
, scm_si_cpl
)
2390 = scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
));
2394 create_port_classes (void)
2398 scm_port_class
= (SCM
*) malloc (3 * 256 * sizeof (SCM
));
2399 for (i
= 0; i
< 3 * 256; ++i
)
2400 scm_port_class
[i
] = 0;
2402 for (i
= 0; i
< scm_numptob
; ++i
)
2403 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2407 make_struct_class (void *closure
, SCM key
, SCM data
, SCM prev
)
2409 if (SCM_NFALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2410 SCM_SET_STRUCT_TABLE_CLASS (data
,
2411 scm_make_extended_class
2412 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2413 return SCM_UNSPECIFIED
;
2417 create_struct_classes (void)
2419 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2422 /**********************************************************************
2426 **********************************************************************/
2431 if (!goops_loaded_p
)
2432 scm_resolve_module (scm_read_0str ("(oop goops)"));
2436 scm_make_foreign_object (SCM
class, SCM initargs
)
2438 void * (*constructor
) (SCM
)
2439 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2440 SCM_ASSERT (constructor
!= 0, class, "Can't make instances of this class",
2442 return scm_wrap_object (class, constructor (initargs
));
2446 scm_free_foreign_object (SCM
*class, SCM
*data
)
2448 size_t (*destructor
) (void *)
2449 = (size_t (*) (void *)) class[scm_si_destructor
];
2450 return destructor (data
);
2454 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2455 void * (*constructor
) (SCM initargs
),
2456 size_t (*destructor
) (void *))
2459 name
= scm_str2symbol (s_name
);
2460 if (SCM_IMP (supers
))
2461 supers
= SCM_LIST1 (scm_class_foreign_object
);
2462 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2463 scm_sys_inherit_magic_x (class, supers
);
2465 if (destructor
!= 0)
2467 SCM_SLOT (class, scm_si_destructor
) = (SCM
) destructor
;
2468 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2472 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2473 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2476 SCM_SLOT (class, scm_si_layout
) = scm_str2symbol ("");
2477 SCM_SLOT (class, scm_si_constructor
) = (SCM
) constructor
;
2482 SCM_SYMBOL (sym_o
, "o");
2483 SCM_SYMBOL (sym_x
, "x");
2485 SCM_KEYWORD (k_accessor
, "accessor");
2486 SCM_KEYWORD (k_getter
, "getter");
2489 default_setter (SCM obj
, SCM c
)
2491 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2496 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2497 SCM (*getter
) (SCM obj
),
2498 SCM (*setter
) (SCM obj
, SCM x
),
2499 char *accessor_name
)
2502 SCM get
= scm_make_subr_opt ("goops:get", scm_tc7_subr_1
, getter
, 0);
2503 SCM set
= scm_make_subr_opt ("goops:set", scm_tc7_subr_2
,
2504 setter
? setter
: default_setter
, 0);
2505 SCM getm
= scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o
),
2506 SCM_LIST2 (get
, sym_o
)),
2508 SCM setm
= scm_closure (SCM_LIST2 (SCM_LIST2 (sym_o
, sym_x
),
2509 SCM_LIST3 (set
, sym_o
, sym_x
)),
2512 SCM name
= scm_str2symbol (slot_name
);
2513 SCM aname
= scm_str2symbol (accessor_name
);
2514 SCM gf
= scm_ensure_accessor (aname
);
2515 SCM slot
= SCM_LIST5 (name
,
2516 k_class
, slot_class
,
2517 setter
? k_accessor
: k_getter
,
2519 SCM gns
= SCM_LIST4 (name
, SCM_BOOL_F
, get
, set
);
2521 scm_add_method (gf
, scm_make (SCM_LIST5 (scm_class_accessor
,
2524 k_procedure
, getm
)));
2525 scm_add_method (scm_setter (gf
),
2526 scm_make (SCM_LIST5 (scm_class_accessor
,
2530 k_procedure
, setm
)));
2533 SCM_SLOT (class, scm_si_slots
)
2534 = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots
),
2536 SCM_SLOT (class, scm_si_getters_n_setters
)
2537 = scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2542 int n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2544 SCM_SLOT (class, scm_si_nfields
)
2545 = SCM_MAKINUM (n
+ 1);
2550 scm_wrap_object (SCM
class, void *data
)
2554 SCM_SETCDR (z
, (SCM
) data
);
2555 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
2556 SCM_SETCAR (z
, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc
);
2563 scm_wrap_component (SCM
class, SCM container
, void *data
)
2565 SCM obj
= scm_wrap_object (class, data
);
2566 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2572 SCM_SETCDR (handle
, container
);
2577 scm_ensure_accessor (SCM name
)
2579 SCM gf
= scm_apply (SCM_TOP_LEVEL_LOOKUP_CLOSURE
,
2580 SCM_LIST2 (name
, SCM_BOOL_F
),
2582 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2584 gf
= scm_make (SCM_LIST3 (scm_class_generic
, k_name
, name
));
2585 gf
= scm_make (SCM_LIST5 (scm_class_generic_with_setter
,
2592 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2595 scm_add_method (SCM gf
, SCM m
)
2597 scm_i_eval (SCM_LIST3 (sym_internal_add_method_x
, gf
, m
),
2598 scm_top_level_env (scm_goops_lookup_closure
));
2603 * Debugging utilities
2606 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2608 "Return @code{#t} if @var{obj} is a pure generic.")
2609 #define FUNC_NAME s_scm_pure_generic_p
2611 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2615 #endif /* GUILE_DEBUG */
2621 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2623 "Announce that GOOPS is loaded and perform initialization\n"
2624 "on the C level which depends on the loaded GOOPS modules.")
2625 #define FUNC_NAME s_scm_sys_goops_loaded
2628 var_compute_applicable_methods
2629 = SCM_CDR (scm_apply (scm_goops_lookup_closure
,
2630 SCM_LIST2 (SCM_CAR (var_compute_applicable_methods
),
2633 return SCM_UNSPECIFIED
;
2637 SCM scm_module_goops
;
2640 scm_init_goops (void)
2643 scm_module_goops
= scm_make_module (scm_read_0str ("(oop goops)"));
2644 old_module
= scm_set_current_module (scm_module_goops
);
2646 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2648 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2649 (SCM_MAKINUM (37)));
2651 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2653 #ifndef SCM_MAGIC_SNARFER
2654 #include "libguile/goops.x"
2657 list_of_no_method
= scm_permanent_object (SCM_LIST1 (sym_no_method
));
2659 hell
= scm_must_malloc (hell_size
, "hell");
2661 scm_mutex_init (&hell_mutex
);
2664 create_basic_classes ();
2665 create_standard_classes ();
2666 create_smob_classes ();
2667 create_struct_classes ();
2668 create_port_classes ();
2671 SCM name
= scm_str2symbol ("no-applicable-method");
2672 scm_no_applicable_method
2673 = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic
,
2676 DEFVAR (name
, scm_no_applicable_method
);
2679 scm_set_current_module (old_module
);
2683 scm_init_oop_goops_goopscore_module ()
2685 scm_register_module_xxx ("oop goops goopscore", (void *) scm_init_goops
);