1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This software is a derivative work of other copyrighted softwares; the
21 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 * This file is based upon stklos.c from the STk distribution by
24 * Erick Gallesio <eg@unice.fr>.
29 #include "libguile/_scm.h"
30 #include "libguile/alist.h"
31 #include "libguile/debug.h"
32 #include "libguile/dynl.h"
33 #include "libguile/dynwind.h"
34 #include "libguile/eval.h"
35 #include "libguile/hashtab.h"
36 #include "libguile/keywords.h"
37 #include "libguile/macros.h"
38 #include "libguile/modules.h"
39 #include "libguile/objects.h"
40 #include "libguile/ports.h"
41 #include "libguile/procprop.h"
42 #include "libguile/random.h"
43 #include "libguile/root.h"
44 #include "libguile/smob.h"
45 #include "libguile/strings.h"
46 #include "libguile/strports.h"
47 #include "libguile/vectors.h"
48 #include "libguile/weaks.h"
50 #include "libguile/validate.h"
51 #include "libguile/goops.h"
53 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
55 #define DEFVAR(v, val) \
56 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
58 /* Temporary hack until we get the new module system */
59 /*fixme* Should optimize by keeping track of the variable object itself */
60 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
63 /* Fixme: Should use already interned symbols */
64 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
66 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
68 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
70 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
73 /* Class redefinition protocol:
75 A class is represented by a heap header h1 which points to a
76 malloc:ed memory block m1.
78 When a new version of a class is created, a new header h2 and
79 memory block m2 are allocated. The headers h1 and h2 then switch
80 pointers so that h1 refers to m2 and h2 to m1. In this way, names
81 bound to h1 will point to the new class at the same time as h2 will
82 be a handle which the GC will us to free m1.
84 The `redefined' slot of m1 will be set to point to h1. An old
85 instance will have it's class pointer (the CAR of the heap header)
86 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
87 the class modification and the new class pointer can be found via
91 /* The following definition is located in libguile/objects.h:
92 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
95 #define TEST_CHANGE_CLASS(obj, class) \
97 class = SCM_CLASS_OF (obj); \
98 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
100 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
101 class = SCM_CLASS_OF (obj); \
105 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
106 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
108 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
109 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
111 static int goops_loaded_p
= 0;
112 static scm_t_rstate
*goops_rstate
;
114 static SCM scm_goops_lookup_closure
;
116 /* Some classes are defined in libguile/objects.c. */
117 SCM scm_class_top
, scm_class_object
, scm_class_class
;
118 SCM scm_class_applicable
;
119 SCM scm_class_entity
, scm_class_entity_with_setter
;
120 SCM scm_class_generic
, scm_class_generic_with_setter
;
121 SCM scm_class_accessor
;
122 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
123 SCM scm_class_extended_accessor
;
124 SCM scm_class_method
;
125 SCM scm_class_simple_method
, scm_class_accessor_method
;
126 SCM scm_class_procedure_class
;
127 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
128 SCM scm_class_entity_class
;
129 SCM scm_class_number
, scm_class_list
;
130 SCM scm_class_keyword
;
131 SCM scm_class_port
, scm_class_input_output_port
;
132 SCM scm_class_input_port
, scm_class_output_port
;
133 SCM scm_class_foreign_class
, scm_class_foreign_object
;
134 SCM scm_class_foreign_slot
;
135 SCM scm_class_self
, scm_class_protected
;
136 SCM scm_class_opaque
, scm_class_read_only
;
137 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
139 SCM scm_class_int
, scm_class_float
, scm_class_double
;
141 SCM_SYMBOL (scm_sym_define_public
, "define-public");
143 static SCM
scm_make_unbound (void);
144 static SCM
scm_unbound_p (SCM obj
);
145 static SCM
scm_assert_bound (SCM value
, SCM obj
);
146 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
147 static SCM
scm_sys_goops_loaded (void);
149 /******************************************************************************
153 * This version doesn't fully handle multiple-inheritance. It serves
154 * only for booting classes and will be overloaded in Scheme
156 ******************************************************************************/
159 map (SCM (*proc
) (SCM
), SCM ls
)
165 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
168 while (!SCM_NULLP (ls
))
170 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
182 while (!SCM_NULLP (ls
))
184 SCM el
= SCM_CAR (ls
);
185 if (scm_is_false (scm_c_memq (el
, res
)))
186 res
= scm_cons (el
, res
);
193 compute_cpl (SCM
class)
196 return CALL_GF1 ("compute-cpl", class);
199 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
200 SCM ls
= scm_append (scm_acons (class, supers
,
201 map (compute_cpl
, supers
)));
202 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
206 /******************************************************************************
210 ******************************************************************************/
213 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
221 if (!SCM_SYMBOLP (tmp
))
222 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
224 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
225 res
= scm_cons (SCM_CAR (l
), res
);
226 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
229 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
233 build_slots_list (SCM dslots
, SCM cpl
)
235 register SCM res
= dslots
;
237 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
238 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
239 scm_si_direct_slots
),
242 /* res contains a list of slots. Remove slots which appears more than once */
243 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
250 while (!SCM_NULLP (ls
))
252 if (!SCM_CONSP (SCM_CAR (ls
)))
253 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
260 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
262 "Return a list consisting of the names of all slots belonging to\n"
263 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
265 #define FUNC_NAME s_scm_sys_compute_slots
267 SCM_VALIDATE_CLASS (1, class);
268 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
269 SCM_SLOT (class, scm_si_cpl
));
274 /******************************************************************************
276 * compute-getters-n-setters
278 * This version doesn't handle slot options. It serves only for booting
279 * classes and will be overloaded in Scheme.
281 ******************************************************************************/
283 SCM_KEYWORD (k_init_value
, "init-value");
284 SCM_KEYWORD (k_init_thunk
, "init-thunk");
287 compute_getters_n_setters (SCM slots
)
293 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
295 SCM init
= SCM_BOOL_F
;
296 SCM options
= SCM_CDAR (slots
);
297 if (!SCM_NULLP (options
))
299 init
= scm_get_keyword (k_init_value
, options
, 0);
302 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
304 scm_list_2 (scm_sym_quote
,
309 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
311 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
313 scm_from_int (i
++))),
315 cdrloc
= SCM_CDRLOC (*cdrloc
);
320 /******************************************************************************
324 ******************************************************************************/
326 /*fixme* Manufacture keywords in advance */
328 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
332 for (i
= 0; i
!= len
; i
+= 2)
334 SCM obj
= SCM_CAR (l
);
336 if (!SCM_KEYWORDP (obj
))
337 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
338 else if (SCM_EQ_P (obj
, key
))
344 return default_value
;
348 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
349 (SCM key
, SCM l
, SCM default_value
),
350 "Determine an associated value for the keyword @var{key} from\n"
351 "the list @var{l}. The list @var{l} has to consist of an even\n"
352 "number of elements, where, starting with the first, every\n"
353 "second element is a keyword, followed by its associated value.\n"
354 "If @var{l} does not hold a value for @var{key}, the value\n"
355 "@var{default_value} is returned.")
356 #define FUNC_NAME s_scm_get_keyword
360 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
361 len
= scm_ilength (l
);
362 if (len
< 0 || len
% 2 == 1)
363 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
365 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
370 SCM_KEYWORD (k_init_keyword
, "init-keyword");
372 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
373 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
375 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
376 (SCM obj
, SCM initargs
),
377 "Initialize the object @var{obj} with the given arguments\n"
379 #define FUNC_NAME s_scm_sys_initialize_object
381 SCM tmp
, get_n_set
, slots
;
382 SCM
class = SCM_CLASS_OF (obj
);
385 SCM_VALIDATE_INSTANCE (1, obj
);
386 n_initargs
= scm_ilength (initargs
);
387 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
389 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
390 slots
= SCM_SLOT (class, scm_si_slots
);
392 /* See for each slot how it must be initialized */
395 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
397 SCM slot_name
= SCM_CAR (slots
);
400 if (!SCM_NULLP (SCM_CDR (slot_name
)))
402 /* This slot admits (perhaps) to be initialized at creation time */
403 long n
= scm_ilength (SCM_CDR (slot_name
));
404 if (n
& 1) /* odd or -1 */
405 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
406 scm_list_1 (slot_name
));
407 tmp
= scm_i_get_keyword (k_init_keyword
,
412 slot_name
= SCM_CAR (slot_name
);
415 /* an initarg was provided for this slot */
416 if (!SCM_KEYWORDP (tmp
))
417 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
419 slot_value
= scm_i_get_keyword (tmp
,
428 /* set slot to provided value */
429 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
432 /* set slot to its :init-form if it exists */
433 tmp
= SCM_CADAR (get_n_set
);
434 if (scm_is_true (tmp
))
436 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
437 if (SCM_GOOPS_UNBOUNDP (slot_value
))
439 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
440 set_slot_value (class,
443 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
453 /* NOTE: The following macros are interdependent with code
454 * in goops.scm:compute-getters-n-setters
456 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
457 (SCM_I_INUMP (SCM_CDDR (gns)) \
458 || (SCM_CONSP (SCM_CDDR (gns)) \
459 && SCM_CONSP (SCM_CDDDR (gns)) \
460 && SCM_CONSP (SCM_CDDDDR (gns))))
461 #define SCM_GNS_INDEX(gns) \
462 (SCM_I_INUMP (SCM_CDDR (gns)) \
463 ? SCM_I_INUM (SCM_CDDR (gns)) \
464 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
465 #define SCM_GNS_SIZE(gns) \
466 (SCM_I_INUMP (SCM_CDDR (gns)) \
468 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
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
479 SCM slots
, getters_n_setters
, nfields
;
480 unsigned long int n
, i
;
483 SCM_VALIDATE_INSTANCE (1, class);
484 slots
= SCM_SLOT (class, scm_si_slots
);
485 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
486 nfields
= SCM_SLOT (class, scm_si_nfields
);
487 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
488 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
489 scm_list_1 (nfields
));
490 n
= 2 * SCM_I_INUM (nfields
);
491 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
492 && SCM_SUBCLASSP (class, scm_class_class
))
493 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
494 scm_list_1 (nfields
));
496 s
= n
> 0 ? scm_malloc (n
) : 0;
498 while (SCM_CONSP (getters_n_setters
))
500 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
503 int len
, index
, size
;
506 if (i
>= n
|| !SCM_CONSP (slots
))
509 /* extract slot type */
510 len
= scm_ilength (SCM_CDAR (slots
));
511 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
512 len
, SCM_BOOL_F
, FUNC_NAME
);
513 /* determine slot GC protection and access mode */
514 if (scm_is_false (type
))
521 if (!SCM_CLASSP (type
))
525 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
527 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
529 if (SCM_SUBCLASSP (type
, scm_class_self
))
531 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
536 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
538 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
550 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
551 if (index
!= (i
>> 1))
553 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
561 slots
= SCM_CDR (slots
);
562 getters_n_setters
= SCM_CDR (getters_n_setters
);
564 if (!SCM_NULLP (slots
))
569 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
571 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
574 return SCM_UNSPECIFIED
;
578 static void prep_hashsets (SCM
);
580 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
581 (SCM
class, SCM dsupers
),
583 #define FUNC_NAME s_scm_sys_inherit_magic_x
587 SCM_VALIDATE_INSTANCE (1, class);
588 while (!SCM_NULLP (ls
))
590 SCM_ASSERT (SCM_CONSP (ls
)
591 && SCM_INSTANCEP (SCM_CAR (ls
)),
595 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
598 flags
&= SCM_CLASSF_INHERIT
;
599 if (flags
& SCM_CLASSF_ENTITY
)
600 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
603 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
606 * We could avoid calling scm_gc_malloc in the allocation code
607 * (in which case the following two lines are needed). Instead
608 * we make 0-slot instances non-light, so that the light case
609 * can be handled without special cases.
612 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
614 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
616 /* NOTE: The following depends on scm_struct_i_size. */
617 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
618 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
621 SCM_SET_CLASS_FLAGS (class, flags
);
623 prep_hashsets (class);
625 return SCM_UNSPECIFIED
;
630 prep_hashsets (SCM
class)
634 for (i
= 0; i
< 7; ++i
)
635 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
638 /******************************************************************************/
641 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
643 SCM z
, cpl
, slots
, nfields
, g_n_s
;
645 /* Allocate one instance */
646 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
648 /* Initialize its slots */
649 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
650 cpl
= compute_cpl (z
);
651 slots
= build_slots_list (maplist (dslots
), cpl
);
652 nfields
= scm_from_int (scm_ilength (slots
));
653 g_n_s
= compute_getters_n_setters (slots
);
655 SCM_SET_SLOT (z
, scm_si_name
, name
);
656 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
657 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
658 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
659 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
660 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
661 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
662 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
663 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
664 SCM_SET_SLOT (z
, scm_si_environment
,
665 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
667 /* Add this class in the direct-subclasses slot of dsupers */
670 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
671 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
672 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
673 scm_si_direct_subclasses
)));
676 /* Support for the underlying structs: */
677 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
678 ? (SCM_CLASSF_GOOPS_OR_VALID
679 | SCM_CLASSF_OPERATOR
681 : class == scm_class_operator_class
682 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
683 : SCM_CLASSF_GOOPS_OR_VALID
));
688 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
690 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
691 scm_sys_inherit_magic_x (z
, dsupers
);
692 scm_sys_prep_layout_x (z
);
696 /******************************************************************************/
698 SCM_SYMBOL (sym_layout
, "layout");
699 SCM_SYMBOL (sym_vcell
, "vcell");
700 SCM_SYMBOL (sym_vtable
, "vtable");
701 SCM_SYMBOL (sym_print
, "print");
702 SCM_SYMBOL (sym_procedure
, "procedure");
703 SCM_SYMBOL (sym_setter
, "setter");
704 SCM_SYMBOL (sym_redefined
, "redefined");
705 SCM_SYMBOL (sym_h0
, "h0");
706 SCM_SYMBOL (sym_h1
, "h1");
707 SCM_SYMBOL (sym_h2
, "h2");
708 SCM_SYMBOL (sym_h3
, "h3");
709 SCM_SYMBOL (sym_h4
, "h4");
710 SCM_SYMBOL (sym_h5
, "h5");
711 SCM_SYMBOL (sym_h6
, "h6");
712 SCM_SYMBOL (sym_h7
, "h7");
713 SCM_SYMBOL (sym_name
, "name");
714 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
715 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
716 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
717 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
718 SCM_SYMBOL (sym_cpl
, "cpl");
719 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
720 SCM_SYMBOL (sym_slots
, "slots");
721 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
722 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
723 SCM_SYMBOL (sym_nfields
, "nfields");
724 SCM_SYMBOL (sym_environment
, "environment");
728 build_class_class_slots ()
731 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
732 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
733 scm_list_1 (sym_print
),
734 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
735 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
736 scm_list_1 (sym_redefined
),
737 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
738 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
739 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
740 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
741 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
742 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
743 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
744 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
745 scm_list_1 (sym_name
),
746 scm_list_1 (sym_direct_supers
),
747 scm_list_1 (sym_direct_slots
),
748 scm_list_1 (sym_direct_subclasses
),
749 scm_list_1 (sym_direct_methods
),
750 scm_list_1 (sym_cpl
),
751 scm_list_1 (sym_default_slot_definition_class
),
752 scm_list_1 (sym_slots
),
753 scm_list_1 (sym_getters_n_setters
),
754 scm_list_1 (sym_keyword_access
),
755 scm_list_1 (sym_nfields
),
756 scm_list_1 (sym_environment
),
761 create_basic_classes (void)
763 /* SCM slots_of_class = build_class_class_slots (); */
765 /**** <scm_class_class> ****/
766 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
767 + 2 * scm_vtable_offset_user
);
768 SCM name
= scm_str2symbol ("<class>");
769 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
772 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
773 | SCM_CLASSF_METACLASS
));
775 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
776 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
777 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
778 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
779 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
780 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
781 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
782 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
783 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
784 compute_getters_n_setters (slots_of_class)); */
785 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
786 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
787 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
789 prep_hashsets (scm_class_class
);
791 DEFVAR(name
, scm_class_class
);
793 /**** <scm_class_top> ****/
794 name
= scm_str2symbol ("<top>");
795 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
800 DEFVAR(name
, scm_class_top
);
802 /**** <scm_class_object> ****/
803 name
= scm_str2symbol ("<object>");
804 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
806 scm_list_1 (scm_class_top
),
809 DEFVAR (name
, scm_class_object
);
811 /* <top> <object> and <class> were partially initialized. Correct them here */
812 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
814 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
815 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
818 /******************************************************************************/
820 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
822 "Return @code{#t} if @var{obj} is an instance.")
823 #define FUNC_NAME s_scm_instance_p
825 return scm_from_bool (SCM_INSTANCEP (obj
));
830 /******************************************************************************
832 * Meta object accessors
834 ******************************************************************************/
835 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
837 "Return the class name of @var{obj}.")
838 #define FUNC_NAME s_scm_class_name
840 SCM_VALIDATE_CLASS (1, obj
);
841 return scm_slot_ref (obj
, sym_name
);
845 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
847 "Return the direct superclasses of the class @var{obj}.")
848 #define FUNC_NAME s_scm_class_direct_supers
850 SCM_VALIDATE_CLASS (1, obj
);
851 return scm_slot_ref (obj
, sym_direct_supers
);
855 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
857 "Return the direct slots of the class @var{obj}.")
858 #define FUNC_NAME s_scm_class_direct_slots
860 SCM_VALIDATE_CLASS (1, obj
);
861 return scm_slot_ref (obj
, sym_direct_slots
);
865 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
867 "Return the direct subclasses of the class @var{obj}.")
868 #define FUNC_NAME s_scm_class_direct_subclasses
870 SCM_VALIDATE_CLASS (1, obj
);
871 return scm_slot_ref(obj
, sym_direct_subclasses
);
875 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
877 "Return the direct methods of the class @var{obj}")
878 #define FUNC_NAME s_scm_class_direct_methods
880 SCM_VALIDATE_CLASS (1, obj
);
881 return scm_slot_ref (obj
, sym_direct_methods
);
885 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
887 "Return the class precedence list of the class @var{obj}.")
888 #define FUNC_NAME s_scm_class_precedence_list
890 SCM_VALIDATE_CLASS (1, obj
);
891 return scm_slot_ref (obj
, sym_cpl
);
895 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
897 "Return the slot list of the class @var{obj}.")
898 #define FUNC_NAME s_scm_class_slots
900 SCM_VALIDATE_CLASS (1, obj
);
901 return scm_slot_ref (obj
, sym_slots
);
905 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
907 "Return the environment of the class @var{obj}.")
908 #define FUNC_NAME s_scm_class_environment
910 SCM_VALIDATE_CLASS (1, obj
);
911 return scm_slot_ref(obj
, sym_environment
);
916 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
918 "Return the name of the generic function @var{obj}.")
919 #define FUNC_NAME s_scm_generic_function_name
921 SCM_VALIDATE_GENERIC (1, obj
);
922 return scm_procedure_property (obj
, scm_sym_name
);
926 SCM_SYMBOL (sym_methods
, "methods");
927 SCM_SYMBOL (sym_extended_by
, "extended-by");
928 SCM_SYMBOL (sym_extends
, "extends");
931 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
933 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
934 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
935 while (!SCM_NULLP (gfs
))
937 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
944 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
946 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
948 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
949 while (!SCM_NULLP (gfs
))
951 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
952 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
961 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
963 "Return the methods of the generic function @var{obj}.")
964 #define FUNC_NAME s_scm_generic_function_methods
967 SCM_VALIDATE_GENERIC (1, obj
);
968 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
969 methods
= fold_downward_gf_methods (methods
, obj
);
970 return scm_append (methods
);
974 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
976 "Return the generic function for the method @var{obj}.")
977 #define FUNC_NAME s_scm_method_generic_function
979 SCM_VALIDATE_METHOD (1, obj
);
980 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
984 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
986 "Return specializers of the method @var{obj}.")
987 #define FUNC_NAME s_scm_method_specializers
989 SCM_VALIDATE_METHOD (1, obj
);
990 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
994 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
996 "Return the procedure of the method @var{obj}.")
997 #define FUNC_NAME s_scm_method_procedure
999 SCM_VALIDATE_METHOD (1, obj
);
1000 return scm_slot_ref (obj
, sym_procedure
);
1004 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1006 "Return the slot definition of the accessor @var{obj}.")
1007 #define FUNC_NAME s_scm_accessor_method_slot_definition
1009 SCM_VALIDATE_ACCESSOR (1, obj
);
1010 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
1014 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1016 "Internal GOOPS magic---don't use this function!")
1017 #define FUNC_NAME s_scm_sys_tag_body
1019 return scm_cons (SCM_IM_LAMBDA
, body
);
1023 /******************************************************************************
1025 * S l o t a c c e s s
1027 ******************************************************************************/
1029 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1031 "Return the unbound value.")
1032 #define FUNC_NAME s_scm_make_unbound
1034 return SCM_GOOPS_UNBOUND
;
1038 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1040 "Return @code{#t} if @var{obj} is unbound.")
1041 #define FUNC_NAME s_scm_unbound_p
1043 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1047 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1048 (SCM value
, SCM obj
),
1049 "Return @var{value} if it is bound, and invoke the\n"
1050 "@var{slot-unbound} method of @var{obj} if it is not.")
1051 #define FUNC_NAME s_scm_assert_bound
1053 if (SCM_GOOPS_UNBOUNDP (value
))
1054 return CALL_GF1 ("slot-unbound", obj
);
1059 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1060 (SCM obj
, SCM index
),
1061 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1062 "the value from @var{obj}.")
1063 #define FUNC_NAME s_scm_at_assert_bound_ref
1065 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1066 if (SCM_GOOPS_UNBOUNDP (value
))
1067 return CALL_GF1 ("slot-unbound", obj
);
1072 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1073 (SCM obj
, SCM index
),
1074 "Return the slot value with index @var{index} from @var{obj}.")
1075 #define FUNC_NAME s_scm_sys_fast_slot_ref
1077 unsigned long int i
;
1079 SCM_VALIDATE_INSTANCE (1, obj
);
1080 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1081 return SCM_SLOT (obj
, i
);
1085 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1086 (SCM obj
, SCM index
, SCM value
),
1087 "Set the slot with index @var{index} in @var{obj} to\n"
1089 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1091 unsigned long int i
;
1093 SCM_VALIDATE_INSTANCE (1, obj
);
1094 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1096 SCM_SET_SLOT (obj
, i
, value
);
1098 return SCM_UNSPECIFIED
;
1103 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1104 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1109 /* In the future, this function will return the effective slot
1110 * definition associated with SLOT_NAME. Now it just returns some of
1111 * the information which will be stored in the effective slot
1116 slot_definition_using_name (SCM
class, SCM slot_name
)
1118 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1119 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1120 if (SCM_CAAR (slots
) == slot_name
)
1121 return SCM_CAR (slots
);
1126 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1128 SCM access
= SCM_CDDR (slotdef
);
1130 * - access is an integer (the offset of this slot in the slots vector)
1131 * - otherwise (car access) is the getter function to apply
1133 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1134 * we can just assume fixnums here.
1136 if (SCM_I_INUMP (access
))
1137 return SCM_SLOT (obj
, SCM_I_INUM (access
));
1140 /* We must evaluate (apply (car access) (list obj))
1141 * where (car access) is known to be a closure of arity 1 */
1142 register SCM code
, env
;
1144 code
= SCM_CAR (access
);
1145 if (!SCM_CLOSUREP (code
))
1146 return SCM_SUBRF (code
) (obj
);
1147 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1150 /* Evaluate the closure body */
1151 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1156 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1158 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1159 if (scm_is_true (slotdef
))
1160 return get_slot_value (class, obj
, slotdef
);
1162 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1166 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1168 SCM access
= SCM_CDDR (slotdef
);
1170 * - access is an integer (the offset of this slot in the slots vector)
1171 * - otherwise (cadr access) is the setter function to apply
1173 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1174 * we can just assume fixnums here.
1176 if (SCM_I_INUMP (access
))
1177 SCM_SET_SLOT (obj
, SCM_I_INUM (access
), value
);
1180 /* We must evaluate (apply (cadr l) (list obj value))
1181 * where (cadr l) is known to be a closure of arity 2 */
1182 register SCM code
, env
;
1184 code
= SCM_CADR (access
);
1185 if (!SCM_CLOSUREP (code
))
1186 SCM_SUBRF (code
) (obj
, value
);
1189 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1190 scm_list_2 (obj
, value
),
1192 /* Evaluate the closure body */
1193 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1196 return SCM_UNSPECIFIED
;
1200 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1202 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1203 if (scm_is_true (slotdef
))
1204 return set_slot_value (class, obj
, slotdef
, value
);
1206 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1210 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1214 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1215 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1221 /* ======================================== */
1223 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1224 (SCM
class, SCM obj
, SCM slot_name
),
1226 #define FUNC_NAME s_scm_slot_ref_using_class
1230 SCM_VALIDATE_CLASS (1, class);
1231 SCM_VALIDATE_INSTANCE (2, obj
);
1232 SCM_VALIDATE_SYMBOL (3, slot_name
);
1234 res
= get_slot_value_using_name (class, obj
, slot_name
);
1235 if (SCM_GOOPS_UNBOUNDP (res
))
1236 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1242 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1243 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1245 #define FUNC_NAME s_scm_slot_set_using_class_x
1247 SCM_VALIDATE_CLASS (1, class);
1248 SCM_VALIDATE_INSTANCE (2, obj
);
1249 SCM_VALIDATE_SYMBOL (3, slot_name
);
1251 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1256 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1257 (SCM
class, SCM obj
, SCM slot_name
),
1259 #define FUNC_NAME s_scm_slot_bound_using_class_p
1261 SCM_VALIDATE_CLASS (1, class);
1262 SCM_VALIDATE_INSTANCE (2, obj
);
1263 SCM_VALIDATE_SYMBOL (3, slot_name
);
1265 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1271 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1272 (SCM
class, SCM obj
, SCM slot_name
),
1274 #define FUNC_NAME s_scm_slot_exists_using_class_p
1276 SCM_VALIDATE_CLASS (1, class);
1277 SCM_VALIDATE_INSTANCE (2, obj
);
1278 SCM_VALIDATE_SYMBOL (3, slot_name
);
1279 return test_slot_existence (class, obj
, slot_name
);
1284 /* ======================================== */
1286 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1287 (SCM obj
, SCM slot_name
),
1288 "Return the value from @var{obj}'s slot with the name\n"
1290 #define FUNC_NAME s_scm_slot_ref
1294 SCM_VALIDATE_INSTANCE (1, obj
);
1295 TEST_CHANGE_CLASS (obj
, class);
1297 res
= get_slot_value_using_name (class, obj
, slot_name
);
1298 if (SCM_GOOPS_UNBOUNDP (res
))
1299 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1304 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1305 (SCM obj
, SCM slot_name
, SCM value
),
1306 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1307 #define FUNC_NAME s_scm_slot_set_x
1311 SCM_VALIDATE_INSTANCE (1, obj
);
1312 TEST_CHANGE_CLASS(obj
, class);
1314 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1318 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1320 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1321 (SCM obj
, SCM slot_name
),
1322 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1324 #define FUNC_NAME s_scm_slot_bound_p
1328 SCM_VALIDATE_INSTANCE (1, obj
);
1329 TEST_CHANGE_CLASS(obj
, class);
1331 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1339 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1340 (SCM obj
, SCM slot_name
),
1341 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1342 #define FUNC_NAME s_scm_slot_exists_p
1346 SCM_VALIDATE_INSTANCE (1, obj
);
1347 SCM_VALIDATE_SYMBOL (2, slot_name
);
1348 TEST_CHANGE_CLASS (obj
, class);
1350 return test_slot_existence (class, obj
, slot_name
);
1355 /******************************************************************************
1357 * %allocate-instance (the low level instance allocation primitive)
1359 ******************************************************************************/
1361 static void clear_method_cache (SCM
);
1364 wrap_init (SCM
class, SCM
*m
, long n
)
1368 /* Set all slots to unbound */
1369 for (i
= 0; i
< n
; i
++)
1370 m
[i
] = SCM_GOOPS_UNBOUND
;
1372 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1374 (scm_t_bits
) m
, 0, 0);
1377 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1378 (SCM
class, SCM initargs
),
1379 "Create a new instance of class @var{class} and initialize it\n"
1380 "from the arguments @var{initargs}.")
1381 #define FUNC_NAME s_scm_sys_allocate_instance
1386 SCM_VALIDATE_CLASS (1, class);
1388 /* Most instances */
1389 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1391 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1392 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1393 return wrap_init (class, m
, n
);
1396 /* Foreign objects */
1397 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1398 return scm_make_foreign_object (class, initargs
);
1400 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1403 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1405 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1407 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1408 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1409 /* Generic functions */
1410 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1412 SCM gf
= wrap_init (class, m
, n
);
1413 clear_method_cache (gf
);
1417 return wrap_init (class, m
, n
);
1421 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1425 /* allocate class object */
1426 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1428 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1429 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1430 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1432 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1433 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1434 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1435 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1440 /* Non-light instances */
1442 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1443 return wrap_init (class, m
, n
);
1448 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1449 (SCM obj
, SCM setter
),
1451 #define FUNC_NAME s_scm_sys_set_object_setter_x
1453 SCM_ASSERT (SCM_STRUCTP (obj
)
1454 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1455 || SCM_I_ENTITYP (obj
)),
1459 if (SCM_I_ENTITYP (obj
))
1460 SCM_SET_ENTITY_SETTER (obj
, setter
);
1462 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1463 return SCM_UNSPECIFIED
;
1467 /******************************************************************************
1469 * %modify-instance (used by change-class to modify in place)
1471 ******************************************************************************/
1473 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1476 #define FUNC_NAME s_scm_sys_modify_instance
1478 SCM_VALIDATE_INSTANCE (1, old
);
1479 SCM_VALIDATE_INSTANCE (2, new);
1481 /* Exchange the data contained in old and new. We exchange rather than
1482 * scratch the old value with new to be correct with GC.
1483 * See "Class redefinition protocol above".
1487 SCM car
= SCM_CAR (old
);
1488 SCM cdr
= SCM_CDR (old
);
1489 SCM_SETCAR (old
, SCM_CAR (new));
1490 SCM_SETCDR (old
, SCM_CDR (new));
1491 SCM_SETCAR (new, car
);
1492 SCM_SETCDR (new, cdr
);
1495 return SCM_UNSPECIFIED
;
1499 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1502 #define FUNC_NAME s_scm_sys_modify_class
1504 SCM_VALIDATE_CLASS (1, old
);
1505 SCM_VALIDATE_CLASS (2, new);
1509 SCM car
= SCM_CAR (old
);
1510 SCM cdr
= SCM_CDR (old
);
1511 SCM_SETCAR (old
, SCM_CAR (new));
1512 SCM_SETCDR (old
, SCM_CDR (new));
1513 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1514 SCM_SETCAR (new, car
);
1515 SCM_SETCDR (new, cdr
);
1516 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1519 return SCM_UNSPECIFIED
;
1523 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1526 #define FUNC_NAME s_scm_sys_invalidate_class
1528 SCM_VALIDATE_CLASS (1, class);
1529 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1530 return SCM_UNSPECIFIED
;
1534 /* When instances change class, they finally get a new body, but
1535 * before that, they go through purgatory in hell. Odd as it may
1536 * seem, this data structure saves us from eternal suffering in
1537 * infinite recursions.
1540 static scm_t_bits
**hell
;
1541 static long n_hell
= 1; /* one place for the evil one himself */
1542 static long hell_size
= 4;
1543 static SCM hell_mutex
;
1549 for (i
= 1; i
< n_hell
; ++i
)
1550 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1556 go_to_hell (void *o
)
1558 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1559 scm_lock_mutex (hell_mutex
);
1560 if (n_hell
== hell_size
)
1562 long new_size
= 2 * hell_size
;
1563 hell
= scm_realloc (hell
, new_size
);
1564 hell_size
= new_size
;
1566 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1567 scm_unlock_mutex (hell_mutex
);
1571 go_to_heaven (void *o
)
1573 scm_lock_mutex (hell_mutex
);
1574 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1575 scm_unlock_mutex (hell_mutex
);
1579 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1582 purgatory (void *args
)
1584 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1585 SCM_PACK ((scm_t_bits
) args
));
1588 /* This function calls the generic function change-class for all
1589 * instances which aren't currently undergoing class change.
1593 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1596 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1597 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1598 (void *) SCM_UNPACK (obj
));
1601 /******************************************************************************
1607 * GGG E N E R I C F U N C T I O N S
1609 * This implementation provides
1610 * - generic functions (with class specializers)
1613 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1615 ******************************************************************************/
1617 SCM_KEYWORD (k_name
, "name");
1619 SCM_SYMBOL (sym_no_method
, "no-method");
1621 static SCM list_of_no_method
;
1623 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1627 scm_make_method_cache (SCM gf
)
1629 return scm_list_5 (SCM_IM_DISPATCH
,
1632 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1638 clear_method_cache (SCM gf
)
1640 SCM cache
= scm_make_method_cache (gf
);
1641 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1642 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1645 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1648 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1651 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1652 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1653 if (scm_is_true (used_by
))
1655 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1656 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1657 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1658 clear_method_cache (gf
);
1659 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1660 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1663 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1664 /* The sign of n is a flag indicating rest args. */
1665 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1667 return SCM_UNSPECIFIED
;
1671 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1674 #define FUNC_NAME s_scm_generic_capability_p
1676 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1677 proc
, SCM_ARG1
, FUNC_NAME
);
1678 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1684 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1687 #define FUNC_NAME s_scm_enable_primitive_generic_x
1689 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1690 while (!SCM_NULLP (subrs
))
1692 SCM subr
= SCM_CAR (subrs
);
1693 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1694 subr
, SCM_ARGn
, FUNC_NAME
);
1695 *SCM_SUBR_GENERIC (subr
)
1696 = scm_make (scm_list_3 (scm_class_generic
,
1699 subrs
= SCM_CDR (subrs
);
1701 return SCM_UNSPECIFIED
;
1705 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1708 #define FUNC_NAME s_scm_primitive_generic_generic
1710 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1712 if (!*SCM_SUBR_GENERIC (subr
))
1713 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1714 return *SCM_SUBR_GENERIC (subr
);
1716 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1720 typedef struct t_extension
{
1721 struct t_extension
*next
;
1726 static t_extension
*extensions
= 0;
1728 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1731 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1736 if (!*SCM_SUBR_GENERIC (extended
))
1737 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1738 gf
= *SCM_SUBR_GENERIC (extended
);
1739 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1741 SCM_SNAME (extension
));
1742 *SCM_SUBR_GENERIC (extension
) = gext
;
1746 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1747 t_extension
**loc
= &extensions
;
1748 /* Make sure that extensions are placed before their own
1749 * extensions in the extensions list. O(N^2) algorithm, but
1750 * extensions of primitive generics are rare.
1752 while (*loc
&& extension
!= (*loc
)->extended
)
1753 loc
= &(*loc
)->next
;
1755 e
->extended
= extended
;
1756 e
->extension
= extension
;
1762 setup_extended_primitive_generics ()
1766 t_extension
*e
= extensions
;
1767 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1768 extensions
= e
->next
;
1773 /******************************************************************************
1775 * Protocol for calling a generic fumction
1776 * This protocol is roughly equivalent to (parameter are a little bit different
1777 * for efficiency reasons):
1779 * + apply-generic (gf args)
1780 * + compute-applicable-methods (gf args ...)
1781 * + sort-applicable-methods (methods args)
1782 * + apply-methods (gf methods args)
1784 * apply-methods calls make-next-method to build the "continuation" of a a
1785 * method. Applying a next-method will call apply-next-method which in
1786 * turn will call apply again to call effectively the following method.
1788 ******************************************************************************/
1791 applicablep (SCM actual
, SCM formal
)
1793 /* We already know that the cpl is well formed. */
1794 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1798 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1800 register SCM s1
, s2
;
1804 * m1 and m2 can have != length (i.e. one can be one element longer than the
1805 * other when we have a dotted parameter list). For instance, with the call
1808 * (define-method M (a . l) ....)
1809 * (define-method M (a) ....)
1811 * we consider that the second method is more specific.
1813 * BTW, targs is an array of types. We don't need it's size since
1814 * we already know that m1 and m2 are applicable (no risk to go past
1815 * the end of this array).
1818 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1819 if (SCM_NULLP(s1
)) return 1;
1820 if (SCM_NULLP(s2
)) return 0;
1821 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1822 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1824 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1825 if (cs1
== SCM_CAR(l
))
1827 if (cs2
== SCM_CAR(l
))
1830 return 0;/* should not occur! */
1833 return 0; /* should not occur! */
1836 #define BUFFSIZE 32 /* big enough for most uses */
1839 scm_i_vector2list (SCM l
, long len
)
1842 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1844 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1845 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1851 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1854 SCM
*v
, vector
= SCM_EOL
;
1855 SCM buffer
[BUFFSIZE
];
1856 SCM save
= method_list
;
1858 /* For reasonably sized method_lists we can try to avoid all the
1859 * consing and reorder the list in place...
1860 * This idea is due to David McClain <Dave_McClain@msn.com>
1862 if (size
<= BUFFSIZE
)
1864 for (i
= 0; i
< size
; i
++)
1866 buffer
[i
] = SCM_CAR (method_list
);
1867 method_list
= SCM_CDR (method_list
);
1873 /* Too many elements in method_list to keep everything locally */
1874 vector
= scm_i_vector2list (save
, size
);
1877 This is a new vector. Don't worry about the write barrier.
1878 We're not allocating elements in this routine, so this should
1881 v
= SCM_WRITABLE_VELTS (vector
);
1884 /* Use a simple shell sort since it is generally faster than qsort on
1885 * small vectors (which is probably mostly the case when we have to
1886 * sort a list of applicable methods).
1888 for (incr
= size
/ 2; incr
; incr
/= 2)
1890 for (i
= incr
; i
< size
; i
++)
1892 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1894 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1898 SCM tmp
= v
[j
+ incr
];
1906 if (size
<= BUFFSIZE
)
1908 /* We did it in locally, so restore the original list (reordered) in-place */
1909 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1911 SCM_SETCAR (method_list
, *v
);
1912 method_list
= SCM_CDR (method_list
);
1916 /* If we are here, that's that we did it the hard way... */
1917 return scm_vector_to_list (vector
);
1921 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1925 SCM l
, fl
, applicable
= SCM_EOL
;
1927 SCM buffer
[BUFFSIZE
];
1932 /* Build the list of arguments types */
1933 if (len
>= BUFFSIZE
) {
1934 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1935 /* NOTE: Using pointers to malloced memory won't work if we
1936 1. have preemtive threading, and,
1937 2. have a GC which moves objects. */
1938 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1941 note that we don't have to work to reset the generation
1942 count. TMP is a new vector anyway, and it is found
1949 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1950 *p
++ = scm_class_of (SCM_CAR (args
));
1952 /* Build a list of all applicable methods */
1953 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1955 fl
= SPEC_OF (SCM_CAR (l
));
1956 /* Only accept accessors which match exactly in first arg. */
1957 if (SCM_ACCESSORP (SCM_CAR (l
))
1958 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1960 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1962 if (SCM_INSTANCEP (fl
)
1963 /* We have a dotted argument list */
1964 || (i
>= len
&& SCM_NULLP (fl
)))
1965 { /* both list exhausted */
1966 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1972 || !applicablep (types
[i
], SCM_CAR (fl
)))
1981 CALL_GF2 ("no-applicable-method", gf
, save
);
1982 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1986 scm_remember_upto_here_1 (tmp
);
1989 : sort_applicable_methods (applicable
, count
, types
));
1993 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1996 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1999 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2000 #define FUNC_NAME s_sys_compute_applicable_methods
2003 SCM_VALIDATE_GENERIC (1, gf
);
2004 n
= scm_ilength (args
);
2005 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2006 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2010 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2011 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
));
2014 lock_cache_mutex (void *m
)
2016 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2017 scm_lock_mutex (mutex
);
2021 unlock_cache_mutex (void *m
)
2023 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2024 scm_unlock_mutex (mutex
);
2028 call_memoize_method (void *a
)
2030 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2031 SCM gf
= SCM_CAR (args
);
2032 SCM x
= SCM_CADR (args
);
2033 /* First check if another thread has inserted a method between
2034 * the cache miss and locking the mutex.
2036 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2037 if (scm_is_true (cmethod
))
2039 /*fixme* Use scm_apply */
2040 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2044 scm_memoize_method (SCM x
, SCM args
)
2046 SCM gf
= SCM_CAR (scm_last_pair (x
));
2047 return scm_internal_dynamic_wind (
2049 call_memoize_method
,
2051 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2052 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2055 /******************************************************************************
2057 * A simple make (which will be redefined later in Scheme)
2058 * This version handles only creation of gf, methods and classes (no instances)
2060 * Since this code will disappear when Goops will be fully booted,
2061 * no precaution is taken to be efficient.
2063 ******************************************************************************/
2065 SCM_KEYWORD (k_setter
, "setter");
2066 SCM_KEYWORD (k_specializers
, "specializers");
2067 SCM_KEYWORD (k_procedure
, "procedure");
2068 SCM_KEYWORD (k_dsupers
, "dsupers");
2069 SCM_KEYWORD (k_slots
, "slots");
2070 SCM_KEYWORD (k_gf
, "generic-function");
2072 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2074 "Make a new object. @var{args} must contain the class and\n"
2075 "all necessary initialization information.")
2076 #define FUNC_NAME s_scm_make
2079 long len
= scm_ilength (args
);
2081 if (len
<= 0 || (len
& 1) == 0)
2082 SCM_WRONG_NUM_ARGS ();
2084 class = SCM_CAR(args
);
2085 args
= SCM_CDR(args
);
2087 if (class == scm_class_generic
|| class == scm_class_accessor
)
2089 z
= scm_make_struct (class, SCM_INUM0
,
2090 scm_list_5 (SCM_EOL
,
2095 scm_set_procedure_property_x (z
, scm_sym_name
,
2096 scm_get_keyword (k_name
,
2099 clear_method_cache (z
);
2100 if (class == scm_class_accessor
)
2102 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2103 if (scm_is_true (setter
))
2104 scm_sys_set_object_setter_x (z
, setter
);
2109 z
= scm_sys_allocate_instance (class, args
);
2111 if (class == scm_class_method
2112 || class == scm_class_simple_method
2113 || class == scm_class_accessor_method
)
2115 SCM_SET_SLOT (z
, scm_si_generic_function
,
2116 scm_i_get_keyword (k_gf
,
2121 SCM_SET_SLOT (z
, scm_si_specializers
,
2122 scm_i_get_keyword (k_specializers
,
2127 SCM_SET_SLOT (z
, scm_si_procedure
,
2128 scm_i_get_keyword (k_procedure
,
2133 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2137 /* In all the others case, make a new class .... No instance here */
2138 SCM_SET_SLOT (z
, scm_si_name
,
2139 scm_i_get_keyword (k_name
,
2142 scm_str2symbol ("???"),
2144 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2145 scm_i_get_keyword (k_dsupers
,
2150 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2151 scm_i_get_keyword (k_slots
,
2162 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2165 #define FUNC_NAME s_scm_find_method
2168 long len
= scm_ilength (l
);
2171 SCM_WRONG_NUM_ARGS ();
2173 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2174 SCM_VALIDATE_GENERIC (1, gf
);
2175 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2176 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2178 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2182 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2183 (SCM m1
, SCM m2
, SCM targs
),
2185 #define FUNC_NAME s_scm_sys_method_more_specific_p
2190 SCM_VALIDATE_METHOD (1, m1
);
2191 SCM_VALIDATE_METHOD (2, m2
);
2192 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2194 /* Verify that all the arguments of targs are classes and place them in a vector*/
2195 v
= scm_c_make_vector (len
, SCM_EOL
);
2197 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2198 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2199 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2201 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2207 /******************************************************************************
2211 ******************************************************************************/
2214 fix_cpl (SCM c
, SCM before
, SCM after
)
2216 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2217 SCM ls
= scm_c_memq (after
, cpl
);
2218 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2219 if (scm_is_false (ls
))
2220 /* if this condition occurs, fix_cpl should not be applied this way */
2222 SCM_SETCAR (ls
, before
);
2223 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2225 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2226 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2227 SCM g_n_s
= compute_getters_n_setters (slots
);
2228 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2229 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2235 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2237 SCM tmp
= scm_str2symbol (name
);
2239 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2243 : scm_list_1 (super
),
2249 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2252 create_standard_classes (void)
2255 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2256 scm_str2symbol ("specializers"),
2258 scm_str2symbol ("code-table"));
2259 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2261 k_slot_definition
));
2262 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2263 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2267 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2268 scm_list_3 (scm_str2symbol ("n-specialized"),
2271 scm_list_3 (scm_str2symbol ("used-by"),
2274 scm_list_3 (scm_str2symbol ("cache-mutex"),
2277 scm_list_3 (scm_str2symbol ("extended-by"),
2280 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2283 /* Foreign class slot classes */
2284 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2285 scm_class_class
, scm_class_top
, SCM_EOL
);
2286 make_stdcls (&scm_class_protected
, "<protected-slot>",
2287 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2288 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2289 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2290 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2291 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2292 make_stdcls (&scm_class_self
, "<self-slot>",
2294 scm_class_read_only
,
2296 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2298 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2300 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2302 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2304 make_stdcls (&scm_class_scm
, "<scm-slot>",
2305 scm_class_class
, scm_class_protected
, SCM_EOL
);
2306 make_stdcls (&scm_class_int
, "<int-slot>",
2307 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2308 make_stdcls (&scm_class_float
, "<float-slot>",
2309 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2310 make_stdcls (&scm_class_double
, "<double-slot>",
2311 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2313 /* Continue initialization of class <class> */
2315 slots
= build_class_class_slots ();
2316 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2317 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2318 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2319 compute_getters_n_setters (slots
));
2321 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2322 scm_class_class
, scm_class_class
,
2323 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2326 scm_list_3 (scm_str2symbol ("destructor"),
2328 scm_class_opaque
)));
2329 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2330 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2331 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2333 /* scm_class_generic functions classes */
2334 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2335 scm_class_class
, scm_class_class
, SCM_EOL
);
2336 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2337 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2338 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2339 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2340 make_stdcls (&scm_class_operator_with_setter_class
,
2341 "<operator-with-setter-class>",
2342 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2343 make_stdcls (&scm_class_method
, "<method>",
2344 scm_class_class
, scm_class_object
, method_slots
);
2345 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2346 scm_class_class
, scm_class_method
, SCM_EOL
);
2347 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2348 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2349 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2350 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2351 make_stdcls (&scm_class_applicable
, "<applicable>",
2352 scm_class_class
, scm_class_top
, SCM_EOL
);
2353 make_stdcls (&scm_class_entity
, "<entity>",
2354 scm_class_entity_class
,
2355 scm_list_2 (scm_class_object
, scm_class_applicable
),
2357 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2358 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2359 make_stdcls (&scm_class_generic
, "<generic>",
2360 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2361 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2362 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2363 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2364 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2365 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2366 scm_class_entity_class
,
2367 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2369 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2370 make_stdcls (&scm_class_accessor
, "<accessor>",
2371 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2372 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2373 make_stdcls (&scm_class_extended_generic_with_setter
,
2374 "<extended-generic-with-setter>",
2375 scm_class_entity_class
,
2376 scm_list_2 (scm_class_generic_with_setter
,
2377 scm_class_extended_generic
),
2379 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2380 SCM_CLASSF_PURE_GENERIC
);
2381 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2382 scm_class_entity_class
,
2383 scm_list_2 (scm_class_accessor
,
2384 scm_class_extended_generic_with_setter
),
2386 fix_cpl (scm_class_extended_accessor
,
2387 scm_class_extended_generic
, scm_class_generic
);
2388 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2390 /* Primitive types classes */
2391 make_stdcls (&scm_class_boolean
, "<boolean>",
2392 scm_class_class
, scm_class_top
, SCM_EOL
);
2393 make_stdcls (&scm_class_char
, "<char>",
2394 scm_class_class
, scm_class_top
, SCM_EOL
);
2395 make_stdcls (&scm_class_list
, "<list>",
2396 scm_class_class
, scm_class_top
, SCM_EOL
);
2397 make_stdcls (&scm_class_pair
, "<pair>",
2398 scm_class_class
, scm_class_list
, SCM_EOL
);
2399 make_stdcls (&scm_class_null
, "<null>",
2400 scm_class_class
, scm_class_list
, SCM_EOL
);
2401 make_stdcls (&scm_class_string
, "<string>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_symbol
, "<symbol>",
2404 scm_class_class
, scm_class_top
, SCM_EOL
);
2405 make_stdcls (&scm_class_vector
, "<vector>",
2406 scm_class_class
, scm_class_top
, SCM_EOL
);
2407 make_stdcls (&scm_class_number
, "<number>",
2408 scm_class_class
, scm_class_top
, SCM_EOL
);
2409 make_stdcls (&scm_class_complex
, "<complex>",
2410 scm_class_class
, scm_class_number
, SCM_EOL
);
2411 make_stdcls (&scm_class_real
, "<real>",
2412 scm_class_class
, scm_class_complex
, SCM_EOL
);
2413 make_stdcls (&scm_class_integer
, "<integer>",
2414 scm_class_class
, scm_class_real
, SCM_EOL
);
2415 make_stdcls (&scm_class_fraction
, "<fraction>",
2416 scm_class_class
, scm_class_real
, SCM_EOL
);
2417 make_stdcls (&scm_class_keyword
, "<keyword>",
2418 scm_class_class
, scm_class_top
, SCM_EOL
);
2419 make_stdcls (&scm_class_unknown
, "<unknown>",
2420 scm_class_class
, scm_class_top
, SCM_EOL
);
2421 make_stdcls (&scm_class_procedure
, "<procedure>",
2422 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2423 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2424 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2425 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2426 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2427 make_stdcls (&scm_class_port
, "<port>",
2428 scm_class_class
, scm_class_top
, SCM_EOL
);
2429 make_stdcls (&scm_class_input_port
, "<input-port>",
2430 scm_class_class
, scm_class_port
, SCM_EOL
);
2431 make_stdcls (&scm_class_output_port
, "<output-port>",
2432 scm_class_class
, scm_class_port
, SCM_EOL
);
2433 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2435 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2439 /**********************************************************************
2443 **********************************************************************/
2446 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2452 sprintf (buffer
, template, type_name
);
2453 name
= scm_str2symbol (buffer
);
2456 name
= SCM_GOOPS_UNBOUND
;
2458 class = scm_permanent_object (scm_basic_make_class (applicablep
2459 ? scm_class_procedure_class
2465 /* Only define name if doesn't already exist. */
2466 if (!SCM_GOOPS_UNBOUNDP (name
)
2467 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2468 DEFVAR (name
, class);
2473 scm_make_extended_class (char const *type_name
, int applicablep
)
2475 return make_class_from_template ("<%s>",
2477 scm_list_1 (applicablep
2478 ? scm_class_applicable
2484 scm_i_inherit_applicable (SCM c
)
2486 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2488 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2489 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2490 /* patch scm_class_applicable into direct-supers */
2491 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2492 if (scm_is_false (top
))
2493 dsupers
= scm_append (scm_list_2 (dsupers
,
2494 scm_list_1 (scm_class_applicable
)));
2497 SCM_SETCAR (top
, scm_class_applicable
);
2498 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2500 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2501 /* patch scm_class_applicable into cpl */
2502 top
= scm_c_memq (scm_class_top
, cpl
);
2503 if (scm_is_false (top
))
2507 SCM_SETCAR (top
, scm_class_applicable
);
2508 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2510 /* add class to direct-subclasses of scm_class_applicable */
2511 SCM_SET_SLOT (scm_class_applicable
,
2512 scm_si_direct_subclasses
,
2513 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2514 scm_si_direct_subclasses
)));
2519 create_smob_classes (void)
2523 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2524 for (i
= 0; i
< 255; ++i
)
2525 scm_smob_class
[i
] = 0;
2527 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2529 for (i
= 0; i
< scm_numsmob
; ++i
)
2530 if (!scm_smob_class
[i
])
2531 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2532 scm_smobs
[i
].apply
!= 0);
2536 scm_make_port_classes (long ptobnum
, char *type_name
)
2538 SCM c
, class = make_class_from_template ("<%s-port>",
2540 scm_list_1 (scm_class_port
),
2542 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2543 = make_class_from_template ("<%s-input-port>",
2545 scm_list_2 (class, scm_class_input_port
),
2547 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2548 = make_class_from_template ("<%s-output-port>",
2550 scm_list_2 (class, scm_class_output_port
),
2552 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2554 = make_class_from_template ("<%s-input-output-port>",
2556 scm_list_2 (class, scm_class_input_output_port
),
2558 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2559 SCM_SET_SLOT (c
, scm_si_cpl
,
2560 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2564 create_port_classes (void)
2568 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2569 for (i
= 0; i
< 3 * 256; ++i
)
2570 scm_port_class
[i
] = 0;
2572 for (i
= 0; i
< scm_numptob
; ++i
)
2573 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2577 make_struct_class (void *closure SCM_UNUSED
,
2578 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2580 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2581 SCM_SET_STRUCT_TABLE_CLASS (data
,
2582 scm_make_extended_class
2583 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
)),
2584 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2585 return SCM_UNSPECIFIED
;
2589 create_struct_classes (void)
2591 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2594 /**********************************************************************
2598 **********************************************************************/
2603 if (!goops_loaded_p
)
2604 scm_c_resolve_module ("oop goops");
2609 scm_make_foreign_object (SCM
class, SCM initargs
)
2610 #define FUNC_NAME s_scm_make
2612 void * (*constructor
) (SCM
)
2613 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2614 if (constructor
== 0)
2615 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2616 return scm_wrap_object (class, constructor (initargs
));
2622 scm_free_foreign_object (SCM
*class, SCM
*data
)
2624 size_t (*destructor
) (void *)
2625 = (size_t (*) (void *)) class[scm_si_destructor
];
2626 return destructor (data
);
2630 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2631 void * (*constructor
) (SCM initargs
),
2632 size_t (*destructor
) (void *))
2635 name
= scm_str2symbol (s_name
);
2636 if (SCM_NULLP (supers
))
2637 supers
= scm_list_1 (scm_class_foreign_object
);
2638 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2639 scm_sys_inherit_magic_x (class, supers
);
2641 if (destructor
!= 0)
2643 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2644 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2648 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2649 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2652 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2653 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2658 SCM_SYMBOL (sym_o
, "o");
2659 SCM_SYMBOL (sym_x
, "x");
2661 SCM_KEYWORD (k_accessor
, "accessor");
2662 SCM_KEYWORD (k_getter
, "getter");
2665 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2667 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2672 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2673 SCM (*getter
) (SCM obj
),
2674 SCM (*setter
) (SCM obj
, SCM x
),
2675 char *accessor_name
)
2678 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2679 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2680 setter
? setter
: default_setter
);
2682 /* Dirk:FIXME:: The following two expressions make use of the fact that
2683 * the memoizer will accept a subr-object in the place of a function.
2684 * This is not guaranteed to stay this way. */
2685 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2687 scm_list_2 (get
, sym_o
)),
2689 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2690 scm_list_2 (sym_o
, sym_x
),
2691 scm_list_3 (set
, sym_o
, sym_x
)),
2695 SCM name
= scm_str2symbol (slot_name
);
2696 SCM aname
= scm_str2symbol (accessor_name
);
2697 SCM gf
= scm_ensure_accessor (aname
);
2698 SCM slot
= scm_list_5 (name
,
2701 setter
? k_accessor
: k_getter
,
2703 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2708 scm_add_method (scm_setter (gf
),
2709 scm_make (scm_list_5 (scm_class_accessor_method
,
2711 scm_list_2 (class, scm_class_top
),
2716 SCM_SET_SLOT (class, scm_si_slots
,
2717 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2718 scm_list_1 (slot
))));
2720 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2721 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1));
2722 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2723 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2724 scm_list_1 (gns
))));
2725 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2732 scm_wrap_object (SCM
class, void *data
)
2734 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2742 scm_wrap_component (SCM
class, SCM container
, void *data
)
2744 SCM obj
= scm_wrap_object (class, data
);
2745 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2751 SCM_SETCDR (handle
, container
);
2756 scm_ensure_accessor (SCM name
)
2758 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2759 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2761 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2762 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2763 k_name
, name
, k_setter
, gf
));
2768 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2771 scm_add_method (SCM gf
, SCM m
)
2773 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2778 * Debugging utilities
2781 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2783 "Return @code{#t} if @var{obj} is a pure generic.")
2784 #define FUNC_NAME s_scm_pure_generic_p
2786 return scm_from_bool (SCM_PUREGENERICP (obj
));
2790 #endif /* GUILE_DEBUG */
2796 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2798 "Announce that GOOPS is loaded and perform initialization\n"
2799 "on the C level which depends on the loaded GOOPS modules.")
2800 #define FUNC_NAME s_scm_sys_goops_loaded
2803 var_compute_applicable_methods
=
2804 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2806 setup_extended_primitive_generics ();
2807 return SCM_UNSPECIFIED
;
2811 SCM scm_module_goops
;
2814 scm_init_goops_builtins (void)
2816 scm_module_goops
= scm_current_module ();
2817 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2819 /* Not really necessary right now, but who knows...
2821 scm_permanent_object (scm_module_goops
);
2822 scm_permanent_object (scm_goops_lookup_closure
);
2824 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2825 (scm_from_int (37)));
2827 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2829 #include "libguile/goops.x"
2831 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2833 hell
= scm_malloc (hell_size
);
2834 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2836 create_basic_classes ();
2837 create_standard_classes ();
2838 create_smob_classes ();
2839 create_struct_classes ();
2840 create_port_classes ();
2843 SCM name
= scm_str2symbol ("no-applicable-method");
2844 scm_no_applicable_method
2845 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2848 DEFVAR (name
, scm_no_applicable_method
);
2851 return SCM_UNSPECIFIED
;
2857 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2858 scm_init_goops_builtins
);