1 /* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 /* This software is a derivative work of other copyrighted softwares; the
20 * copyright notices of these softwares are placed in the file COPYRIGHTS
22 * This file is based upon stklos.c from the STk distribution by
23 * Erick Gallesio <eg@unice.fr>.
28 #include "libguile/_scm.h"
29 #include "libguile/alist.h"
30 #include "libguile/debug.h"
31 #include "libguile/dynl.h"
32 #include "libguile/dynwind.h"
33 #include "libguile/eval.h"
34 #include "libguile/hashtab.h"
35 #include "libguile/keywords.h"
36 #include "libguile/macros.h"
37 #include "libguile/modules.h"
38 #include "libguile/objects.h"
39 #include "libguile/ports.h"
40 #include "libguile/procprop.h"
41 #include "libguile/random.h"
42 #include "libguile/root.h"
43 #include "libguile/smob.h"
44 #include "libguile/strings.h"
45 #include "libguile/strports.h"
46 #include "libguile/vectors.h"
47 #include "libguile/weaks.h"
49 #include "libguile/validate.h"
50 #include "libguile/goops.h"
52 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
54 #define DEFVAR(v, val) \
55 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
57 /* Temporary hack until we get the new module system */
58 /*fixme* Should optimize by keeping track of the variable object itself */
59 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
62 /* Fixme: Should use already interned symbols */
63 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
65 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
67 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
69 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
72 /* Class redefinition protocol:
74 A class is represented by a heap header h1 which points to a
75 malloc:ed memory block m1.
77 When a new version of a class is created, a new header h2 and
78 memory block m2 are allocated. The headers h1 and h2 then switch
79 pointers so that h1 refers to m2 and h2 to m1. In this way, names
80 bound to h1 will point to the new class at the same time as h2 will
81 be a handle which the GC will us to free m1.
83 The `redefined' slot of m1 will be set to point to h1. An old
84 instance will have it's class pointer (the CAR of the heap header)
85 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
86 the class modification and the new class pointer can be found via
90 /* The following definition is located in libguile/objects.h:
91 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
94 #define TEST_CHANGE_CLASS(obj, class) \
96 class = SCM_CLASS_OF (obj); \
97 if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
98 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
101 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
102 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
104 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
105 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
107 static int goops_loaded_p
= 0;
108 static scm_t_rstate
*goops_rstate
;
110 static SCM scm_goops_lookup_closure
;
112 /* Some classes are defined in libguile/objects.c. */
113 SCM scm_class_top
, scm_class_object
, scm_class_class
;
114 SCM scm_class_applicable
;
115 SCM scm_class_entity
, scm_class_entity_with_setter
;
116 SCM scm_class_generic
, scm_class_generic_with_setter
;
117 SCM scm_class_accessor
;
118 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
119 SCM scm_class_extended_accessor
;
120 SCM scm_class_method
;
121 SCM scm_class_simple_method
, scm_class_accessor_method
;
122 SCM scm_class_procedure_class
;
123 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
124 SCM scm_class_entity_class
;
125 SCM scm_class_number
, scm_class_list
;
126 SCM scm_class_keyword
;
127 SCM scm_class_port
, scm_class_input_output_port
;
128 SCM scm_class_input_port
, scm_class_output_port
;
129 SCM scm_class_foreign_class
, scm_class_foreign_object
;
130 SCM scm_class_foreign_slot
;
131 SCM scm_class_self
, scm_class_protected
;
132 SCM scm_class_opaque
, scm_class_read_only
;
133 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
135 SCM scm_class_int
, scm_class_float
, scm_class_double
;
137 SCM_SYMBOL (scm_sym_define_public
, "define-public");
139 static SCM
scm_make_unbound (void);
140 static SCM
scm_unbound_p (SCM obj
);
141 static SCM
scm_assert_bound (SCM value
, SCM obj
);
142 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
143 static SCM
scm_sys_goops_loaded (void);
145 /******************************************************************************
149 * This version doesn't fully handle multiple-inheritance. It serves
150 * only for booting classes and will be overloaded in Scheme
152 ******************************************************************************/
155 map (SCM (*proc
) (SCM
), SCM ls
)
161 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
164 while (!SCM_NULLP (ls
))
166 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
178 while (!SCM_NULLP (ls
))
180 SCM el
= SCM_CAR (ls
);
181 if (SCM_FALSEP (scm_c_memq (el
, res
)))
182 res
= scm_cons (el
, res
);
189 compute_cpl (SCM
class)
192 return CALL_GF1 ("compute-cpl", class);
195 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
196 SCM ls
= scm_append (scm_acons (class, supers
,
197 map (compute_cpl
, supers
)));
198 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
202 /******************************************************************************
206 ******************************************************************************/
209 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
217 if (!SCM_SYMBOLP (tmp
))
218 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
220 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
221 res
= scm_cons (SCM_CAR (l
), res
);
222 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
225 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
229 build_slots_list (SCM dslots
, SCM cpl
)
231 register SCM res
= dslots
;
233 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
234 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
235 scm_si_direct_slots
),
238 /* res contains a list of slots. Remove slots which appears more than once */
239 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
246 while (!SCM_NULLP (ls
))
248 if (!SCM_CONSP (SCM_CAR (ls
)))
249 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
256 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
258 "Return a list consisting of the names of all slots belonging to\n"
259 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
261 #define FUNC_NAME s_scm_sys_compute_slots
263 SCM_VALIDATE_CLASS (1, class);
264 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
265 SCM_SLOT (class, scm_si_cpl
));
270 /******************************************************************************
272 * compute-getters-n-setters
274 * This version doesn't handle slot options. It serves only for booting
275 * classes and will be overloaded in Scheme.
277 ******************************************************************************/
279 SCM_KEYWORD (k_init_value
, "init-value");
280 SCM_KEYWORD (k_init_thunk
, "init-thunk");
283 compute_getters_n_setters (SCM slots
)
289 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
291 SCM init
= SCM_BOOL_F
;
292 SCM options
= SCM_CDAR (slots
);
293 if (!SCM_NULLP (options
))
295 init
= scm_get_keyword (k_init_value
, options
, 0);
297 init
= scm_closure (scm_list_2 (SCM_EOL
,
298 scm_list_2 (scm_sym_quote
, init
)),
301 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
303 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
307 cdrloc
= SCM_CDRLOC (*cdrloc
);
312 /******************************************************************************
316 ******************************************************************************/
318 /*fixme* Manufacture keywords in advance */
320 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
324 for (i
= 0; i
!= len
; i
+= 2)
326 SCM obj
= SCM_CAR (l
);
328 if (!SCM_KEYWORDP (obj
))
329 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
330 else if (SCM_EQ_P (obj
, key
))
336 return default_value
;
340 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
341 (SCM key
, SCM l
, SCM default_value
),
342 "Determine an associated value for the keyword @var{key} from\n"
343 "the list @var{l}. The list @var{l} has to consist of an even\n"
344 "number of elements, where, starting with the first, every\n"
345 "second element is a keyword, followed by its associated value.\n"
346 "If @var{l} does not hold a value for @var{key}, the value\n"
347 "@var{default_value} is returned.")
348 #define FUNC_NAME s_scm_get_keyword
352 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
353 len
= scm_ilength (l
);
354 if (len
< 0 || len
% 2 == 1)
355 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
357 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
362 SCM_KEYWORD (k_init_keyword
, "init-keyword");
364 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
365 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
367 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
368 (SCM obj
, SCM initargs
),
369 "Initialize the object @var{obj} with the given arguments\n"
371 #define FUNC_NAME s_scm_sys_initialize_object
373 SCM tmp
, get_n_set
, slots
;
374 SCM
class = SCM_CLASS_OF (obj
);
377 SCM_VALIDATE_INSTANCE (1, obj
);
378 n_initargs
= scm_ilength (initargs
);
379 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
381 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
382 slots
= SCM_SLOT (class, scm_si_slots
);
384 /* See for each slot how it must be initialized */
387 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
389 SCM slot_name
= SCM_CAR (slots
);
392 if (!SCM_NULLP (SCM_CDR (slot_name
)))
394 /* This slot admits (perhaps) to be initialized at creation time */
395 long n
= scm_ilength (SCM_CDR (slot_name
));
396 if (n
& 1) /* odd or -1 */
397 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
398 scm_list_1 (slot_name
));
399 tmp
= scm_i_get_keyword (k_init_keyword
,
404 slot_name
= SCM_CAR (slot_name
);
407 /* an initarg was provided for this slot */
408 if (!SCM_KEYWORDP (tmp
))
409 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
411 slot_value
= scm_i_get_keyword (tmp
,
420 /* set slot to provided value */
421 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
424 /* set slot to its :init-form if it exists */
425 tmp
= SCM_CADAR (get_n_set
);
426 if (tmp
!= SCM_BOOL_F
)
428 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
429 if (SCM_GOOPS_UNBOUNDP (slot_value
))
431 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
432 set_slot_value (class,
435 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
445 /* NOTE: The following macros are interdependent with code
446 * in goops.scm:compute-getters-n-setters
448 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
449 (SCM_INUMP (SCM_CDDR (gns)) \
450 || (SCM_CONSP (SCM_CDDR (gns)) \
451 && SCM_CONSP (SCM_CDDDR (gns)) \
452 && SCM_CONSP (SCM_CDDDDR (gns))))
453 #define SCM_GNS_INDEX(gns) \
454 (SCM_INUMP (SCM_CDDR (gns)) \
455 ? SCM_INUM (SCM_CDDR (gns)) \
456 : SCM_INUM (SCM_CAR (SCM_CDDDDR (gns))))
457 #define SCM_GNS_SIZE(gns) \
458 (SCM_INUMP (SCM_CDDR (gns)) \
460 : SCM_INUM (SCM_CADR (SCM_CDDDDR (gns))))
462 SCM_KEYWORD (k_class
, "class");
463 SCM_KEYWORD (k_allocation
, "allocation");
464 SCM_KEYWORD (k_instance
, "instance");
466 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
469 #define FUNC_NAME s_scm_sys_prep_layout_x
471 SCM slots
, getters_n_setters
, nfields
;
472 unsigned long int n
, i
;
475 SCM_VALIDATE_INSTANCE (1, class);
476 slots
= SCM_SLOT (class, scm_si_slots
);
477 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
478 nfields
= SCM_SLOT (class, scm_si_nfields
);
479 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
480 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
481 scm_list_1 (nfields
));
482 n
= 2 * SCM_INUM (nfields
);
483 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
484 && SCM_SUBCLASSP (class, scm_class_class
))
485 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
486 scm_list_1 (nfields
));
488 s
= n
> 0 ? scm_malloc (n
) : 0;
490 while (SCM_CONSP (getters_n_setters
))
492 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
495 int len
, index
, size
;
498 if (i
>= n
|| !SCM_CONSP (slots
))
501 /* extract slot type */
502 len
= scm_ilength (SCM_CDAR (slots
));
503 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
504 len
, SCM_BOOL_F
, FUNC_NAME
);
505 /* determine slot GC protection and access mode */
506 if (SCM_FALSEP (type
))
513 if (!SCM_CLASSP (type
))
517 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
519 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
521 if (SCM_SUBCLASSP (type
, scm_class_self
))
523 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
528 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
530 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
542 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
543 if (index
!= (i
>> 1))
545 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
553 slots
= SCM_CDR (slots
);
554 getters_n_setters
= SCM_CDR (getters_n_setters
);
556 if (!SCM_NULLP (slots
))
561 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
563 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
566 return SCM_UNSPECIFIED
;
570 static void prep_hashsets (SCM
);
572 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
573 (SCM
class, SCM dsupers
),
575 #define FUNC_NAME s_scm_sys_inherit_magic_x
579 SCM_VALIDATE_INSTANCE (1, class);
580 while (!SCM_NULLP (ls
))
582 SCM_ASSERT (SCM_CONSP (ls
)
583 && SCM_INSTANCEP (SCM_CAR (ls
)),
587 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
590 flags
&= SCM_CLASSF_INHERIT
;
591 if (flags
& SCM_CLASSF_ENTITY
)
592 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
595 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
598 * We could avoid calling scm_gc_malloc in the allocation code
599 * (in which case the following two lines are needed). Instead
600 * we make 0-slot instances non-light, so that the light case
601 * can be handled without special cases.
604 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
606 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
608 /* NOTE: The following depends on scm_struct_i_size. */
609 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
610 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
613 SCM_SET_CLASS_FLAGS (class, flags
);
615 prep_hashsets (class);
617 return SCM_UNSPECIFIED
;
622 prep_hashsets (SCM
class)
626 for (i
= 0; i
< 7; ++i
)
627 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
630 /******************************************************************************/
633 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
635 SCM z
, cpl
, slots
, nfields
, g_n_s
;
637 /* Allocate one instance */
638 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
640 /* Initialize its slots */
641 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
642 cpl
= compute_cpl (z
);
643 slots
= build_slots_list (maplist (dslots
), cpl
);
644 nfields
= SCM_MAKINUM (scm_ilength (slots
));
645 g_n_s
= compute_getters_n_setters (slots
);
647 SCM_SET_SLOT (z
, scm_si_name
, name
);
648 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
649 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
650 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
651 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
652 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
653 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
654 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
655 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
656 SCM_SET_SLOT (z
, scm_si_environment
,
657 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
659 /* Add this class in the direct-subclasses slot of dsupers */
662 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
663 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
664 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
665 scm_si_direct_subclasses
)));
668 /* Support for the underlying structs: */
669 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
670 ? (SCM_CLASSF_GOOPS_OR_VALID
671 | SCM_CLASSF_OPERATOR
673 : class == scm_class_operator_class
674 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
675 : SCM_CLASSF_GOOPS_OR_VALID
));
680 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
682 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
683 scm_sys_inherit_magic_x (z
, dsupers
);
684 scm_sys_prep_layout_x (z
);
688 /******************************************************************************/
690 SCM_SYMBOL (sym_layout
, "layout");
691 SCM_SYMBOL (sym_vcell
, "vcell");
692 SCM_SYMBOL (sym_vtable
, "vtable");
693 SCM_SYMBOL (sym_print
, "print");
694 SCM_SYMBOL (sym_procedure
, "procedure");
695 SCM_SYMBOL (sym_setter
, "setter");
696 SCM_SYMBOL (sym_redefined
, "redefined");
697 SCM_SYMBOL (sym_h0
, "h0");
698 SCM_SYMBOL (sym_h1
, "h1");
699 SCM_SYMBOL (sym_h2
, "h2");
700 SCM_SYMBOL (sym_h3
, "h3");
701 SCM_SYMBOL (sym_h4
, "h4");
702 SCM_SYMBOL (sym_h5
, "h5");
703 SCM_SYMBOL (sym_h6
, "h6");
704 SCM_SYMBOL (sym_h7
, "h7");
705 SCM_SYMBOL (sym_name
, "name");
706 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
707 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
708 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
709 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
710 SCM_SYMBOL (sym_cpl
, "cpl");
711 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
712 SCM_SYMBOL (sym_slots
, "slots");
713 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
714 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
715 SCM_SYMBOL (sym_nfields
, "nfields");
716 SCM_SYMBOL (sym_environment
, "environment");
720 build_class_class_slots ()
723 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
724 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
725 scm_list_1 (sym_print
),
726 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
727 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
728 scm_list_1 (sym_redefined
),
729 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
730 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
731 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
732 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
733 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
734 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
735 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
736 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
737 scm_list_1 (sym_name
),
738 scm_list_1 (sym_direct_supers
),
739 scm_list_1 (sym_direct_slots
),
740 scm_list_1 (sym_direct_subclasses
),
741 scm_list_1 (sym_direct_methods
),
742 scm_list_1 (sym_cpl
),
743 scm_list_1 (sym_default_slot_definition_class
),
744 scm_list_1 (sym_slots
),
745 scm_list_1 (sym_getters_n_setters
),
746 scm_list_1 (sym_keyword_access
),
747 scm_list_1 (sym_nfields
),
748 scm_list_1 (sym_environment
),
753 create_basic_classes (void)
755 /* SCM slots_of_class = build_class_class_slots (); */
757 /**** <scm_class_class> ****/
758 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
759 + 2 * scm_vtable_offset_user
);
760 SCM name
= scm_str2symbol ("<class>");
761 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
764 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
765 | SCM_CLASSF_METACLASS
));
767 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
768 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
769 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
770 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
771 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
772 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
773 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
774 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
775 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
776 compute_getters_n_setters (slots_of_class)); */
777 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
778 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
779 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
781 prep_hashsets (scm_class_class
);
783 DEFVAR(name
, scm_class_class
);
785 /**** <scm_class_top> ****/
786 name
= scm_str2symbol ("<top>");
787 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
792 DEFVAR(name
, scm_class_top
);
794 /**** <scm_class_object> ****/
795 name
= scm_str2symbol ("<object>");
796 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
798 scm_list_1 (scm_class_top
),
801 DEFVAR (name
, scm_class_object
);
803 /* <top> <object> and <class> were partially initialized. Correct them here */
804 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
806 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
807 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
810 /******************************************************************************/
812 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
814 "Return @code{#t} if @var{obj} is an instance.")
815 #define FUNC_NAME s_scm_instance_p
817 return SCM_BOOL (SCM_INSTANCEP (obj
));
822 /******************************************************************************
824 * Meta object accessors
826 ******************************************************************************/
827 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
829 "Return the class name of @var{obj}.")
830 #define FUNC_NAME s_scm_class_name
832 SCM_VALIDATE_CLASS (1, obj
);
833 return scm_slot_ref (obj
, sym_name
);
837 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
839 "Return the direct superclasses of the class @var{obj}.")
840 #define FUNC_NAME s_scm_class_direct_supers
842 SCM_VALIDATE_CLASS (1, obj
);
843 return scm_slot_ref (obj
, sym_direct_supers
);
847 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
849 "Return the direct slots of the class @var{obj}.")
850 #define FUNC_NAME s_scm_class_direct_slots
852 SCM_VALIDATE_CLASS (1, obj
);
853 return scm_slot_ref (obj
, sym_direct_slots
);
857 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
859 "Return the direct subclasses of the class @var{obj}.")
860 #define FUNC_NAME s_scm_class_direct_subclasses
862 SCM_VALIDATE_CLASS (1, obj
);
863 return scm_slot_ref(obj
, sym_direct_subclasses
);
867 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
869 "Return the direct methods of the class @var{obj}")
870 #define FUNC_NAME s_scm_class_direct_methods
872 SCM_VALIDATE_CLASS (1, obj
);
873 return scm_slot_ref (obj
, sym_direct_methods
);
877 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
879 "Return the class precedence list of the class @var{obj}.")
880 #define FUNC_NAME s_scm_class_precedence_list
882 SCM_VALIDATE_CLASS (1, obj
);
883 return scm_slot_ref (obj
, sym_cpl
);
887 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
889 "Return the slot list of the class @var{obj}.")
890 #define FUNC_NAME s_scm_class_slots
892 SCM_VALIDATE_CLASS (1, obj
);
893 return scm_slot_ref (obj
, sym_slots
);
897 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
899 "Return the environment of the class @var{obj}.")
900 #define FUNC_NAME s_scm_class_environment
902 SCM_VALIDATE_CLASS (1, obj
);
903 return scm_slot_ref(obj
, sym_environment
);
908 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
910 "Return the name of the generic function @var{obj}.")
911 #define FUNC_NAME s_scm_generic_function_name
913 SCM_VALIDATE_GENERIC (1, obj
);
914 return scm_procedure_property (obj
, scm_sym_name
);
918 SCM_SYMBOL (sym_methods
, "methods");
919 SCM_SYMBOL (sym_extended_by
, "extended-by");
920 SCM_SYMBOL (sym_extends
, "extends");
923 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
925 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
926 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
927 while (!SCM_NULLP (gfs
))
929 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
936 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
938 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
940 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
941 while (!SCM_NULLP (gfs
))
943 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
944 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
953 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
955 "Return the methods of the generic function @var{obj}.")
956 #define FUNC_NAME s_scm_generic_function_methods
959 SCM_VALIDATE_GENERIC (1, obj
);
960 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
961 methods
= fold_downward_gf_methods (methods
, obj
);
962 return scm_append (methods
);
966 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
968 "Return the generic function for the method @var{obj}.")
969 #define FUNC_NAME s_scm_method_generic_function
971 SCM_VALIDATE_METHOD (1, obj
);
972 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
976 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
978 "Return specializers of the method @var{obj}.")
979 #define FUNC_NAME s_scm_method_specializers
981 SCM_VALIDATE_METHOD (1, obj
);
982 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
986 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
988 "Return the procedure of the method @var{obj}.")
989 #define FUNC_NAME s_scm_method_procedure
991 SCM_VALIDATE_METHOD (1, obj
);
992 return scm_slot_ref (obj
, sym_procedure
);
996 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
998 "Return the slot definition of the accessor @var{obj}.")
999 #define FUNC_NAME s_scm_accessor_method_slot_definition
1001 SCM_VALIDATE_ACCESSOR (1, obj
);
1002 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
1006 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1008 "Internal GOOPS magic---don't use this function!")
1009 #define FUNC_NAME s_scm_sys_tag_body
1011 return scm_cons (SCM_IM_LAMBDA
, body
);
1015 /******************************************************************************
1017 * S l o t a c c e s s
1019 ******************************************************************************/
1021 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1023 "Return the unbound value.")
1024 #define FUNC_NAME s_scm_make_unbound
1026 return SCM_GOOPS_UNBOUND
;
1030 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1032 "Return @code{#t} if @var{obj} is unbound.")
1033 #define FUNC_NAME s_scm_unbound_p
1035 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1039 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1040 (SCM value
, SCM obj
),
1041 "Return @var{value} if it is bound, and invoke the\n"
1042 "@var{slot-unbound} method of @var{obj} if it is not.")
1043 #define FUNC_NAME s_scm_assert_bound
1045 if (SCM_GOOPS_UNBOUNDP (value
))
1046 return CALL_GF1 ("slot-unbound", obj
);
1051 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1052 (SCM obj
, SCM index
),
1053 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1054 "the value from @var{obj}.")
1055 #define FUNC_NAME s_scm_at_assert_bound_ref
1057 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1058 if (SCM_GOOPS_UNBOUNDP (value
))
1059 return CALL_GF1 ("slot-unbound", obj
);
1064 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1065 (SCM obj
, SCM index
),
1066 "Return the slot value with index @var{index} from @var{obj}.")
1067 #define FUNC_NAME s_scm_sys_fast_slot_ref
1069 unsigned long int i
;
1071 SCM_VALIDATE_INSTANCE (1, obj
);
1072 SCM_VALIDATE_INUM (2, index
);
1073 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1074 i
= SCM_INUM (index
);
1075 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1077 return scm_at_assert_bound_ref (obj
, index
);
1081 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1082 (SCM obj
, SCM index
, SCM value
),
1083 "Set the slot with index @var{index} in @var{obj} to\n"
1085 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1087 unsigned long int i
;
1089 SCM_VALIDATE_INSTANCE (1, obj
);
1090 SCM_VALIDATE_INUM (2, index
);
1091 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1092 i
= SCM_INUM (index
);
1093 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1095 SCM_SET_SLOT (obj
, i
, value
);
1097 return SCM_UNSPECIFIED
;
1104 /* In the future, this function will return the effective slot
1105 * definition associated with SLOT_NAME. Now it just returns some of
1106 * the information which will be stored in the effective slot
1111 slot_definition_using_name (SCM
class, SCM slot_name
)
1113 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1114 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1115 if (SCM_CAAR (slots
) == slot_name
)
1116 return SCM_CAR (slots
);
1121 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1123 SCM access
= SCM_CDDR (slotdef
);
1125 * - access is an integer (the offset of this slot in the slots vector)
1126 * - otherwise (car access) is the getter function to apply
1128 if (SCM_INUMP (access
))
1129 return SCM_SLOT (obj
, SCM_INUM (access
));
1132 /* We must evaluate (apply (car access) (list obj))
1133 * where (car access) is known to be a closure of arity 1 */
1134 register SCM code
, env
;
1136 code
= SCM_CAR (access
);
1137 if (!SCM_CLOSUREP (code
))
1138 return SCM_SUBRF (code
) (obj
);
1139 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1142 /* Evaluate the closure body */
1143 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1148 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1150 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1151 if (!SCM_FALSEP (slotdef
))
1152 return get_slot_value (class, obj
, slotdef
);
1154 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1158 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1160 SCM access
= SCM_CDDR (slotdef
);
1162 * - access is an integer (the offset of this slot in the slots vector)
1163 * - otherwise (cadr access) is the setter function to apply
1165 if (SCM_INUMP (access
))
1166 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1169 /* We must evaluate (apply (cadr l) (list obj value))
1170 * where (cadr l) is known to be a closure of arity 2 */
1171 register SCM code
, env
;
1173 code
= SCM_CADR (access
);
1174 if (!SCM_CLOSUREP (code
))
1175 SCM_SUBRF (code
) (obj
, value
);
1178 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1179 scm_list_2 (obj
, value
),
1181 /* Evaluate the closure body */
1182 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1185 return SCM_UNSPECIFIED
;
1189 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1191 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1192 if (!SCM_FALSEP (slotdef
))
1193 return set_slot_value (class, obj
, slotdef
, value
);
1195 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1199 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1203 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1204 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1210 /* ======================================== */
1212 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1213 (SCM
class, SCM obj
, SCM slot_name
),
1215 #define FUNC_NAME s_scm_slot_ref_using_class
1219 SCM_VALIDATE_CLASS (1, class);
1220 SCM_VALIDATE_INSTANCE (2, obj
);
1221 SCM_VALIDATE_SYMBOL (3, slot_name
);
1223 res
= get_slot_value_using_name (class, obj
, slot_name
);
1224 if (SCM_GOOPS_UNBOUNDP (res
))
1225 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1231 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1232 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1234 #define FUNC_NAME s_scm_slot_set_using_class_x
1236 SCM_VALIDATE_CLASS (1, class);
1237 SCM_VALIDATE_INSTANCE (2, obj
);
1238 SCM_VALIDATE_SYMBOL (3, slot_name
);
1240 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1245 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1246 (SCM
class, SCM obj
, SCM slot_name
),
1248 #define FUNC_NAME s_scm_slot_bound_using_class_p
1250 SCM_VALIDATE_CLASS (1, class);
1251 SCM_VALIDATE_INSTANCE (2, obj
);
1252 SCM_VALIDATE_SYMBOL (3, slot_name
);
1254 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1260 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1261 (SCM
class, SCM obj
, SCM slot_name
),
1263 #define FUNC_NAME s_scm_slot_exists_using_class_p
1265 SCM_VALIDATE_CLASS (1, class);
1266 SCM_VALIDATE_INSTANCE (2, obj
);
1267 SCM_VALIDATE_SYMBOL (3, slot_name
);
1268 return test_slot_existence (class, obj
, slot_name
);
1273 /* ======================================== */
1275 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1276 (SCM obj
, SCM slot_name
),
1277 "Return the value from @var{obj}'s slot with the name\n"
1279 #define FUNC_NAME s_scm_slot_ref
1283 SCM_VALIDATE_INSTANCE (1, obj
);
1284 TEST_CHANGE_CLASS (obj
, class);
1286 res
= get_slot_value_using_name (class, obj
, slot_name
);
1287 if (SCM_GOOPS_UNBOUNDP (res
))
1288 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1293 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1294 (SCM obj
, SCM slot_name
, SCM value
),
1295 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1296 #define FUNC_NAME s_scm_slot_set_x
1300 SCM_VALIDATE_INSTANCE (1, obj
);
1301 TEST_CHANGE_CLASS(obj
, class);
1303 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1307 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1309 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1310 (SCM obj
, SCM slot_name
),
1311 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1313 #define FUNC_NAME s_scm_slot_bound_p
1317 SCM_VALIDATE_INSTANCE (1, obj
);
1318 TEST_CHANGE_CLASS(obj
, class);
1320 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1328 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1329 (SCM obj
, SCM slot_name
),
1330 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1331 #define FUNC_NAME s_scm_slot_exists_p
1335 SCM_VALIDATE_INSTANCE (1, obj
);
1336 SCM_VALIDATE_SYMBOL (2, slot_name
);
1337 TEST_CHANGE_CLASS (obj
, class);
1339 return test_slot_existence (class, obj
, slot_name
);
1344 /******************************************************************************
1346 * %allocate-instance (the low level instance allocation primitive)
1348 ******************************************************************************/
1350 static void clear_method_cache (SCM
);
1353 wrap_init (SCM
class, SCM
*m
, long n
)
1357 /* Set all slots to unbound */
1358 for (i
= 0; i
< n
; i
++)
1359 m
[i
] = SCM_GOOPS_UNBOUND
;
1361 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1363 (scm_t_bits
) m
, 0, 0);
1366 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1367 (SCM
class, SCM initargs
),
1368 "Create a new instance of class @var{class} and initialize it\n"
1369 "from the arguments @var{initargs}.")
1370 #define FUNC_NAME s_scm_sys_allocate_instance
1375 SCM_VALIDATE_CLASS (1, class);
1377 /* Most instances */
1378 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1380 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1381 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1382 return wrap_init (class, m
, n
);
1385 /* Foreign objects */
1386 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1387 return scm_make_foreign_object (class, initargs
);
1389 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1392 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1394 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1396 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1397 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1398 /* Generic functions */
1399 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1401 SCM gf
= wrap_init (class, m
, n
);
1402 clear_method_cache (gf
);
1406 return wrap_init (class, m
, n
);
1410 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1414 /* allocate class object */
1415 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1417 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1418 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1419 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1421 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1422 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1423 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1424 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1429 /* Non-light instances */
1431 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1432 return wrap_init (class, m
, n
);
1437 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1438 (SCM obj
, SCM setter
),
1440 #define FUNC_NAME s_scm_sys_set_object_setter_x
1442 SCM_ASSERT (SCM_STRUCTP (obj
)
1443 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1444 || SCM_I_ENTITYP (obj
)),
1448 if (SCM_I_ENTITYP (obj
))
1449 SCM_SET_ENTITY_SETTER (obj
, setter
);
1451 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1452 return SCM_UNSPECIFIED
;
1456 /******************************************************************************
1458 * %modify-instance (used by change-class to modify in place)
1460 ******************************************************************************/
1462 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1465 #define FUNC_NAME s_scm_sys_modify_instance
1467 SCM_VALIDATE_INSTANCE (1, old
);
1468 SCM_VALIDATE_INSTANCE (2, new);
1470 /* Exchange the data contained in old and new. We exchange rather than
1471 * scratch the old value with new to be correct with GC.
1472 * See "Class redefinition protocol above".
1476 SCM car
= SCM_CAR (old
);
1477 SCM cdr
= SCM_CDR (old
);
1478 SCM_SETCAR (old
, SCM_CAR (new));
1479 SCM_SETCDR (old
, SCM_CDR (new));
1480 SCM_SETCAR (new, car
);
1481 SCM_SETCDR (new, cdr
);
1484 return SCM_UNSPECIFIED
;
1488 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1491 #define FUNC_NAME s_scm_sys_modify_class
1493 SCM_VALIDATE_CLASS (1, old
);
1494 SCM_VALIDATE_CLASS (2, new);
1498 SCM car
= SCM_CAR (old
);
1499 SCM cdr
= SCM_CDR (old
);
1500 SCM_SETCAR (old
, SCM_CAR (new));
1501 SCM_SETCDR (old
, SCM_CDR (new));
1502 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1503 SCM_SETCAR (new, car
);
1504 SCM_SETCDR (new, cdr
);
1505 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1508 return SCM_UNSPECIFIED
;
1512 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1515 #define FUNC_NAME s_scm_sys_invalidate_class
1517 SCM_VALIDATE_CLASS (1, class);
1518 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1519 return SCM_UNSPECIFIED
;
1523 /* When instances change class, they finally get a new body, but
1524 * before that, they go through purgatory in hell. Odd as it may
1525 * seem, this data structure saves us from eternal suffering in
1526 * infinite recursions.
1529 static scm_t_bits
**hell
;
1530 static long n_hell
= 1; /* one place for the evil one himself */
1531 static long hell_size
= 4;
1532 static SCM hell_mutex
;
1538 for (i
= 1; i
< n_hell
; ++i
)
1539 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1545 go_to_hell (void *o
)
1547 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1548 scm_lock_mutex (hell_mutex
);
1549 if (n_hell
== hell_size
)
1551 long new_size
= 2 * hell_size
;
1552 hell
= scm_realloc (hell
, new_size
);
1553 hell_size
= new_size
;
1555 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1556 scm_unlock_mutex (hell_mutex
);
1560 go_to_heaven (void *o
)
1562 scm_lock_mutex (hell_mutex
);
1563 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1564 scm_unlock_mutex (hell_mutex
);
1568 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1571 purgatory (void *args
)
1573 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1574 SCM_PACK ((scm_t_bits
) args
));
1577 /* This function calls the generic function change-class for all
1578 * instances which aren't currently undergoing class change.
1582 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1585 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1586 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1587 (void *) SCM_UNPACK (obj
));
1590 /******************************************************************************
1596 * GGG E N E R I C F U N C T I O N S
1598 * This implementation provides
1599 * - generic functions (with class specializers)
1602 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1604 ******************************************************************************/
1606 SCM_KEYWORD (k_name
, "name");
1608 SCM_SYMBOL (sym_no_method
, "no-method");
1610 static SCM list_of_no_method
;
1612 SCM_SYMBOL (scm_sym_args
, "args");
1615 scm_make_method_cache (SCM gf
)
1617 return scm_list_5 (SCM_IM_DISPATCH
,
1620 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1626 clear_method_cache (SCM gf
)
1628 SCM cache
= scm_make_method_cache (gf
);
1629 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1630 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1633 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1636 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1639 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1640 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1641 if (!SCM_FALSEP (used_by
))
1643 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1644 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1645 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1646 clear_method_cache (gf
);
1647 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1648 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1651 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1652 /* The sign of n is a flag indicating rest args. */
1653 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1655 return SCM_UNSPECIFIED
;
1659 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1662 #define FUNC_NAME s_scm_generic_capability_p
1664 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1665 proc
, SCM_ARG1
, FUNC_NAME
);
1666 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1672 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1675 #define FUNC_NAME s_scm_enable_primitive_generic_x
1677 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1678 while (!SCM_NULLP (subrs
))
1680 SCM subr
= SCM_CAR (subrs
);
1681 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1682 subr
, SCM_ARGn
, FUNC_NAME
);
1683 *SCM_SUBR_GENERIC (subr
)
1684 = scm_make (scm_list_3 (scm_class_generic
,
1687 subrs
= SCM_CDR (subrs
);
1689 return SCM_UNSPECIFIED
;
1693 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1696 #define FUNC_NAME s_scm_primitive_generic_generic
1698 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1700 if (!*SCM_SUBR_GENERIC (subr
))
1701 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1702 return *SCM_SUBR_GENERIC (subr
);
1704 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1708 typedef struct t_extension
{
1709 struct t_extension
*next
;
1714 static t_extension
*extensions
= 0;
1716 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1719 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1724 if (!*SCM_SUBR_GENERIC (extended
))
1725 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1726 gf
= *SCM_SUBR_GENERIC (extended
);
1727 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1729 SCM_SNAME (extension
));
1730 *SCM_SUBR_GENERIC (extension
) = gext
;
1734 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1735 t_extension
**loc
= &extensions
;
1736 /* Make sure that extensions are placed before their own
1737 * extensions in the extensions list. O(N^2) algorithm, but
1738 * extensions of primitive generics are rare.
1740 while (*loc
&& extension
!= (*loc
)->extended
)
1741 loc
= &(*loc
)->next
;
1743 e
->extended
= extended
;
1744 e
->extension
= extension
;
1750 setup_extended_primitive_generics ()
1754 t_extension
*e
= extensions
;
1755 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1756 extensions
= e
->next
;
1761 /******************************************************************************
1763 * Protocol for calling a generic fumction
1764 * This protocol is roughly equivalent to (parameter are a little bit different
1765 * for efficiency reasons):
1767 * + apply-generic (gf args)
1768 * + compute-applicable-methods (gf args ...)
1769 * + sort-applicable-methods (methods args)
1770 * + apply-methods (gf methods args)
1772 * apply-methods calls make-next-method to build the "continuation" of a a
1773 * method. Applying a next-method will call apply-next-method which in
1774 * turn will call apply again to call effectively the following method.
1776 ******************************************************************************/
1779 applicablep (SCM actual
, SCM formal
)
1781 /* We already know that the cpl is well formed. */
1782 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1786 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1788 register SCM s1
, s2
;
1792 * m1 and m2 can have != length (i.e. one can be one element longer than the
1793 * other when we have a dotted parameter list). For instance, with the call
1796 * (define-method M (a . l) ....)
1797 * (define-method M (a) ....)
1799 * we consider that the second method is more specific.
1801 * BTW, targs is an array of types. We don't need it's size since
1802 * we already know that m1 and m2 are applicable (no risk to go past
1803 * the end of this array).
1806 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1807 if (SCM_NULLP(s1
)) return 1;
1808 if (SCM_NULLP(s2
)) return 0;
1809 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1810 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1812 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1813 if (cs1
== SCM_CAR(l
))
1815 if (cs2
== SCM_CAR(l
))
1818 return 0;/* should not occur! */
1821 return 0; /* should not occur! */
1824 #define BUFFSIZE 32 /* big enough for most uses */
1827 scm_i_vector2list (SCM l
, long len
)
1830 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1832 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1833 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1839 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1842 SCM
*v
, vector
= SCM_EOL
;
1843 SCM buffer
[BUFFSIZE
];
1844 SCM save
= method_list
;
1846 /* For reasonably sized method_lists we can try to avoid all the
1847 * consing and reorder the list in place...
1848 * This idea is due to David McClain <Dave_McClain@msn.com>
1850 if (size
<= BUFFSIZE
)
1852 for (i
= 0; i
< size
; i
++)
1854 buffer
[i
] = SCM_CAR (method_list
);
1855 method_list
= SCM_CDR (method_list
);
1861 /* Too many elements in method_list to keep everything locally */
1862 vector
= scm_i_vector2list (save
, size
);
1865 This is a new vector. Don't worry about the write barrier.
1866 We're not allocating elements in this routine, so this should
1869 v
= SCM_WRITABLE_VELTS (vector
);
1872 /* Use a simple shell sort since it is generally faster than qsort on
1873 * small vectors (which is probably mostly the case when we have to
1874 * sort a list of applicable methods).
1876 for (incr
= size
/ 2; incr
; incr
/= 2)
1878 for (i
= incr
; i
< size
; i
++)
1880 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1882 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1886 SCM tmp
= v
[j
+ incr
];
1894 if (size
<= BUFFSIZE
)
1896 /* We did it in locally, so restore the original list (reordered) in-place */
1897 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1899 SCM_SETCAR (method_list
, *v
);
1900 method_list
= SCM_CDR (method_list
);
1904 /* If we are here, that's that we did it the hard way... */
1905 return scm_vector_to_list (vector
);
1909 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1913 SCM l
, fl
, applicable
= SCM_EOL
;
1915 SCM buffer
[BUFFSIZE
];
1920 /* Build the list of arguments types */
1921 if (len
>= BUFFSIZE
) {
1922 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1923 /* NOTE: Using pointers to malloced memory won't work if we
1924 1. have preemtive threading, and,
1925 2. have a GC which moves objects. */
1926 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1929 note that we don't have to work to reset the generation
1930 count. TMP is a new vector anyway, and it is found
1937 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1938 *p
++ = scm_class_of (SCM_CAR (args
));
1940 /* Build a list of all applicable methods */
1941 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1943 fl
= SPEC_OF (SCM_CAR (l
));
1944 /* Only accept accessors which match exactly in first arg. */
1945 if (SCM_ACCESSORP (SCM_CAR (l
))
1946 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1948 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1950 if (SCM_INSTANCEP (fl
)
1951 /* We have a dotted argument list */
1952 || (i
>= len
&& SCM_NULLP (fl
)))
1953 { /* both list exhausted */
1954 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1960 || !applicablep (types
[i
], SCM_CAR (fl
)))
1969 CALL_GF2 ("no-applicable-method", gf
, save
);
1970 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1974 scm_remember_upto_here_1 (tmp
);
1977 : sort_applicable_methods (applicable
, count
, types
));
1981 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1984 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1987 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1988 #define FUNC_NAME s_sys_compute_applicable_methods
1991 SCM_VALIDATE_GENERIC (1, gf
);
1992 n
= scm_ilength (args
);
1993 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1994 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1998 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1999 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
));
2001 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
2004 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
2005 #define FUNC_NAME s_atslot_ref
2007 SCM x
= SCM_CDR (xorig
);
2008 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
2009 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
2010 return scm_cons (SCM_IM_SLOT_REF
, x
);
2015 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
2018 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
2019 #define FUNC_NAME s_atslot_set_x
2021 SCM x
= SCM_CDR (xorig
);
2022 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
2023 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
2024 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
2029 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
2031 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
2034 scm_m_atdispatch (SCM xorig
, SCM env
)
2035 #define FUNC_NAME s_atdispatch
2037 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
2038 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
2040 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
2041 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
2043 n
= SCM_XEVALCAR (x
, env
);
2044 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
2045 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
2047 v
= SCM_XEVALCAR (x
, env
);
2048 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
2050 gf
= SCM_XEVALCAR (x
, env
);
2051 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
2052 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
2058 lock_cache_mutex (void *m
)
2060 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2061 scm_lock_mutex (mutex
);
2065 unlock_cache_mutex (void *m
)
2067 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2068 scm_unlock_mutex (mutex
);
2072 call_memoize_method (void *a
)
2074 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2075 SCM gf
= SCM_CAR (args
);
2076 SCM x
= SCM_CADR (args
);
2077 /* First check if another thread has inserted a method between
2078 * the cache miss and locking the mutex.
2080 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2081 if (!SCM_FALSEP (cmethod
))
2083 /*fixme* Use scm_apply */
2084 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2088 scm_memoize_method (SCM x
, SCM args
)
2090 SCM gf
= SCM_CAR (scm_last_pair (x
));
2091 return scm_internal_dynamic_wind (
2093 call_memoize_method
,
2095 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2096 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2099 /******************************************************************************
2101 * A simple make (which will be redefined later in Scheme)
2102 * This version handles only creation of gf, methods and classes (no instances)
2104 * Since this code will disappear when Goops will be fully booted,
2105 * no precaution is taken to be efficient.
2107 ******************************************************************************/
2109 SCM_KEYWORD (k_setter
, "setter");
2110 SCM_KEYWORD (k_specializers
, "specializers");
2111 SCM_KEYWORD (k_procedure
, "procedure");
2112 SCM_KEYWORD (k_dsupers
, "dsupers");
2113 SCM_KEYWORD (k_slots
, "slots");
2114 SCM_KEYWORD (k_gf
, "generic-function");
2116 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2118 "Make a new object. @var{args} must contain the class and\n"
2119 "all necessary initialization information.")
2120 #define FUNC_NAME s_scm_make
2123 long len
= scm_ilength (args
);
2125 if (len
<= 0 || (len
& 1) == 0)
2126 SCM_WRONG_NUM_ARGS ();
2128 class = SCM_CAR(args
);
2129 args
= SCM_CDR(args
);
2131 if (class == scm_class_generic
|| class == scm_class_accessor
)
2133 z
= scm_make_struct (class, SCM_INUM0
,
2134 scm_list_5 (SCM_EOL
,
2139 scm_set_procedure_property_x (z
, scm_sym_name
,
2140 scm_get_keyword (k_name
,
2143 clear_method_cache (z
);
2144 if (class == scm_class_accessor
)
2146 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2147 if (!SCM_FALSEP (setter
))
2148 scm_sys_set_object_setter_x (z
, setter
);
2153 z
= scm_sys_allocate_instance (class, args
);
2155 if (class == scm_class_method
2156 || class == scm_class_simple_method
2157 || class == scm_class_accessor_method
)
2159 SCM_SET_SLOT (z
, scm_si_generic_function
,
2160 scm_i_get_keyword (k_gf
,
2165 SCM_SET_SLOT (z
, scm_si_specializers
,
2166 scm_i_get_keyword (k_specializers
,
2171 SCM_SET_SLOT (z
, scm_si_procedure
,
2172 scm_i_get_keyword (k_procedure
,
2177 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2181 /* In all the others case, make a new class .... No instance here */
2182 SCM_SET_SLOT (z
, scm_si_name
,
2183 scm_i_get_keyword (k_name
,
2186 scm_str2symbol ("???"),
2188 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2189 scm_i_get_keyword (k_dsupers
,
2194 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2195 scm_i_get_keyword (k_slots
,
2206 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2209 #define FUNC_NAME s_scm_find_method
2212 long len
= scm_ilength (l
);
2215 SCM_WRONG_NUM_ARGS ();
2217 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2218 SCM_VALIDATE_GENERIC (1, gf
);
2219 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2220 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2222 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2226 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2227 (SCM m1
, SCM m2
, SCM targs
),
2229 #define FUNC_NAME s_scm_sys_method_more_specific_p
2234 SCM_VALIDATE_METHOD (1, m1
);
2235 SCM_VALIDATE_METHOD (2, m2
);
2236 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2238 /* Verify that all the arguments of targs are classes and place them in a vector*/
2239 v
= scm_c_make_vector (len
, SCM_EOL
);
2241 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2242 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2243 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2245 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2251 /******************************************************************************
2255 ******************************************************************************/
2258 fix_cpl (SCM c
, SCM before
, SCM after
)
2260 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2261 SCM ls
= scm_c_memq (after
, cpl
);
2262 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2263 if (SCM_FALSEP (ls
))
2264 /* if this condition occurs, fix_cpl should not be applied this way */
2266 SCM_SETCAR (ls
, before
);
2267 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2269 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2270 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2271 SCM g_n_s
= compute_getters_n_setters (slots
);
2272 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2273 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2279 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2281 SCM tmp
= scm_str2symbol (name
);
2283 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2287 : scm_list_1 (super
),
2293 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2296 create_standard_classes (void)
2299 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2300 scm_str2symbol ("specializers"),
2302 scm_str2symbol ("code-table"));
2303 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2305 k_slot_definition
));
2306 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2307 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2308 scm_list_3 (scm_str2symbol ("n-specialized"),
2311 scm_list_3 (scm_str2symbol ("used-by"),
2314 scm_list_3 (scm_str2symbol ("cache-mutex"),
2316 scm_closure (scm_list_2 (SCM_EOL
,
2319 scm_list_3 (scm_str2symbol ("extended-by"),
2322 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2325 /* Foreign class slot classes */
2326 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2327 scm_class_class
, scm_class_top
, SCM_EOL
);
2328 make_stdcls (&scm_class_protected
, "<protected-slot>",
2329 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2330 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2331 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2332 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2333 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2334 make_stdcls (&scm_class_self
, "<self-slot>",
2336 scm_class_read_only
,
2338 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2340 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2342 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2344 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2346 make_stdcls (&scm_class_scm
, "<scm-slot>",
2347 scm_class_class
, scm_class_protected
, SCM_EOL
);
2348 make_stdcls (&scm_class_int
, "<int-slot>",
2349 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2350 make_stdcls (&scm_class_float
, "<float-slot>",
2351 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2352 make_stdcls (&scm_class_double
, "<double-slot>",
2353 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2355 /* Continue initialization of class <class> */
2357 slots
= build_class_class_slots ();
2358 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2359 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2360 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2361 compute_getters_n_setters (slots
));
2363 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2364 scm_class_class
, scm_class_class
,
2365 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2368 scm_list_3 (scm_str2symbol ("destructor"),
2370 scm_class_opaque
)));
2371 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2372 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2373 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2375 /* scm_class_generic functions classes */
2376 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2377 scm_class_class
, scm_class_class
, SCM_EOL
);
2378 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2379 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2380 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2381 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2382 make_stdcls (&scm_class_operator_with_setter_class
,
2383 "<operator-with-setter-class>",
2384 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2385 make_stdcls (&scm_class_method
, "<method>",
2386 scm_class_class
, scm_class_object
, method_slots
);
2387 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2388 scm_class_class
, scm_class_method
, SCM_EOL
);
2389 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2390 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2391 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2392 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2393 make_stdcls (&scm_class_applicable
, "<applicable>",
2394 scm_class_class
, scm_class_top
, SCM_EOL
);
2395 make_stdcls (&scm_class_entity
, "<entity>",
2396 scm_class_entity_class
,
2397 scm_list_2 (scm_class_object
, scm_class_applicable
),
2399 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2400 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2401 make_stdcls (&scm_class_generic
, "<generic>",
2402 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2403 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2404 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2405 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2406 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2407 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2408 scm_class_entity_class
,
2409 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2411 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2412 make_stdcls (&scm_class_accessor
, "<accessor>",
2413 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2414 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2415 make_stdcls (&scm_class_extended_generic_with_setter
,
2416 "<extended-generic-with-setter>",
2417 scm_class_entity_class
,
2418 scm_list_2 (scm_class_generic_with_setter
,
2419 scm_class_extended_generic
),
2421 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2422 SCM_CLASSF_PURE_GENERIC
);
2423 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2424 scm_class_entity_class
,
2425 scm_list_2 (scm_class_accessor
,
2426 scm_class_extended_generic_with_setter
),
2428 fix_cpl (scm_class_extended_accessor
,
2429 scm_class_extended_generic
, scm_class_generic
);
2430 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2432 /* Primitive types classes */
2433 make_stdcls (&scm_class_boolean
, "<boolean>",
2434 scm_class_class
, scm_class_top
, SCM_EOL
);
2435 make_stdcls (&scm_class_char
, "<char>",
2436 scm_class_class
, scm_class_top
, SCM_EOL
);
2437 make_stdcls (&scm_class_list
, "<list>",
2438 scm_class_class
, scm_class_top
, SCM_EOL
);
2439 make_stdcls (&scm_class_pair
, "<pair>",
2440 scm_class_class
, scm_class_list
, SCM_EOL
);
2441 make_stdcls (&scm_class_null
, "<null>",
2442 scm_class_class
, scm_class_list
, SCM_EOL
);
2443 make_stdcls (&scm_class_string
, "<string>",
2444 scm_class_class
, scm_class_top
, SCM_EOL
);
2445 make_stdcls (&scm_class_symbol
, "<symbol>",
2446 scm_class_class
, scm_class_top
, SCM_EOL
);
2447 make_stdcls (&scm_class_vector
, "<vector>",
2448 scm_class_class
, scm_class_top
, SCM_EOL
);
2449 make_stdcls (&scm_class_number
, "<number>",
2450 scm_class_class
, scm_class_top
, SCM_EOL
);
2451 make_stdcls (&scm_class_complex
, "<complex>",
2452 scm_class_class
, scm_class_number
, SCM_EOL
);
2453 make_stdcls (&scm_class_real
, "<real>",
2454 scm_class_class
, scm_class_complex
, SCM_EOL
);
2455 make_stdcls (&scm_class_integer
, "<integer>",
2456 scm_class_class
, scm_class_real
, SCM_EOL
);
2457 make_stdcls (&scm_class_keyword
, "<keyword>",
2458 scm_class_class
, scm_class_top
, SCM_EOL
);
2459 make_stdcls (&scm_class_unknown
, "<unknown>",
2460 scm_class_class
, scm_class_top
, SCM_EOL
);
2461 make_stdcls (&scm_class_procedure
, "<procedure>",
2462 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2463 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2464 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2465 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2466 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2467 make_stdcls (&scm_class_port
, "<port>",
2468 scm_class_class
, scm_class_top
, SCM_EOL
);
2469 make_stdcls (&scm_class_input_port
, "<input-port>",
2470 scm_class_class
, scm_class_port
, SCM_EOL
);
2471 make_stdcls (&scm_class_output_port
, "<output-port>",
2472 scm_class_class
, scm_class_port
, SCM_EOL
);
2473 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2475 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2479 /**********************************************************************
2483 **********************************************************************/
2486 make_class_from_template (char *template, char *type_name
, SCM supers
, int applicablep
)
2492 sprintf (buffer
, template, type_name
);
2493 name
= scm_str2symbol (buffer
);
2496 name
= SCM_GOOPS_UNBOUND
;
2498 class = scm_permanent_object (scm_basic_make_class (applicablep
2499 ? scm_class_procedure_class
2505 /* Only define name if doesn't already exist. */
2506 if (!SCM_GOOPS_UNBOUNDP (name
)
2507 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2508 DEFVAR (name
, class);
2513 scm_make_extended_class (char *type_name
, int applicablep
)
2515 return make_class_from_template ("<%s>",
2517 scm_list_1 (applicablep
2518 ? scm_class_applicable
2524 scm_i_inherit_applicable (SCM c
)
2526 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2528 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2529 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2530 /* patch scm_class_applicable into direct-supers */
2531 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2532 if (SCM_FALSEP (top
))
2533 dsupers
= scm_append (scm_list_2 (dsupers
,
2534 scm_list_1 (scm_class_applicable
)));
2537 SCM_SETCAR (top
, scm_class_applicable
);
2538 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2540 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2541 /* patch scm_class_applicable into cpl */
2542 top
= scm_c_memq (scm_class_top
, cpl
);
2543 if (SCM_FALSEP (top
))
2547 SCM_SETCAR (top
, scm_class_applicable
);
2548 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2550 /* add class to direct-subclasses of scm_class_applicable */
2551 SCM_SET_SLOT (scm_class_applicable
,
2552 scm_si_direct_subclasses
,
2553 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2554 scm_si_direct_subclasses
)));
2559 create_smob_classes (void)
2563 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2564 for (i
= 0; i
< 255; ++i
)
2565 scm_smob_class
[i
] = 0;
2567 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2568 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2569 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2570 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2572 for (i
= 0; i
< scm_numsmob
; ++i
)
2573 if (!scm_smob_class
[i
])
2574 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2575 scm_smobs
[i
].apply
!= 0);
2579 scm_make_port_classes (long ptobnum
, char *type_name
)
2581 SCM c
, class = make_class_from_template ("<%s-port>",
2583 scm_list_1 (scm_class_port
),
2585 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2586 = make_class_from_template ("<%s-input-port>",
2588 scm_list_2 (class, scm_class_input_port
),
2590 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2591 = make_class_from_template ("<%s-output-port>",
2593 scm_list_2 (class, scm_class_output_port
),
2595 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2597 = make_class_from_template ("<%s-input-output-port>",
2599 scm_list_2 (class, scm_class_input_output_port
),
2601 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2602 SCM_SET_SLOT (c
, scm_si_cpl
,
2603 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2607 create_port_classes (void)
2611 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2612 for (i
= 0; i
< 3 * 256; ++i
)
2613 scm_port_class
[i
] = 0;
2615 for (i
= 0; i
< scm_numptob
; ++i
)
2616 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2620 make_struct_class (void *closure SCM_UNUSED
,
2621 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2623 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2624 SCM_SET_STRUCT_TABLE_CLASS (data
,
2625 scm_make_extended_class
2626 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
)),
2627 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2628 return SCM_UNSPECIFIED
;
2632 create_struct_classes (void)
2634 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2637 /**********************************************************************
2641 **********************************************************************/
2646 if (!goops_loaded_p
)
2647 scm_c_resolve_module ("oop goops");
2652 scm_make_foreign_object (SCM
class, SCM initargs
)
2653 #define FUNC_NAME s_scm_make
2655 void * (*constructor
) (SCM
)
2656 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2657 if (constructor
== 0)
2658 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2659 return scm_wrap_object (class, constructor (initargs
));
2665 scm_free_foreign_object (SCM
*class, SCM
*data
)
2667 size_t (*destructor
) (void *)
2668 = (size_t (*) (void *)) class[scm_si_destructor
];
2669 return destructor (data
);
2673 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2674 void * (*constructor
) (SCM initargs
),
2675 size_t (*destructor
) (void *))
2678 name
= scm_str2symbol (s_name
);
2679 if (SCM_NULLP (supers
))
2680 supers
= scm_list_1 (scm_class_foreign_object
);
2681 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2682 scm_sys_inherit_magic_x (class, supers
);
2684 if (destructor
!= 0)
2686 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2687 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2691 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2692 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2695 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2696 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2701 SCM_SYMBOL (sym_o
, "o");
2702 SCM_SYMBOL (sym_x
, "x");
2704 SCM_KEYWORD (k_accessor
, "accessor");
2705 SCM_KEYWORD (k_getter
, "getter");
2708 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2710 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2715 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2716 SCM (*getter
) (SCM obj
),
2717 SCM (*setter
) (SCM obj
, SCM x
),
2718 char *accessor_name
)
2721 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2722 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2723 setter
? setter
: default_setter
);
2724 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2725 scm_list_2 (get
, sym_o
)),
2727 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2728 scm_list_3 (set
, sym_o
, sym_x
)),
2731 SCM name
= scm_str2symbol (slot_name
);
2732 SCM aname
= scm_str2symbol (accessor_name
);
2733 SCM gf
= scm_ensure_accessor (aname
);
2734 SCM slot
= scm_list_5 (name
,
2737 setter
? k_accessor
: k_getter
,
2739 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2744 scm_add_method (scm_setter (gf
),
2745 scm_make (scm_list_5 (scm_class_accessor_method
,
2747 scm_list_2 (class, scm_class_top
),
2752 SCM_SET_SLOT (class, scm_si_slots
,
2753 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2754 scm_list_1 (slot
))));
2756 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2757 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, SCM_MAKINUM (1));
2758 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2759 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2760 scm_list_1 (gns
))));
2761 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (SCM_INUM (n
) + 1));
2768 scm_wrap_object (SCM
class, void *data
)
2770 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2778 scm_wrap_component (SCM
class, SCM container
, void *data
)
2780 SCM obj
= scm_wrap_object (class, data
);
2781 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2787 SCM_SETCDR (handle
, container
);
2792 scm_ensure_accessor (SCM name
)
2794 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2795 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2797 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2798 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2799 k_name
, name
, k_setter
, gf
));
2804 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2807 scm_add_method (SCM gf
, SCM m
)
2809 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2814 * Debugging utilities
2817 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2819 "Return @code{#t} if @var{obj} is a pure generic.")
2820 #define FUNC_NAME s_scm_pure_generic_p
2822 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2826 #endif /* GUILE_DEBUG */
2832 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2834 "Announce that GOOPS is loaded and perform initialization\n"
2835 "on the C level which depends on the loaded GOOPS modules.")
2836 #define FUNC_NAME s_scm_sys_goops_loaded
2839 var_compute_applicable_methods
=
2840 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2842 setup_extended_primitive_generics ();
2843 return SCM_UNSPECIFIED
;
2847 SCM scm_module_goops
;
2850 scm_init_goops_builtins (void)
2852 scm_module_goops
= scm_current_module ();
2853 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2855 /* Not really necessary right now, but who knows...
2857 scm_permanent_object (scm_module_goops
);
2858 scm_permanent_object (scm_goops_lookup_closure
);
2860 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2861 (SCM_MAKINUM (37)));
2863 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2865 #include "libguile/goops.x"
2867 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2869 hell
= scm_malloc (hell_size
);
2870 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2872 create_basic_classes ();
2873 create_standard_classes ();
2874 create_smob_classes ();
2875 create_struct_classes ();
2876 create_port_classes ();
2879 SCM name
= scm_str2symbol ("no-applicable-method");
2880 scm_no_applicable_method
2881 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2884 DEFVAR (name
, scm_no_applicable_method
);
2887 return SCM_UNSPECIFIED
;
2893 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2894 scm_init_goops_builtins
);