1 /* Copyright (C) 1998,1999,2000,2001, 2002, 2003 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 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
125 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
126 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
128 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
129 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
131 static int goops_loaded_p
= 0;
132 static scm_t_rstate
*goops_rstate
;
134 static SCM scm_goops_lookup_closure
;
136 /* Some classes are defined in libguile/objects.c. */
137 SCM scm_class_top
, scm_class_object
, scm_class_class
;
138 SCM scm_class_applicable
;
139 SCM scm_class_entity
, scm_class_entity_with_setter
;
140 SCM scm_class_generic
, scm_class_generic_with_setter
;
141 SCM scm_class_accessor
;
142 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
143 SCM scm_class_extended_accessor
;
144 SCM scm_class_method
;
145 SCM scm_class_simple_method
, scm_class_accessor_method
;
146 SCM scm_class_procedure_class
;
147 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
148 SCM scm_class_entity_class
;
149 SCM scm_class_number
, scm_class_list
;
150 SCM scm_class_keyword
;
151 SCM scm_class_port
, scm_class_input_output_port
;
152 SCM scm_class_input_port
, scm_class_output_port
;
153 SCM scm_class_foreign_class
, scm_class_foreign_object
;
154 SCM scm_class_foreign_slot
;
155 SCM scm_class_self
, scm_class_protected
;
156 SCM scm_class_opaque
, scm_class_read_only
;
157 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
159 SCM scm_class_int
, scm_class_float
, scm_class_double
;
161 SCM_SYMBOL (scm_sym_define_public
, "define-public");
163 static SCM
scm_make_unbound (void);
164 static SCM
scm_unbound_p (SCM obj
);
165 static SCM
scm_assert_bound (SCM value
, SCM obj
);
166 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
167 static SCM
scm_sys_goops_loaded (void);
169 /******************************************************************************
173 * This version doesn't fully handle multiple-inheritance. It serves
174 * only for booting classes and will be overloaded in Scheme
176 ******************************************************************************/
179 map (SCM (*proc
) (SCM
), SCM ls
)
185 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
188 while (!SCM_NULLP (ls
))
190 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
202 while (!SCM_NULLP (ls
))
204 SCM el
= SCM_CAR (ls
);
205 if (SCM_FALSEP (scm_c_memq (el
, res
)))
206 res
= scm_cons (el
, res
);
213 compute_cpl (SCM
class)
216 return CALL_GF1 ("compute-cpl", class);
219 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
220 SCM ls
= scm_append (scm_acons (class, supers
,
221 map (compute_cpl
, supers
)));
222 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
226 /******************************************************************************
230 ******************************************************************************/
233 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
241 if (!SCM_SYMBOLP (tmp
))
242 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
244 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
245 res
= scm_cons (SCM_CAR (l
), res
);
246 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
249 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
253 build_slots_list (SCM dslots
, SCM cpl
)
255 register SCM res
= dslots
;
257 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
258 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
259 scm_si_direct_slots
),
262 /* res contains a list of slots. Remove slots which appears more than once */
263 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
270 while (!SCM_NULLP (ls
))
272 if (!SCM_CONSP (SCM_CAR (ls
)))
273 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
280 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
282 "Return a list consisting of the names of all slots belonging to\n"
283 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
285 #define FUNC_NAME s_scm_sys_compute_slots
287 SCM_VALIDATE_CLASS (1, class);
288 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
289 SCM_SLOT (class, scm_si_cpl
));
294 /******************************************************************************
296 * compute-getters-n-setters
298 * This version doesn't handle slot options. It serves only for booting
299 * classes and will be overloaded in Scheme.
301 ******************************************************************************/
303 SCM_KEYWORD (k_init_value
, "init-value");
304 SCM_KEYWORD (k_init_thunk
, "init-thunk");
307 compute_getters_n_setters (SCM slots
)
313 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
315 SCM init
= SCM_BOOL_F
;
316 SCM options
= SCM_CDAR (slots
);
317 if (!SCM_NULLP (options
))
319 init
= scm_get_keyword (k_init_value
, options
, 0);
321 init
= scm_closure (scm_list_2 (SCM_EOL
,
322 scm_list_2 (scm_sym_quote
, init
)),
325 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
327 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
331 cdrloc
= SCM_CDRLOC (*cdrloc
);
336 /******************************************************************************
340 ******************************************************************************/
342 /*fixme* Manufacture keywords in advance */
344 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
348 for (i
= 0; i
!= len
; i
+= 2)
350 SCM obj
= SCM_CAR (l
);
352 if (!SCM_KEYWORDP (obj
))
353 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
354 else if (SCM_EQ_P (obj
, key
))
360 return default_value
;
364 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
365 (SCM key
, SCM l
, SCM default_value
),
366 "Determine an associated value for the keyword @var{key} from\n"
367 "the list @var{l}. The list @var{l} has to consist of an even\n"
368 "number of elements, where, starting with the first, every\n"
369 "second element is a keyword, followed by its associated value.\n"
370 "If @var{l} does not hold a value for @var{key}, the value\n"
371 "@var{default_value} is returned.")
372 #define FUNC_NAME s_scm_get_keyword
376 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
377 len
= scm_ilength (l
);
378 if (len
< 0 || len
% 2 == 1)
379 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
381 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
386 SCM_KEYWORD (k_init_keyword
, "init-keyword");
388 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
389 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
391 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
392 (SCM obj
, SCM initargs
),
393 "Initialize the object @var{obj} with the given arguments\n"
395 #define FUNC_NAME s_scm_sys_initialize_object
397 SCM tmp
, get_n_set
, slots
;
398 SCM
class = SCM_CLASS_OF (obj
);
401 SCM_VALIDATE_INSTANCE (1, obj
);
402 n_initargs
= scm_ilength (initargs
);
403 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
405 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
406 slots
= SCM_SLOT (class, scm_si_slots
);
408 /* See for each slot how it must be initialized */
411 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
413 SCM slot_name
= SCM_CAR (slots
);
416 if (!SCM_NULLP (SCM_CDR (slot_name
)))
418 /* This slot admits (perhaps) to be initialized at creation time */
419 long n
= scm_ilength (SCM_CDR (slot_name
));
420 if (n
& 1) /* odd or -1 */
421 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
422 scm_list_1 (slot_name
));
423 tmp
= scm_i_get_keyword (k_init_keyword
,
428 slot_name
= SCM_CAR (slot_name
);
431 /* an initarg was provided for this slot */
432 if (!SCM_KEYWORDP (tmp
))
433 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
435 slot_value
= scm_i_get_keyword (tmp
,
444 /* set slot to provided value */
445 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
448 /* set slot to its :init-form if it exists */
449 tmp
= SCM_CADAR (get_n_set
);
450 if (tmp
!= SCM_BOOL_F
)
452 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
453 if (SCM_GOOPS_UNBOUNDP (slot_value
))
455 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
456 set_slot_value (class,
459 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
470 SCM_KEYWORD (k_class
, "class");
471 SCM_KEYWORD (k_allocation
, "allocation");
472 SCM_KEYWORD (k_instance
, "instance");
474 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
477 #define FUNC_NAME s_scm_sys_prep_layout_x
480 unsigned long int n
, i
;
483 SCM_VALIDATE_INSTANCE (1, class);
484 slots
= SCM_SLOT (class, scm_si_slots
);
485 nfields
= SCM_SLOT (class, scm_si_nfields
);
486 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
487 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
488 scm_list_1 (nfields
));
489 n
= 2 * SCM_INUM (nfields
);
490 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
491 && SCM_SUBCLASSP (class, scm_class_class
))
492 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
493 scm_list_1 (nfields
));
495 s
= n
> 0 ? scm_malloc (n
) : 0;
496 for (i
= 0; i
< n
; i
+= 2)
499 SCM type
, allocation
;
502 if (!SCM_CONSP (slots
))
503 SCM_MISC_ERROR ("too few slot definitions", SCM_EOL
);
504 len
= scm_ilength (SCM_CDAR (slots
));
505 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
506 len
, k_instance
, FUNC_NAME
);
507 while (!SCM_EQ_P (allocation
, k_instance
))
509 slots
= SCM_CDR (slots
);
510 len
= scm_ilength (SCM_CDAR (slots
));
511 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
512 len
, k_instance
, FUNC_NAME
);
514 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
515 len
, SCM_BOOL_F
, FUNC_NAME
);
516 if (SCM_FALSEP (type
))
523 if (!SCM_CLASSP (type
))
524 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
525 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
527 if (SCM_SUBCLASSP (type
, scm_class_self
))
529 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
534 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
536 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
549 slots
= SCM_CDR (slots
);
551 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
554 return SCM_UNSPECIFIED
;
558 static void prep_hashsets (SCM
);
560 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
561 (SCM
class, SCM dsupers
),
563 #define FUNC_NAME s_scm_sys_inherit_magic_x
567 SCM_VALIDATE_INSTANCE (1, class);
568 while (!SCM_NULLP (ls
))
570 SCM_ASSERT (SCM_CONSP (ls
)
571 && SCM_INSTANCEP (SCM_CAR (ls
)),
575 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
578 flags
&= SCM_CLASSF_INHERIT
;
579 if (flags
& SCM_CLASSF_ENTITY
)
580 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
583 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
586 * We could avoid calling scm_gc_malloc in the allocation code
587 * (in which case the following two lines are needed). Instead
588 * we make 0-slot instances non-light, so that the light case
589 * can be handled without special cases.
592 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
594 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
596 /* NOTE: The following depends on scm_struct_i_size. */
597 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
598 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
601 SCM_SET_CLASS_FLAGS (class, flags
);
603 prep_hashsets (class);
605 return SCM_UNSPECIFIED
;
610 prep_hashsets (SCM
class)
614 for (i
= 0; i
< 7; ++i
)
615 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
618 /******************************************************************************/
621 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
623 SCM z
, cpl
, slots
, nfields
, g_n_s
;
625 /* Allocate one instance */
626 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
628 /* Initialize its slots */
629 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
630 cpl
= compute_cpl (z
);
631 slots
= build_slots_list (maplist (dslots
), cpl
);
632 nfields
= SCM_MAKINUM (scm_ilength (slots
));
633 g_n_s
= compute_getters_n_setters (slots
);
635 SCM_SET_SLOT (z
, scm_si_name
, name
);
636 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
637 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
638 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
639 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
640 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
641 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
642 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
643 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
644 SCM_SET_SLOT (z
, scm_si_environment
,
645 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
647 /* Add this class in the direct-subclasses slot of dsupers */
650 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
651 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
652 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
653 scm_si_direct_subclasses
)));
656 /* Support for the underlying structs: */
657 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
658 ? (SCM_CLASSF_GOOPS_OR_VALID
659 | SCM_CLASSF_OPERATOR
661 : class == scm_class_operator_class
662 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
663 : SCM_CLASSF_GOOPS_OR_VALID
));
668 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
670 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
671 scm_sys_inherit_magic_x (z
, dsupers
);
672 scm_sys_prep_layout_x (z
);
676 /******************************************************************************/
678 SCM_SYMBOL (sym_layout
, "layout");
679 SCM_SYMBOL (sym_vcell
, "vcell");
680 SCM_SYMBOL (sym_vtable
, "vtable");
681 SCM_SYMBOL (sym_print
, "print");
682 SCM_SYMBOL (sym_procedure
, "procedure");
683 SCM_SYMBOL (sym_setter
, "setter");
684 SCM_SYMBOL (sym_redefined
, "redefined");
685 SCM_SYMBOL (sym_h0
, "h0");
686 SCM_SYMBOL (sym_h1
, "h1");
687 SCM_SYMBOL (sym_h2
, "h2");
688 SCM_SYMBOL (sym_h3
, "h3");
689 SCM_SYMBOL (sym_h4
, "h4");
690 SCM_SYMBOL (sym_h5
, "h5");
691 SCM_SYMBOL (sym_h6
, "h6");
692 SCM_SYMBOL (sym_h7
, "h7");
693 SCM_SYMBOL (sym_name
, "name");
694 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
695 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
696 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
697 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
698 SCM_SYMBOL (sym_cpl
, "cpl");
699 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
700 SCM_SYMBOL (sym_slots
, "slots");
701 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
702 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
703 SCM_SYMBOL (sym_nfields
, "nfields");
704 SCM_SYMBOL (sym_environment
, "environment");
708 build_class_class_slots ()
711 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
712 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
713 scm_list_1 (sym_print
),
714 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
715 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
716 scm_list_1 (sym_redefined
),
717 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
718 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
719 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
720 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
721 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
722 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
723 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
724 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
725 scm_list_1 (sym_name
),
726 scm_list_1 (sym_direct_supers
),
727 scm_list_1 (sym_direct_slots
),
728 scm_list_1 (sym_direct_subclasses
),
729 scm_list_1 (sym_direct_methods
),
730 scm_list_1 (sym_cpl
),
731 scm_list_1 (sym_default_slot_definition_class
),
732 scm_list_1 (sym_slots
),
733 scm_list_1 (sym_getters_n_setters
),
734 scm_list_1 (sym_keyword_access
),
735 scm_list_1 (sym_nfields
),
736 scm_list_1 (sym_environment
),
741 create_basic_classes (void)
743 /* SCM slots_of_class = build_class_class_slots (); */
745 /**** <scm_class_class> ****/
746 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
747 + 2 * scm_vtable_offset_user
);
748 SCM name
= scm_str2symbol ("<class>");
749 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
752 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
753 | SCM_CLASSF_METACLASS
));
755 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
756 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
757 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
758 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
759 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
760 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
761 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
762 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
763 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
764 compute_getters_n_setters (slots_of_class)); */
765 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
766 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
767 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
769 prep_hashsets (scm_class_class
);
771 DEFVAR(name
, scm_class_class
);
773 /**** <scm_class_top> ****/
774 name
= scm_str2symbol ("<top>");
775 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
780 DEFVAR(name
, scm_class_top
);
782 /**** <scm_class_object> ****/
783 name
= scm_str2symbol ("<object>");
784 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
786 scm_list_1 (scm_class_top
),
789 DEFVAR (name
, scm_class_object
);
791 /* <top> <object> and <class> were partially initialized. Correct them here */
792 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
794 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
795 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
798 /******************************************************************************/
800 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
802 "Return @code{#t} if @var{obj} is an instance.")
803 #define FUNC_NAME s_scm_instance_p
805 return SCM_BOOL (SCM_INSTANCEP (obj
));
810 /******************************************************************************
812 * Meta object accessors
814 ******************************************************************************/
815 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
817 "Return the class name of @var{obj}.")
818 #define FUNC_NAME s_scm_class_name
820 SCM_VALIDATE_CLASS (1, obj
);
821 return scm_slot_ref (obj
, sym_name
);
825 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
827 "Return the direct superclasses of the class @var{obj}.")
828 #define FUNC_NAME s_scm_class_direct_supers
830 SCM_VALIDATE_CLASS (1, obj
);
831 return scm_slot_ref (obj
, sym_direct_supers
);
835 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
837 "Return the direct slots of the class @var{obj}.")
838 #define FUNC_NAME s_scm_class_direct_slots
840 SCM_VALIDATE_CLASS (1, obj
);
841 return scm_slot_ref (obj
, sym_direct_slots
);
845 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
847 "Return the direct subclasses of the class @var{obj}.")
848 #define FUNC_NAME s_scm_class_direct_subclasses
850 SCM_VALIDATE_CLASS (1, obj
);
851 return scm_slot_ref(obj
, sym_direct_subclasses
);
855 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
857 "Return the direct methods of the class @var{obj}")
858 #define FUNC_NAME s_scm_class_direct_methods
860 SCM_VALIDATE_CLASS (1, obj
);
861 return scm_slot_ref (obj
, sym_direct_methods
);
865 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
867 "Return the class precedence list of the class @var{obj}.")
868 #define FUNC_NAME s_scm_class_precedence_list
870 SCM_VALIDATE_CLASS (1, obj
);
871 return scm_slot_ref (obj
, sym_cpl
);
875 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
877 "Return the slot list of the class @var{obj}.")
878 #define FUNC_NAME s_scm_class_slots
880 SCM_VALIDATE_CLASS (1, obj
);
881 return scm_slot_ref (obj
, sym_slots
);
885 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
887 "Return the environment of the class @var{obj}.")
888 #define FUNC_NAME s_scm_class_environment
890 SCM_VALIDATE_CLASS (1, obj
);
891 return scm_slot_ref(obj
, sym_environment
);
896 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
898 "Return the name of the generic function @var{obj}.")
899 #define FUNC_NAME s_scm_generic_function_name
901 SCM_VALIDATE_GENERIC (1, obj
);
902 return scm_procedure_property (obj
, scm_sym_name
);
906 SCM_SYMBOL (sym_methods
, "methods");
907 SCM_SYMBOL (sym_extended_by
, "extended-by");
908 SCM_SYMBOL (sym_extends
, "extends");
911 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
913 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
914 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
915 while (!SCM_NULLP (gfs
))
917 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
924 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
926 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
928 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
929 while (!SCM_NULLP (gfs
))
931 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
932 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
941 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
943 "Return the methods of the generic function @var{obj}.")
944 #define FUNC_NAME s_scm_generic_function_methods
947 SCM_VALIDATE_GENERIC (1, obj
);
948 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
949 methods
= fold_downward_gf_methods (methods
, obj
);
950 return scm_append (methods
);
954 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
956 "Return the generic function for the method @var{obj}.")
957 #define FUNC_NAME s_scm_method_generic_function
959 SCM_VALIDATE_METHOD (1, obj
);
960 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
964 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
966 "Return specializers of the method @var{obj}.")
967 #define FUNC_NAME s_scm_method_specializers
969 SCM_VALIDATE_METHOD (1, obj
);
970 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
974 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
976 "Return the procedure of the method @var{obj}.")
977 #define FUNC_NAME s_scm_method_procedure
979 SCM_VALIDATE_METHOD (1, obj
);
980 return scm_slot_ref (obj
, sym_procedure
);
984 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
986 "Return the slot definition of the accessor @var{obj}.")
987 #define FUNC_NAME s_scm_accessor_method_slot_definition
989 SCM_VALIDATE_ACCESSOR (1, obj
);
990 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
994 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
996 "Internal GOOPS magic---don't use this function!")
997 #define FUNC_NAME s_scm_sys_tag_body
999 return scm_cons (SCM_IM_LAMBDA
, body
);
1003 /******************************************************************************
1005 * S l o t a c c e s s
1007 ******************************************************************************/
1009 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1011 "Return the unbound value.")
1012 #define FUNC_NAME s_scm_make_unbound
1014 return SCM_GOOPS_UNBOUND
;
1018 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1020 "Return @code{#t} if @var{obj} is unbound.")
1021 #define FUNC_NAME s_scm_unbound_p
1023 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1027 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1028 (SCM value
, SCM obj
),
1029 "Return @var{value} if it is bound, and invoke the\n"
1030 "@var{slot-unbound} method of @var{obj} if it is not.")
1031 #define FUNC_NAME s_scm_assert_bound
1033 if (SCM_GOOPS_UNBOUNDP (value
))
1034 return CALL_GF1 ("slot-unbound", obj
);
1039 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1040 (SCM obj
, SCM index
),
1041 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1042 "the value from @var{obj}.")
1043 #define FUNC_NAME s_scm_at_assert_bound_ref
1045 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1046 if (SCM_GOOPS_UNBOUNDP (value
))
1047 return CALL_GF1 ("slot-unbound", obj
);
1052 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1053 (SCM obj
, SCM index
),
1054 "Return the slot value with index @var{index} from @var{obj}.")
1055 #define FUNC_NAME s_scm_sys_fast_slot_ref
1057 unsigned long int i
;
1059 SCM_VALIDATE_INSTANCE (1, obj
);
1060 SCM_VALIDATE_INUM (2, index
);
1061 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1062 i
= SCM_INUM (index
);
1063 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1065 return scm_at_assert_bound_ref (obj
, index
);
1069 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1070 (SCM obj
, SCM index
, SCM value
),
1071 "Set the slot with index @var{index} in @var{obj} to\n"
1073 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1075 unsigned long int i
;
1077 SCM_VALIDATE_INSTANCE (1, obj
);
1078 SCM_VALIDATE_INUM (2, index
);
1079 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1080 i
= SCM_INUM (index
);
1081 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1083 SCM_SET_SLOT (obj
, i
, value
);
1085 return SCM_UNSPECIFIED
;
1092 /* In the future, this function will return the effective slot
1093 * definition associated with SLOT_NAME. Now it just returns some of
1094 * the information which will be stored in the effective slot
1099 slot_definition_using_name (SCM
class, SCM slot_name
)
1101 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1102 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1103 if (SCM_CAAR (slots
) == slot_name
)
1104 return SCM_CAR (slots
);
1109 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1111 SCM access
= SCM_CDDR (slotdef
);
1113 * - access is an integer (the offset of this slot in the slots vector)
1114 * - otherwise (car access) is the getter function to apply
1116 if (SCM_INUMP (access
))
1117 return SCM_SLOT (obj
, SCM_INUM (access
));
1120 /* We must evaluate (apply (car access) (list obj))
1121 * where (car access) is known to be a closure of arity 1 */
1122 register SCM code
, env
;
1124 code
= SCM_CAR (access
);
1125 if (!SCM_CLOSUREP (code
))
1126 return SCM_SUBRF (code
) (obj
);
1127 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1130 /* Evaluate the closure body */
1131 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1136 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1138 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1139 if (!SCM_FALSEP (slotdef
))
1140 return get_slot_value (class, obj
, slotdef
);
1142 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1146 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1148 SCM access
= SCM_CDDR (slotdef
);
1150 * - access is an integer (the offset of this slot in the slots vector)
1151 * - otherwise (cadr access) is the setter function to apply
1153 if (SCM_INUMP (access
))
1154 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1157 /* We must evaluate (apply (cadr l) (list obj value))
1158 * where (cadr l) is known to be a closure of arity 2 */
1159 register SCM code
, env
;
1161 code
= SCM_CADR (access
);
1162 if (!SCM_CLOSUREP (code
))
1163 SCM_SUBRF (code
) (obj
, value
);
1166 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1167 scm_list_2 (obj
, value
),
1169 /* Evaluate the closure body */
1170 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1173 return SCM_UNSPECIFIED
;
1177 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1179 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1180 if (!SCM_FALSEP (slotdef
))
1181 return set_slot_value (class, obj
, slotdef
, value
);
1183 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1187 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1191 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1192 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1198 /* ======================================== */
1200 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1201 (SCM
class, SCM obj
, SCM slot_name
),
1203 #define FUNC_NAME s_scm_slot_ref_using_class
1207 SCM_VALIDATE_CLASS (1, class);
1208 SCM_VALIDATE_INSTANCE (2, obj
);
1209 SCM_VALIDATE_SYMBOL (3, slot_name
);
1211 res
= get_slot_value_using_name (class, obj
, slot_name
);
1212 if (SCM_GOOPS_UNBOUNDP (res
))
1213 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1219 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1220 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1222 #define FUNC_NAME s_scm_slot_set_using_class_x
1224 SCM_VALIDATE_CLASS (1, class);
1225 SCM_VALIDATE_INSTANCE (2, obj
);
1226 SCM_VALIDATE_SYMBOL (3, slot_name
);
1228 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1233 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1234 (SCM
class, SCM obj
, SCM slot_name
),
1236 #define FUNC_NAME s_scm_slot_bound_using_class_p
1238 SCM_VALIDATE_CLASS (1, class);
1239 SCM_VALIDATE_INSTANCE (2, obj
);
1240 SCM_VALIDATE_SYMBOL (3, slot_name
);
1242 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1248 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1249 (SCM
class, SCM obj
, SCM slot_name
),
1251 #define FUNC_NAME s_scm_slot_exists_using_class_p
1253 SCM_VALIDATE_CLASS (1, class);
1254 SCM_VALIDATE_INSTANCE (2, obj
);
1255 SCM_VALIDATE_SYMBOL (3, slot_name
);
1256 return test_slot_existence (class, obj
, slot_name
);
1261 /* ======================================== */
1263 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1264 (SCM obj
, SCM slot_name
),
1265 "Return the value from @var{obj}'s slot with the name\n"
1267 #define FUNC_NAME s_scm_slot_ref
1271 SCM_VALIDATE_INSTANCE (1, obj
);
1272 TEST_CHANGE_CLASS (obj
, class);
1274 res
= get_slot_value_using_name (class, obj
, slot_name
);
1275 if (SCM_GOOPS_UNBOUNDP (res
))
1276 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1281 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1282 (SCM obj
, SCM slot_name
, SCM value
),
1283 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1284 #define FUNC_NAME s_scm_slot_set_x
1288 SCM_VALIDATE_INSTANCE (1, obj
);
1289 TEST_CHANGE_CLASS(obj
, class);
1291 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1295 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1297 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1298 (SCM obj
, SCM slot_name
),
1299 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1301 #define FUNC_NAME s_scm_slot_bound_p
1305 SCM_VALIDATE_INSTANCE (1, obj
);
1306 TEST_CHANGE_CLASS(obj
, class);
1308 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1316 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1317 (SCM obj
, SCM slot_name
),
1318 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1319 #define FUNC_NAME s_scm_slot_exists_p
1323 SCM_VALIDATE_INSTANCE (1, obj
);
1324 SCM_VALIDATE_SYMBOL (2, slot_name
);
1325 TEST_CHANGE_CLASS (obj
, class);
1327 return test_slot_existence (class, obj
, slot_name
);
1332 /******************************************************************************
1334 * %allocate-instance (the low level instance allocation primitive)
1336 ******************************************************************************/
1338 static void clear_method_cache (SCM
);
1341 wrap_init (SCM
class, SCM
*m
, long n
)
1345 /* Set all slots to unbound */
1346 for (i
= 0; i
< n
; i
++)
1347 m
[i
] = SCM_GOOPS_UNBOUND
;
1349 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1351 (scm_t_bits
) m
, 0, 0);
1354 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1355 (SCM
class, SCM initargs
),
1356 "Create a new instance of class @var{class} and initialize it\n"
1357 "from the arguments @var{initargs}.")
1358 #define FUNC_NAME s_scm_sys_allocate_instance
1363 SCM_VALIDATE_CLASS (1, class);
1365 /* Most instances */
1366 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1368 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1369 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1370 return wrap_init (class, m
, n
);
1373 /* Foreign objects */
1374 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1375 return scm_make_foreign_object (class, initargs
);
1377 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1380 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1382 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1384 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1385 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1386 /* Generic functions */
1387 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1389 SCM gf
= wrap_init (class, m
, n
);
1390 clear_method_cache (gf
);
1394 return wrap_init (class, m
, n
);
1398 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1402 /* allocate class object */
1403 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1405 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1406 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1407 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1409 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1410 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1411 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1412 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1417 /* Non-light instances */
1419 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1420 return wrap_init (class, m
, n
);
1425 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1426 (SCM obj
, SCM setter
),
1428 #define FUNC_NAME s_scm_sys_set_object_setter_x
1430 SCM_ASSERT (SCM_STRUCTP (obj
)
1431 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1432 || SCM_I_ENTITYP (obj
)),
1436 if (SCM_I_ENTITYP (obj
))
1437 SCM_SET_ENTITY_SETTER (obj
, setter
);
1439 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1440 return SCM_UNSPECIFIED
;
1444 /******************************************************************************
1446 * %modify-instance (used by change-class to modify in place)
1448 ******************************************************************************/
1450 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1453 #define FUNC_NAME s_scm_sys_modify_instance
1455 SCM_VALIDATE_INSTANCE (1, old
);
1456 SCM_VALIDATE_INSTANCE (2, new);
1458 /* Exchange the data contained in old and new. We exchange rather than
1459 * scratch the old value with new to be correct with GC.
1460 * See "Class redefinition protocol above".
1464 SCM car
= SCM_CAR (old
);
1465 SCM cdr
= SCM_CDR (old
);
1466 SCM_SETCAR (old
, SCM_CAR (new));
1467 SCM_SETCDR (old
, SCM_CDR (new));
1468 SCM_SETCAR (new, car
);
1469 SCM_SETCDR (new, cdr
);
1472 return SCM_UNSPECIFIED
;
1476 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1479 #define FUNC_NAME s_scm_sys_modify_class
1481 SCM_VALIDATE_CLASS (1, old
);
1482 SCM_VALIDATE_CLASS (2, new);
1486 SCM car
= SCM_CAR (old
);
1487 SCM cdr
= SCM_CDR (old
);
1488 SCM_SETCAR (old
, SCM_CAR (new));
1489 SCM_SETCDR (old
, SCM_CDR (new));
1490 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1491 SCM_SETCAR (new, car
);
1492 SCM_SETCDR (new, cdr
);
1493 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1496 return SCM_UNSPECIFIED
;
1500 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1503 #define FUNC_NAME s_scm_sys_invalidate_class
1505 SCM_VALIDATE_CLASS (1, class);
1506 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1507 return SCM_UNSPECIFIED
;
1511 /* When instances change class, they finally get a new body, but
1512 * before that, they go through purgatory in hell. Odd as it may
1513 * seem, this data structure saves us from eternal suffering in
1514 * infinite recursions.
1517 static scm_t_bits
**hell
;
1518 static long n_hell
= 1; /* one place for the evil one himself */
1519 static long hell_size
= 4;
1520 static SCM hell_mutex
;
1526 for (i
= 1; i
< n_hell
; ++i
)
1527 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1533 go_to_hell (void *o
)
1535 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1536 scm_lock_mutex (hell_mutex
);
1537 if (n_hell
== hell_size
)
1539 long new_size
= 2 * hell_size
;
1540 hell
= scm_realloc (hell
, new_size
);
1541 hell_size
= new_size
;
1543 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1544 scm_unlock_mutex (hell_mutex
);
1548 go_to_heaven (void *o
)
1550 scm_lock_mutex (hell_mutex
);
1551 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1552 scm_unlock_mutex (hell_mutex
);
1556 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1559 purgatory (void *args
)
1561 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1562 SCM_PACK ((scm_t_bits
) args
));
1565 /* This function calls the generic function change-class for all
1566 * instances which aren't currently undergoing class change.
1570 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1573 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1574 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1575 (void *) SCM_UNPACK (obj
));
1578 /******************************************************************************
1584 * GGG E N E R I C F U N C T I O N S
1586 * This implementation provides
1587 * - generic functions (with class specializers)
1590 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1592 ******************************************************************************/
1594 SCM_KEYWORD (k_name
, "name");
1596 SCM_SYMBOL (sym_no_method
, "no-method");
1598 static SCM list_of_no_method
;
1600 SCM_SYMBOL (scm_sym_args
, "args");
1603 scm_make_method_cache (SCM gf
)
1605 return scm_list_5 (SCM_IM_DISPATCH
,
1608 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1614 clear_method_cache (SCM gf
)
1616 SCM cache
= scm_make_method_cache (gf
);
1617 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1618 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1621 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1624 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1627 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1628 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1629 if (!SCM_FALSEP (used_by
))
1631 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1632 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1633 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1634 clear_method_cache (gf
);
1635 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1636 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1639 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1640 /* The sign of n is a flag indicating rest args. */
1641 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1643 return SCM_UNSPECIFIED
;
1647 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1650 #define FUNC_NAME s_scm_generic_capability_p
1652 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1653 proc
, SCM_ARG1
, FUNC_NAME
);
1654 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1660 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1663 #define FUNC_NAME s_scm_enable_primitive_generic_x
1665 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1666 while (!SCM_NULLP (subrs
))
1668 SCM subr
= SCM_CAR (subrs
);
1669 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1670 subr
, SCM_ARGn
, FUNC_NAME
);
1671 *SCM_SUBR_GENERIC (subr
)
1672 = scm_make (scm_list_3 (scm_class_generic
,
1675 subrs
= SCM_CDR (subrs
);
1677 return SCM_UNSPECIFIED
;
1681 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1684 #define FUNC_NAME s_scm_primitive_generic_generic
1686 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1688 if (!*SCM_SUBR_GENERIC (subr
))
1689 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1690 return *SCM_SUBR_GENERIC (subr
);
1692 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1696 typedef struct t_extension
{
1697 struct t_extension
*next
;
1702 static t_extension
*extensions
= 0;
1704 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1707 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1712 if (!*SCM_SUBR_GENERIC (extended
))
1713 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1714 gf
= *SCM_SUBR_GENERIC (extended
);
1715 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1717 SCM_SNAME (extension
));
1718 *SCM_SUBR_GENERIC (extension
) = gext
;
1722 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1723 t_extension
**loc
= &extensions
;
1724 /* Make sure that extensions are placed before their own
1725 * extensions in the extensions list. O(N^2) algorithm, but
1726 * extensions of primitive generics are rare.
1728 while (*loc
&& extension
!= (*loc
)->extended
)
1729 loc
= &(*loc
)->next
;
1731 e
->extended
= extended
;
1732 e
->extension
= extension
;
1738 setup_extended_primitive_generics ()
1742 t_extension
*e
= extensions
;
1743 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1744 extensions
= e
->next
;
1749 /******************************************************************************
1751 * Protocol for calling a generic fumction
1752 * This protocol is roughly equivalent to (parameter are a little bit different
1753 * for efficiency reasons):
1755 * + apply-generic (gf args)
1756 * + compute-applicable-methods (gf args ...)
1757 * + sort-applicable-methods (methods args)
1758 * + apply-methods (gf methods args)
1760 * apply-methods calls make-next-method to build the "continuation" of a a
1761 * method. Applying a next-method will call apply-next-method which in
1762 * turn will call apply again to call effectively the following method.
1764 ******************************************************************************/
1767 applicablep (SCM actual
, SCM formal
)
1769 /* We already know that the cpl is well formed. */
1770 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1774 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1776 register SCM s1
, s2
;
1780 * m1 and m2 can have != length (i.e. one can be one element longer than the
1781 * other when we have a dotted parameter list). For instance, with the call
1784 * (define-method M (a . l) ....)
1785 * (define-method M (a) ....)
1787 * we consider that the second method is more specific.
1789 * BTW, targs is an array of types. We don't need it's size since
1790 * we already know that m1 and m2 are applicable (no risk to go past
1791 * the end of this array).
1794 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1795 if (SCM_NULLP(s1
)) return 1;
1796 if (SCM_NULLP(s2
)) return 0;
1797 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1798 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1800 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1801 if (cs1
== SCM_CAR(l
))
1803 if (cs2
== SCM_CAR(l
))
1806 return 0;/* should not occur! */
1809 return 0; /* should not occur! */
1812 #define BUFFSIZE 32 /* big enough for most uses */
1815 scm_i_vector2list (SCM l
, long len
)
1818 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1820 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1821 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1827 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1830 SCM
*v
, vector
= SCM_EOL
;
1831 SCM buffer
[BUFFSIZE
];
1832 SCM save
= method_list
;
1834 /* For reasonably sized method_lists we can try to avoid all the
1835 * consing and reorder the list in place...
1836 * This idea is due to David McClain <Dave_McClain@msn.com>
1838 if (size
<= BUFFSIZE
)
1840 for (i
= 0; i
< size
; i
++)
1842 buffer
[i
] = SCM_CAR (method_list
);
1843 method_list
= SCM_CDR (method_list
);
1849 /* Too many elements in method_list to keep everything locally */
1850 vector
= scm_i_vector2list (save
, size
);
1853 This is a new vector. Don't worry about the write barrier.
1854 We're not allocating elements in this routine, so this should
1857 v
= SCM_WRITABLE_VELTS (vector
);
1860 /* Use a simple shell sort since it is generally faster than qsort on
1861 * small vectors (which is probably mostly the case when we have to
1862 * sort a list of applicable methods).
1864 for (incr
= size
/ 2; incr
; incr
/= 2)
1866 for (i
= incr
; i
< size
; i
++)
1868 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1870 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1874 SCM tmp
= v
[j
+ incr
];
1882 if (size
<= BUFFSIZE
)
1884 /* We did it in locally, so restore the original list (reordered) in-place */
1885 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1887 SCM_SETCAR (method_list
, *v
);
1888 method_list
= SCM_CDR (method_list
);
1892 /* If we are here, that's that we did it the hard way... */
1893 return scm_vector_to_list (vector
);
1897 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1901 SCM l
, fl
, applicable
= SCM_EOL
;
1903 SCM buffer
[BUFFSIZE
];
1908 /* Build the list of arguments types */
1909 if (len
>= BUFFSIZE
) {
1910 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1911 /* NOTE: Using pointers to malloced memory won't work if we
1912 1. have preemtive threading, and,
1913 2. have a GC which moves objects. */
1914 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1917 note that we don't have to work to reset the generation
1918 count. TMP is a new vector anyway, and it is found
1925 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1926 *p
++ = scm_class_of (SCM_CAR (args
));
1928 /* Build a list of all applicable methods */
1929 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1931 fl
= SPEC_OF (SCM_CAR (l
));
1932 /* Only accept accessors which match exactly in first arg. */
1933 if (SCM_ACCESSORP (SCM_CAR (l
))
1934 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1936 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1938 if (SCM_INSTANCEP (fl
)
1939 /* We have a dotted argument list */
1940 || (i
>= len
&& SCM_NULLP (fl
)))
1941 { /* both list exhausted */
1942 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1948 || !applicablep (types
[i
], SCM_CAR (fl
)))
1957 CALL_GF2 ("no-applicable-method", gf
, save
);
1958 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1962 scm_remember_upto_here_1 (tmp
);
1965 : sort_applicable_methods (applicable
, count
, types
));
1969 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1972 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1975 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1976 #define FUNC_NAME s_sys_compute_applicable_methods
1979 SCM_VALIDATE_GENERIC (1, gf
);
1980 n
= scm_ilength (args
);
1981 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1982 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1986 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1987 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
));
1989 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1992 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1993 #define FUNC_NAME s_atslot_ref
1995 SCM x
= SCM_CDR (xorig
);
1996 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1997 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1998 return scm_cons (SCM_IM_SLOT_REF
, x
);
2003 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
2006 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
2007 #define FUNC_NAME s_atslot_set_x
2009 SCM x
= SCM_CDR (xorig
);
2010 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
2011 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
2012 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
2017 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
2019 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
2022 scm_m_atdispatch (SCM xorig
, SCM env
)
2023 #define FUNC_NAME s_atdispatch
2025 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
2026 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
2028 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
2029 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
2031 n
= SCM_XEVALCAR (x
, env
);
2032 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
2033 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
2035 v
= SCM_XEVALCAR (x
, env
);
2036 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
2038 gf
= SCM_XEVALCAR (x
, env
);
2039 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
2040 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
2046 lock_cache_mutex (void *m
)
2048 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2049 scm_lock_mutex (mutex
);
2053 unlock_cache_mutex (void *m
)
2055 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2056 scm_unlock_mutex (mutex
);
2060 call_memoize_method (void *a
)
2062 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2063 SCM gf
= SCM_CAR (args
);
2064 SCM x
= SCM_CADR (args
);
2065 /* First check if another thread has inserted a method between
2066 * the cache miss and locking the mutex.
2068 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2069 if (!SCM_FALSEP (cmethod
))
2071 /*fixme* Use scm_apply */
2072 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2076 scm_memoize_method (SCM x
, SCM args
)
2078 SCM gf
= SCM_CAR (scm_last_pair (x
));
2079 return scm_internal_dynamic_wind (
2081 call_memoize_method
,
2083 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2084 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2087 /******************************************************************************
2089 * A simple make (which will be redefined later in Scheme)
2090 * This version handles only creation of gf, methods and classes (no instances)
2092 * Since this code will disappear when Goops will be fully booted,
2093 * no precaution is taken to be efficient.
2095 ******************************************************************************/
2097 SCM_KEYWORD (k_setter
, "setter");
2098 SCM_KEYWORD (k_specializers
, "specializers");
2099 SCM_KEYWORD (k_procedure
, "procedure");
2100 SCM_KEYWORD (k_dsupers
, "dsupers");
2101 SCM_KEYWORD (k_slots
, "slots");
2102 SCM_KEYWORD (k_gf
, "generic-function");
2104 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2106 "Make a new object. @var{args} must contain the class and\n"
2107 "all necessary initialization information.")
2108 #define FUNC_NAME s_scm_make
2111 long len
= scm_ilength (args
);
2113 if (len
<= 0 || (len
& 1) == 0)
2114 SCM_WRONG_NUM_ARGS ();
2116 class = SCM_CAR(args
);
2117 args
= SCM_CDR(args
);
2119 if (class == scm_class_generic
|| class == scm_class_accessor
)
2121 z
= scm_make_struct (class, SCM_INUM0
,
2122 scm_list_5 (SCM_EOL
,
2127 scm_set_procedure_property_x (z
, scm_sym_name
,
2128 scm_get_keyword (k_name
,
2131 clear_method_cache (z
);
2132 if (class == scm_class_accessor
)
2134 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2135 if (!SCM_FALSEP (setter
))
2136 scm_sys_set_object_setter_x (z
, setter
);
2141 z
= scm_sys_allocate_instance (class, args
);
2143 if (class == scm_class_method
2144 || class == scm_class_simple_method
2145 || class == scm_class_accessor_method
)
2147 SCM_SET_SLOT (z
, scm_si_generic_function
,
2148 scm_i_get_keyword (k_gf
,
2153 SCM_SET_SLOT (z
, scm_si_specializers
,
2154 scm_i_get_keyword (k_specializers
,
2159 SCM_SET_SLOT (z
, scm_si_procedure
,
2160 scm_i_get_keyword (k_procedure
,
2165 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2169 /* In all the others case, make a new class .... No instance here */
2170 SCM_SET_SLOT (z
, scm_si_name
,
2171 scm_i_get_keyword (k_name
,
2174 scm_str2symbol ("???"),
2176 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2177 scm_i_get_keyword (k_dsupers
,
2182 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2183 scm_i_get_keyword (k_slots
,
2194 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2197 #define FUNC_NAME s_scm_find_method
2200 long len
= scm_ilength (l
);
2203 SCM_WRONG_NUM_ARGS ();
2205 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2206 SCM_VALIDATE_GENERIC (1, gf
);
2207 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2208 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2210 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2214 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2215 (SCM m1
, SCM m2
, SCM targs
),
2217 #define FUNC_NAME s_scm_sys_method_more_specific_p
2222 SCM_VALIDATE_METHOD (1, m1
);
2223 SCM_VALIDATE_METHOD (2, m2
);
2224 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2226 /* Verify that all the arguments of targs are classes and place them in a vector*/
2227 v
= scm_c_make_vector (len
, SCM_EOL
);
2229 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2230 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2231 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2233 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2239 /******************************************************************************
2243 ******************************************************************************/
2246 fix_cpl (SCM c
, SCM before
, SCM after
)
2248 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2249 SCM ls
= scm_c_memq (after
, cpl
);
2250 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2251 if (SCM_FALSEP (ls
))
2252 /* if this condition occurs, fix_cpl should not be applied this way */
2254 SCM_SETCAR (ls
, before
);
2255 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2257 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2258 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2259 SCM g_n_s
= compute_getters_n_setters (slots
);
2260 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2261 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2267 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2269 SCM tmp
= scm_str2symbol (name
);
2271 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2275 : scm_list_1 (super
),
2281 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2284 create_standard_classes (void)
2287 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2288 scm_str2symbol ("specializers"),
2290 scm_str2symbol ("code-table"));
2291 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2293 k_slot_definition
));
2294 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2295 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2296 scm_list_3 (scm_str2symbol ("n-specialized"),
2299 scm_list_3 (scm_str2symbol ("used-by"),
2302 scm_list_3 (scm_str2symbol ("cache-mutex"),
2304 scm_closure (scm_list_2 (SCM_EOL
,
2307 scm_list_3 (scm_str2symbol ("extended-by"),
2310 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2313 /* Foreign class slot classes */
2314 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2315 scm_class_class
, scm_class_top
, SCM_EOL
);
2316 make_stdcls (&scm_class_protected
, "<protected-slot>",
2317 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2318 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2319 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2320 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2321 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2322 make_stdcls (&scm_class_self
, "<self-slot>",
2324 scm_class_read_only
,
2326 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2328 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2330 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2332 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2334 make_stdcls (&scm_class_scm
, "<scm-slot>",
2335 scm_class_class
, scm_class_protected
, SCM_EOL
);
2336 make_stdcls (&scm_class_int
, "<int-slot>",
2337 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2338 make_stdcls (&scm_class_float
, "<float-slot>",
2339 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2340 make_stdcls (&scm_class_double
, "<double-slot>",
2341 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2343 /* Continue initialization of class <class> */
2345 slots
= build_class_class_slots ();
2346 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2347 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2348 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2349 compute_getters_n_setters (slots
));
2351 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2352 scm_class_class
, scm_class_class
,
2353 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2356 scm_list_3 (scm_str2symbol ("destructor"),
2358 scm_class_opaque
)));
2359 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2360 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2361 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2363 /* scm_class_generic functions classes */
2364 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2365 scm_class_class
, scm_class_class
, SCM_EOL
);
2366 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2367 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2368 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2369 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2370 make_stdcls (&scm_class_operator_with_setter_class
,
2371 "<operator-with-setter-class>",
2372 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2373 make_stdcls (&scm_class_method
, "<method>",
2374 scm_class_class
, scm_class_object
, method_slots
);
2375 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2376 scm_class_class
, scm_class_method
, SCM_EOL
);
2377 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2378 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2379 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2380 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2381 make_stdcls (&scm_class_applicable
, "<applicable>",
2382 scm_class_class
, scm_class_top
, SCM_EOL
);
2383 make_stdcls (&scm_class_entity
, "<entity>",
2384 scm_class_entity_class
,
2385 scm_list_2 (scm_class_object
, scm_class_applicable
),
2387 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2388 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2389 make_stdcls (&scm_class_generic
, "<generic>",
2390 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2391 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2392 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2393 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2394 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2395 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2396 scm_class_entity_class
,
2397 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2399 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2400 make_stdcls (&scm_class_accessor
, "<accessor>",
2401 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2402 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2403 make_stdcls (&scm_class_extended_generic_with_setter
,
2404 "<extended-generic-with-setter>",
2405 scm_class_entity_class
,
2406 scm_list_2 (scm_class_generic_with_setter
,
2407 scm_class_extended_generic
),
2409 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2410 SCM_CLASSF_PURE_GENERIC
);
2411 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2412 scm_class_entity_class
,
2413 scm_list_2 (scm_class_accessor
,
2414 scm_class_extended_generic_with_setter
),
2416 fix_cpl (scm_class_extended_accessor
,
2417 scm_class_extended_generic
, scm_class_generic
);
2418 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2420 /* Primitive types classes */
2421 make_stdcls (&scm_class_boolean
, "<boolean>",
2422 scm_class_class
, scm_class_top
, SCM_EOL
);
2423 make_stdcls (&scm_class_char
, "<char>",
2424 scm_class_class
, scm_class_top
, SCM_EOL
);
2425 make_stdcls (&scm_class_list
, "<list>",
2426 scm_class_class
, scm_class_top
, SCM_EOL
);
2427 make_stdcls (&scm_class_pair
, "<pair>",
2428 scm_class_class
, scm_class_list
, SCM_EOL
);
2429 make_stdcls (&scm_class_null
, "<null>",
2430 scm_class_class
, scm_class_list
, SCM_EOL
);
2431 make_stdcls (&scm_class_string
, "<string>",
2432 scm_class_class
, scm_class_top
, SCM_EOL
);
2433 make_stdcls (&scm_class_symbol
, "<symbol>",
2434 scm_class_class
, scm_class_top
, SCM_EOL
);
2435 make_stdcls (&scm_class_vector
, "<vector>",
2436 scm_class_class
, scm_class_top
, SCM_EOL
);
2437 make_stdcls (&scm_class_number
, "<number>",
2438 scm_class_class
, scm_class_top
, SCM_EOL
);
2439 make_stdcls (&scm_class_complex
, "<complex>",
2440 scm_class_class
, scm_class_number
, SCM_EOL
);
2441 make_stdcls (&scm_class_real
, "<real>",
2442 scm_class_class
, scm_class_complex
, SCM_EOL
);
2443 make_stdcls (&scm_class_integer
, "<integer>",
2444 scm_class_class
, scm_class_real
, SCM_EOL
);
2445 make_stdcls (&scm_class_keyword
, "<keyword>",
2446 scm_class_class
, scm_class_top
, SCM_EOL
);
2447 make_stdcls (&scm_class_unknown
, "<unknown>",
2448 scm_class_class
, scm_class_top
, SCM_EOL
);
2449 make_stdcls (&scm_class_procedure
, "<procedure>",
2450 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2451 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2452 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2453 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2454 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2455 make_stdcls (&scm_class_port
, "<port>",
2456 scm_class_class
, scm_class_top
, SCM_EOL
);
2457 make_stdcls (&scm_class_input_port
, "<input-port>",
2458 scm_class_class
, scm_class_port
, SCM_EOL
);
2459 make_stdcls (&scm_class_output_port
, "<output-port>",
2460 scm_class_class
, scm_class_port
, SCM_EOL
);
2461 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2463 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2467 /**********************************************************************
2471 **********************************************************************/
2474 make_class_from_template (char *template, char *type_name
, SCM supers
, int applicablep
)
2480 sprintf (buffer
, template, type_name
);
2481 name
= scm_str2symbol (buffer
);
2484 name
= SCM_GOOPS_UNBOUND
;
2486 class = scm_permanent_object (scm_basic_make_class (applicablep
2487 ? scm_class_procedure_class
2493 /* Only define name if doesn't already exist. */
2494 if (!SCM_GOOPS_UNBOUNDP (name
)
2495 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2496 DEFVAR (name
, class);
2501 scm_make_extended_class (char *type_name
, int applicablep
)
2503 return make_class_from_template ("<%s>",
2505 scm_list_1 (applicablep
2506 ? scm_class_applicable
2512 scm_i_inherit_applicable (SCM c
)
2514 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2516 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2517 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2518 /* patch scm_class_applicable into direct-supers */
2519 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2520 if (SCM_FALSEP (top
))
2521 dsupers
= scm_append (scm_list_2 (dsupers
,
2522 scm_list_1 (scm_class_applicable
)));
2525 SCM_SETCAR (top
, scm_class_applicable
);
2526 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2528 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2529 /* patch scm_class_applicable into cpl */
2530 top
= scm_c_memq (scm_class_top
, cpl
);
2531 if (SCM_FALSEP (top
))
2535 SCM_SETCAR (top
, scm_class_applicable
);
2536 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2538 /* add class to direct-subclasses of scm_class_applicable */
2539 SCM_SET_SLOT (scm_class_applicable
,
2540 scm_si_direct_subclasses
,
2541 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2542 scm_si_direct_subclasses
)));
2547 create_smob_classes (void)
2551 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2552 for (i
= 0; i
< 255; ++i
)
2553 scm_smob_class
[i
] = 0;
2555 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2556 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2557 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2558 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2560 for (i
= 0; i
< scm_numsmob
; ++i
)
2561 if (!scm_smob_class
[i
])
2562 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2563 scm_smobs
[i
].apply
!= 0);
2567 scm_make_port_classes (long ptobnum
, char *type_name
)
2569 SCM c
, class = make_class_from_template ("<%s-port>",
2571 scm_list_1 (scm_class_port
),
2573 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2574 = make_class_from_template ("<%s-input-port>",
2576 scm_list_2 (class, scm_class_input_port
),
2578 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2579 = make_class_from_template ("<%s-output-port>",
2581 scm_list_2 (class, scm_class_output_port
),
2583 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2585 = make_class_from_template ("<%s-input-output-port>",
2587 scm_list_2 (class, scm_class_input_output_port
),
2589 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2590 SCM_SET_SLOT (c
, scm_si_cpl
,
2591 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2595 create_port_classes (void)
2599 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2600 for (i
= 0; i
< 3 * 256; ++i
)
2601 scm_port_class
[i
] = 0;
2603 for (i
= 0; i
< scm_numptob
; ++i
)
2604 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2608 make_struct_class (void *closure SCM_UNUSED
,
2609 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2611 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2612 SCM_SET_STRUCT_TABLE_CLASS (data
,
2613 scm_make_extended_class
2614 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
)),
2615 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2616 return SCM_UNSPECIFIED
;
2620 create_struct_classes (void)
2622 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2625 /**********************************************************************
2629 **********************************************************************/
2634 if (!goops_loaded_p
)
2635 scm_c_resolve_module ("oop goops");
2640 scm_make_foreign_object (SCM
class, SCM initargs
)
2641 #define FUNC_NAME s_scm_make
2643 void * (*constructor
) (SCM
)
2644 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2645 if (constructor
== 0)
2646 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2647 return scm_wrap_object (class, constructor (initargs
));
2653 scm_free_foreign_object (SCM
*class, SCM
*data
)
2655 size_t (*destructor
) (void *)
2656 = (size_t (*) (void *)) class[scm_si_destructor
];
2657 return destructor (data
);
2661 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2662 void * (*constructor
) (SCM initargs
),
2663 size_t (*destructor
) (void *))
2666 name
= scm_str2symbol (s_name
);
2667 if (SCM_NULLP (supers
))
2668 supers
= scm_list_1 (scm_class_foreign_object
);
2669 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2670 scm_sys_inherit_magic_x (class, supers
);
2672 if (destructor
!= 0)
2674 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2675 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2679 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2680 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2683 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2684 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2689 SCM_SYMBOL (sym_o
, "o");
2690 SCM_SYMBOL (sym_x
, "x");
2692 SCM_KEYWORD (k_accessor
, "accessor");
2693 SCM_KEYWORD (k_getter
, "getter");
2696 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2698 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2703 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2704 SCM (*getter
) (SCM obj
),
2705 SCM (*setter
) (SCM obj
, SCM x
),
2706 char *accessor_name
)
2709 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2710 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2711 setter
? setter
: default_setter
);
2712 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2713 scm_list_2 (get
, sym_o
)),
2715 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2716 scm_list_3 (set
, sym_o
, sym_x
)),
2719 SCM name
= scm_str2symbol (slot_name
);
2720 SCM aname
= scm_str2symbol (accessor_name
);
2721 SCM gf
= scm_ensure_accessor (aname
);
2722 SCM slot
= scm_list_5 (name
,
2725 setter
? k_accessor
: k_getter
,
2727 SCM gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2729 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2734 scm_add_method (scm_setter (gf
),
2735 scm_make (scm_list_5 (scm_class_accessor_method
,
2737 scm_list_2 (class, scm_class_top
),
2742 SCM_SET_SLOT (class, scm_si_slots
,
2743 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2744 scm_list_1 (slot
))));
2745 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2746 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2747 scm_list_1 (gns
))));
2751 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2753 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2758 scm_wrap_object (SCM
class, void *data
)
2760 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2768 scm_wrap_component (SCM
class, SCM container
, void *data
)
2770 SCM obj
= scm_wrap_object (class, data
);
2771 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2777 SCM_SETCDR (handle
, container
);
2782 scm_ensure_accessor (SCM name
)
2784 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2785 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2787 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2788 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2789 k_name
, name
, k_setter
, gf
));
2794 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2797 scm_add_method (SCM gf
, SCM m
)
2799 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2804 * Debugging utilities
2807 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2809 "Return @code{#t} if @var{obj} is a pure generic.")
2810 #define FUNC_NAME s_scm_pure_generic_p
2812 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2816 #endif /* GUILE_DEBUG */
2822 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2824 "Announce that GOOPS is loaded and perform initialization\n"
2825 "on the C level which depends on the loaded GOOPS modules.")
2826 #define FUNC_NAME s_scm_sys_goops_loaded
2829 var_compute_applicable_methods
=
2830 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2832 setup_extended_primitive_generics ();
2833 return SCM_UNSPECIFIED
;
2837 SCM scm_module_goops
;
2840 scm_init_goops_builtins (void)
2842 scm_module_goops
= scm_current_module ();
2843 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2845 /* Not really necessary right now, but who knows...
2847 scm_permanent_object (scm_module_goops
);
2848 scm_permanent_object (scm_goops_lookup_closure
);
2850 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2851 (SCM_MAKINUM (37)));
2853 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2855 #include "libguile/goops.x"
2857 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2859 hell
= scm_malloc (hell_size
);
2860 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2862 create_basic_classes ();
2863 create_standard_classes ();
2864 create_smob_classes ();
2865 create_struct_classes ();
2866 create_port_classes ();
2869 SCM name
= scm_str2symbol ("no-applicable-method");
2870 scm_no_applicable_method
2871 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2874 DEFVAR (name
, scm_no_applicable_method
);
2877 return SCM_UNSPECIFIED
;
2883 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2884 scm_init_goops_builtins
);