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
));
446 SCM_KEYWORD (k_class
, "class");
447 SCM_KEYWORD (k_allocation
, "allocation");
448 SCM_KEYWORD (k_instance
, "instance");
450 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
453 #define FUNC_NAME s_scm_sys_prep_layout_x
456 unsigned long int n
, i
;
459 SCM_VALIDATE_INSTANCE (1, class);
460 slots
= SCM_SLOT (class, scm_si_slots
);
461 nfields
= SCM_SLOT (class, scm_si_nfields
);
462 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
463 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
464 scm_list_1 (nfields
));
465 n
= 2 * SCM_INUM (nfields
);
466 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
467 && SCM_SUBCLASSP (class, scm_class_class
))
468 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
469 scm_list_1 (nfields
));
471 s
= n
> 0 ? scm_malloc (n
) : 0;
472 for (i
= 0; i
< n
; i
+= 2)
475 SCM type
, allocation
;
478 if (!SCM_CONSP (slots
))
479 SCM_MISC_ERROR ("too few slot definitions", SCM_EOL
);
480 len
= scm_ilength (SCM_CDAR (slots
));
481 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
482 len
, k_instance
, FUNC_NAME
);
483 while (!SCM_EQ_P (allocation
, k_instance
))
485 slots
= SCM_CDR (slots
);
486 len
= scm_ilength (SCM_CDAR (slots
));
487 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
488 len
, k_instance
, FUNC_NAME
);
490 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
491 len
, SCM_BOOL_F
, FUNC_NAME
);
492 if (SCM_FALSEP (type
))
499 if (!SCM_CLASSP (type
))
500 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
501 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
503 if (SCM_SUBCLASSP (type
, scm_class_self
))
505 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
510 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
512 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
525 slots
= SCM_CDR (slots
);
527 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
530 return SCM_UNSPECIFIED
;
534 static void prep_hashsets (SCM
);
536 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
537 (SCM
class, SCM dsupers
),
539 #define FUNC_NAME s_scm_sys_inherit_magic_x
543 SCM_VALIDATE_INSTANCE (1, class);
544 while (!SCM_NULLP (ls
))
546 SCM_ASSERT (SCM_CONSP (ls
)
547 && SCM_INSTANCEP (SCM_CAR (ls
)),
551 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
554 flags
&= SCM_CLASSF_INHERIT
;
555 if (flags
& SCM_CLASSF_ENTITY
)
556 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
559 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
562 * We could avoid calling scm_gc_malloc in the allocation code
563 * (in which case the following two lines are needed). Instead
564 * we make 0-slot instances non-light, so that the light case
565 * can be handled without special cases.
568 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
570 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
572 /* NOTE: The following depends on scm_struct_i_size. */
573 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
574 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
577 SCM_SET_CLASS_FLAGS (class, flags
);
579 prep_hashsets (class);
581 return SCM_UNSPECIFIED
;
586 prep_hashsets (SCM
class)
590 for (i
= 0; i
< 7; ++i
)
591 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
594 /******************************************************************************/
597 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
599 SCM z
, cpl
, slots
, nfields
, g_n_s
;
601 /* Allocate one instance */
602 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
604 /* Initialize its slots */
605 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
606 cpl
= compute_cpl (z
);
607 slots
= build_slots_list (maplist (dslots
), cpl
);
608 nfields
= SCM_MAKINUM (scm_ilength (slots
));
609 g_n_s
= compute_getters_n_setters (slots
);
611 SCM_SET_SLOT (z
, scm_si_name
, name
);
612 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
613 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
614 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
615 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
616 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
617 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
618 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
619 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
620 SCM_SET_SLOT (z
, scm_si_environment
,
621 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
623 /* Add this class in the direct-subclasses slot of dsupers */
626 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
627 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
628 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
629 scm_si_direct_subclasses
)));
632 /* Support for the underlying structs: */
633 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
634 ? (SCM_CLASSF_GOOPS_OR_VALID
635 | SCM_CLASSF_OPERATOR
637 : class == scm_class_operator_class
638 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
639 : SCM_CLASSF_GOOPS_OR_VALID
));
644 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
646 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
647 scm_sys_inherit_magic_x (z
, dsupers
);
648 scm_sys_prep_layout_x (z
);
652 /******************************************************************************/
654 SCM_SYMBOL (sym_layout
, "layout");
655 SCM_SYMBOL (sym_vcell
, "vcell");
656 SCM_SYMBOL (sym_vtable
, "vtable");
657 SCM_SYMBOL (sym_print
, "print");
658 SCM_SYMBOL (sym_procedure
, "procedure");
659 SCM_SYMBOL (sym_setter
, "setter");
660 SCM_SYMBOL (sym_redefined
, "redefined");
661 SCM_SYMBOL (sym_h0
, "h0");
662 SCM_SYMBOL (sym_h1
, "h1");
663 SCM_SYMBOL (sym_h2
, "h2");
664 SCM_SYMBOL (sym_h3
, "h3");
665 SCM_SYMBOL (sym_h4
, "h4");
666 SCM_SYMBOL (sym_h5
, "h5");
667 SCM_SYMBOL (sym_h6
, "h6");
668 SCM_SYMBOL (sym_h7
, "h7");
669 SCM_SYMBOL (sym_name
, "name");
670 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
671 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
672 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
673 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
674 SCM_SYMBOL (sym_cpl
, "cpl");
675 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
676 SCM_SYMBOL (sym_slots
, "slots");
677 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
678 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
679 SCM_SYMBOL (sym_nfields
, "nfields");
680 SCM_SYMBOL (sym_environment
, "environment");
684 build_class_class_slots ()
687 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
688 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
689 scm_list_1 (sym_print
),
690 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
691 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
692 scm_list_1 (sym_redefined
),
693 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
694 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
695 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
696 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
697 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
698 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
699 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
700 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
701 scm_list_1 (sym_name
),
702 scm_list_1 (sym_direct_supers
),
703 scm_list_1 (sym_direct_slots
),
704 scm_list_1 (sym_direct_subclasses
),
705 scm_list_1 (sym_direct_methods
),
706 scm_list_1 (sym_cpl
),
707 scm_list_1 (sym_default_slot_definition_class
),
708 scm_list_1 (sym_slots
),
709 scm_list_1 (sym_getters_n_setters
),
710 scm_list_1 (sym_keyword_access
),
711 scm_list_1 (sym_nfields
),
712 scm_list_1 (sym_environment
),
717 create_basic_classes (void)
719 /* SCM slots_of_class = build_class_class_slots (); */
721 /**** <scm_class_class> ****/
722 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
723 + 2 * scm_vtable_offset_user
);
724 SCM name
= scm_str2symbol ("<class>");
725 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
728 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
729 | SCM_CLASSF_METACLASS
));
731 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
732 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
733 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
734 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
735 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
736 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
737 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
738 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
739 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
740 compute_getters_n_setters (slots_of_class)); */
741 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
742 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
743 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
745 prep_hashsets (scm_class_class
);
747 DEFVAR(name
, scm_class_class
);
749 /**** <scm_class_top> ****/
750 name
= scm_str2symbol ("<top>");
751 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
756 DEFVAR(name
, scm_class_top
);
758 /**** <scm_class_object> ****/
759 name
= scm_str2symbol ("<object>");
760 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
762 scm_list_1 (scm_class_top
),
765 DEFVAR (name
, scm_class_object
);
767 /* <top> <object> and <class> were partially initialized. Correct them here */
768 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
770 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
771 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
774 /******************************************************************************/
776 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
778 "Return @code{#t} if @var{obj} is an instance.")
779 #define FUNC_NAME s_scm_instance_p
781 return SCM_BOOL (SCM_INSTANCEP (obj
));
786 /******************************************************************************
788 * Meta object accessors
790 ******************************************************************************/
791 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
793 "Return the class name of @var{obj}.")
794 #define FUNC_NAME s_scm_class_name
796 SCM_VALIDATE_CLASS (1, obj
);
797 return scm_slot_ref (obj
, sym_name
);
801 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
803 "Return the direct superclasses of the class @var{obj}.")
804 #define FUNC_NAME s_scm_class_direct_supers
806 SCM_VALIDATE_CLASS (1, obj
);
807 return scm_slot_ref (obj
, sym_direct_supers
);
811 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
813 "Return the direct slots of the class @var{obj}.")
814 #define FUNC_NAME s_scm_class_direct_slots
816 SCM_VALIDATE_CLASS (1, obj
);
817 return scm_slot_ref (obj
, sym_direct_slots
);
821 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
823 "Return the direct subclasses of the class @var{obj}.")
824 #define FUNC_NAME s_scm_class_direct_subclasses
826 SCM_VALIDATE_CLASS (1, obj
);
827 return scm_slot_ref(obj
, sym_direct_subclasses
);
831 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
833 "Return the direct methods of the class @var{obj}")
834 #define FUNC_NAME s_scm_class_direct_methods
836 SCM_VALIDATE_CLASS (1, obj
);
837 return scm_slot_ref (obj
, sym_direct_methods
);
841 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
843 "Return the class precedence list of the class @var{obj}.")
844 #define FUNC_NAME s_scm_class_precedence_list
846 SCM_VALIDATE_CLASS (1, obj
);
847 return scm_slot_ref (obj
, sym_cpl
);
851 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
853 "Return the slot list of the class @var{obj}.")
854 #define FUNC_NAME s_scm_class_slots
856 SCM_VALIDATE_CLASS (1, obj
);
857 return scm_slot_ref (obj
, sym_slots
);
861 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
863 "Return the environment of the class @var{obj}.")
864 #define FUNC_NAME s_scm_class_environment
866 SCM_VALIDATE_CLASS (1, obj
);
867 return scm_slot_ref(obj
, sym_environment
);
872 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
874 "Return the name of the generic function @var{obj}.")
875 #define FUNC_NAME s_scm_generic_function_name
877 SCM_VALIDATE_GENERIC (1, obj
);
878 return scm_procedure_property (obj
, scm_sym_name
);
882 SCM_SYMBOL (sym_methods
, "methods");
883 SCM_SYMBOL (sym_extended_by
, "extended-by");
884 SCM_SYMBOL (sym_extends
, "extends");
887 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
889 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
890 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
891 while (!SCM_NULLP (gfs
))
893 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
900 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
902 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
904 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
905 while (!SCM_NULLP (gfs
))
907 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
908 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
917 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
919 "Return the methods of the generic function @var{obj}.")
920 #define FUNC_NAME s_scm_generic_function_methods
923 SCM_VALIDATE_GENERIC (1, obj
);
924 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
925 methods
= fold_downward_gf_methods (methods
, obj
);
926 return scm_append (methods
);
930 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
932 "Return the generic function for the method @var{obj}.")
933 #define FUNC_NAME s_scm_method_generic_function
935 SCM_VALIDATE_METHOD (1, obj
);
936 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
940 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
942 "Return specializers of the method @var{obj}.")
943 #define FUNC_NAME s_scm_method_specializers
945 SCM_VALIDATE_METHOD (1, obj
);
946 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
950 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
952 "Return the procedure of the method @var{obj}.")
953 #define FUNC_NAME s_scm_method_procedure
955 SCM_VALIDATE_METHOD (1, obj
);
956 return scm_slot_ref (obj
, sym_procedure
);
960 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
962 "Return the slot definition of the accessor @var{obj}.")
963 #define FUNC_NAME s_scm_accessor_method_slot_definition
965 SCM_VALIDATE_ACCESSOR (1, obj
);
966 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
970 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
972 "Internal GOOPS magic---don't use this function!")
973 #define FUNC_NAME s_scm_sys_tag_body
975 return scm_cons (SCM_IM_LAMBDA
, body
);
979 /******************************************************************************
981 * S l o t a c c e s s
983 ******************************************************************************/
985 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
987 "Return the unbound value.")
988 #define FUNC_NAME s_scm_make_unbound
990 return SCM_GOOPS_UNBOUND
;
994 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
996 "Return @code{#t} if @var{obj} is unbound.")
997 #define FUNC_NAME s_scm_unbound_p
999 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1003 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1004 (SCM value
, SCM obj
),
1005 "Return @var{value} if it is bound, and invoke the\n"
1006 "@var{slot-unbound} method of @var{obj} if it is not.")
1007 #define FUNC_NAME s_scm_assert_bound
1009 if (SCM_GOOPS_UNBOUNDP (value
))
1010 return CALL_GF1 ("slot-unbound", obj
);
1015 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1016 (SCM obj
, SCM index
),
1017 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1018 "the value from @var{obj}.")
1019 #define FUNC_NAME s_scm_at_assert_bound_ref
1021 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1022 if (SCM_GOOPS_UNBOUNDP (value
))
1023 return CALL_GF1 ("slot-unbound", obj
);
1028 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1029 (SCM obj
, SCM index
),
1030 "Return the slot value with index @var{index} from @var{obj}.")
1031 #define FUNC_NAME s_scm_sys_fast_slot_ref
1033 unsigned long int i
;
1035 SCM_VALIDATE_INSTANCE (1, obj
);
1036 SCM_VALIDATE_INUM (2, index
);
1037 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1038 i
= SCM_INUM (index
);
1039 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1041 return scm_at_assert_bound_ref (obj
, index
);
1045 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1046 (SCM obj
, SCM index
, SCM value
),
1047 "Set the slot with index @var{index} in @var{obj} to\n"
1049 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1051 unsigned long int i
;
1053 SCM_VALIDATE_INSTANCE (1, obj
);
1054 SCM_VALIDATE_INUM (2, index
);
1055 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1056 i
= SCM_INUM (index
);
1057 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1059 SCM_SET_SLOT (obj
, i
, value
);
1061 return SCM_UNSPECIFIED
;
1068 /* In the future, this function will return the effective slot
1069 * definition associated with SLOT_NAME. Now it just returns some of
1070 * the information which will be stored in the effective slot
1075 slot_definition_using_name (SCM
class, SCM slot_name
)
1077 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1078 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1079 if (SCM_CAAR (slots
) == slot_name
)
1080 return SCM_CAR (slots
);
1085 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1087 SCM access
= SCM_CDDR (slotdef
);
1089 * - access is an integer (the offset of this slot in the slots vector)
1090 * - otherwise (car access) is the getter function to apply
1092 if (SCM_INUMP (access
))
1093 return SCM_SLOT (obj
, SCM_INUM (access
));
1096 /* We must evaluate (apply (car access) (list obj))
1097 * where (car access) is known to be a closure of arity 1 */
1098 register SCM code
, env
;
1100 code
= SCM_CAR (access
);
1101 if (!SCM_CLOSUREP (code
))
1102 return SCM_SUBRF (code
) (obj
);
1103 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1106 /* Evaluate the closure body */
1107 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1112 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1114 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1115 if (!SCM_FALSEP (slotdef
))
1116 return get_slot_value (class, obj
, slotdef
);
1118 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1122 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1124 SCM access
= SCM_CDDR (slotdef
);
1126 * - access is an integer (the offset of this slot in the slots vector)
1127 * - otherwise (cadr access) is the setter function to apply
1129 if (SCM_INUMP (access
))
1130 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1133 /* We must evaluate (apply (cadr l) (list obj value))
1134 * where (cadr l) is known to be a closure of arity 2 */
1135 register SCM code
, env
;
1137 code
= SCM_CADR (access
);
1138 if (!SCM_CLOSUREP (code
))
1139 SCM_SUBRF (code
) (obj
, value
);
1142 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1143 scm_list_2 (obj
, value
),
1145 /* Evaluate the closure body */
1146 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1149 return SCM_UNSPECIFIED
;
1153 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1155 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1156 if (!SCM_FALSEP (slotdef
))
1157 return set_slot_value (class, obj
, slotdef
, value
);
1159 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1163 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1167 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1168 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1174 /* ======================================== */
1176 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1177 (SCM
class, SCM obj
, SCM slot_name
),
1179 #define FUNC_NAME s_scm_slot_ref_using_class
1183 SCM_VALIDATE_CLASS (1, class);
1184 SCM_VALIDATE_INSTANCE (2, obj
);
1185 SCM_VALIDATE_SYMBOL (3, slot_name
);
1187 res
= get_slot_value_using_name (class, obj
, slot_name
);
1188 if (SCM_GOOPS_UNBOUNDP (res
))
1189 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1195 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1196 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1198 #define FUNC_NAME s_scm_slot_set_using_class_x
1200 SCM_VALIDATE_CLASS (1, class);
1201 SCM_VALIDATE_INSTANCE (2, obj
);
1202 SCM_VALIDATE_SYMBOL (3, slot_name
);
1204 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1209 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1210 (SCM
class, SCM obj
, SCM slot_name
),
1212 #define FUNC_NAME s_scm_slot_bound_using_class_p
1214 SCM_VALIDATE_CLASS (1, class);
1215 SCM_VALIDATE_INSTANCE (2, obj
);
1216 SCM_VALIDATE_SYMBOL (3, slot_name
);
1218 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1224 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1225 (SCM
class, SCM obj
, SCM slot_name
),
1227 #define FUNC_NAME s_scm_slot_exists_using_class_p
1229 SCM_VALIDATE_CLASS (1, class);
1230 SCM_VALIDATE_INSTANCE (2, obj
);
1231 SCM_VALIDATE_SYMBOL (3, slot_name
);
1232 return test_slot_existence (class, obj
, slot_name
);
1237 /* ======================================== */
1239 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1240 (SCM obj
, SCM slot_name
),
1241 "Return the value from @var{obj}'s slot with the name\n"
1243 #define FUNC_NAME s_scm_slot_ref
1247 SCM_VALIDATE_INSTANCE (1, obj
);
1248 TEST_CHANGE_CLASS (obj
, class);
1250 res
= get_slot_value_using_name (class, obj
, slot_name
);
1251 if (SCM_GOOPS_UNBOUNDP (res
))
1252 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1257 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1258 (SCM obj
, SCM slot_name
, SCM value
),
1259 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1260 #define FUNC_NAME s_scm_slot_set_x
1264 SCM_VALIDATE_INSTANCE (1, obj
);
1265 TEST_CHANGE_CLASS(obj
, class);
1267 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1271 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1273 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1274 (SCM obj
, SCM slot_name
),
1275 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1277 #define FUNC_NAME s_scm_slot_bound_p
1281 SCM_VALIDATE_INSTANCE (1, obj
);
1282 TEST_CHANGE_CLASS(obj
, class);
1284 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1292 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1293 (SCM obj
, SCM slot_name
),
1294 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1295 #define FUNC_NAME s_scm_slot_exists_p
1299 SCM_VALIDATE_INSTANCE (1, obj
);
1300 SCM_VALIDATE_SYMBOL (2, slot_name
);
1301 TEST_CHANGE_CLASS (obj
, class);
1303 return test_slot_existence (class, obj
, slot_name
);
1308 /******************************************************************************
1310 * %allocate-instance (the low level instance allocation primitive)
1312 ******************************************************************************/
1314 static void clear_method_cache (SCM
);
1317 wrap_init (SCM
class, SCM
*m
, long n
)
1321 /* Set all slots to unbound */
1322 for (i
= 0; i
< n
; i
++)
1323 m
[i
] = SCM_GOOPS_UNBOUND
;
1325 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1327 (scm_t_bits
) m
, 0, 0);
1330 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1331 (SCM
class, SCM initargs
),
1332 "Create a new instance of class @var{class} and initialize it\n"
1333 "from the arguments @var{initargs}.")
1334 #define FUNC_NAME s_scm_sys_allocate_instance
1339 SCM_VALIDATE_CLASS (1, class);
1341 /* Most instances */
1342 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1344 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1345 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1346 return wrap_init (class, m
, n
);
1349 /* Foreign objects */
1350 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1351 return scm_make_foreign_object (class, initargs
);
1353 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1356 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1358 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1360 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1361 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1362 /* Generic functions */
1363 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1365 SCM gf
= wrap_init (class, m
, n
);
1366 clear_method_cache (gf
);
1370 return wrap_init (class, m
, n
);
1374 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1378 /* allocate class object */
1379 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1381 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1382 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1383 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1385 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1386 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1387 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1388 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1393 /* Non-light instances */
1395 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1396 return wrap_init (class, m
, n
);
1401 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1402 (SCM obj
, SCM setter
),
1404 #define FUNC_NAME s_scm_sys_set_object_setter_x
1406 SCM_ASSERT (SCM_STRUCTP (obj
)
1407 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1408 || SCM_I_ENTITYP (obj
)),
1412 if (SCM_I_ENTITYP (obj
))
1413 SCM_SET_ENTITY_SETTER (obj
, setter
);
1415 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1416 return SCM_UNSPECIFIED
;
1420 /******************************************************************************
1422 * %modify-instance (used by change-class to modify in place)
1424 ******************************************************************************/
1426 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1429 #define FUNC_NAME s_scm_sys_modify_instance
1431 SCM_VALIDATE_INSTANCE (1, old
);
1432 SCM_VALIDATE_INSTANCE (2, new);
1434 /* Exchange the data contained in old and new. We exchange rather than
1435 * scratch the old value with new to be correct with GC.
1436 * See "Class redefinition protocol above".
1440 SCM car
= SCM_CAR (old
);
1441 SCM cdr
= SCM_CDR (old
);
1442 SCM_SETCAR (old
, SCM_CAR (new));
1443 SCM_SETCDR (old
, SCM_CDR (new));
1444 SCM_SETCAR (new, car
);
1445 SCM_SETCDR (new, cdr
);
1448 return SCM_UNSPECIFIED
;
1452 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1455 #define FUNC_NAME s_scm_sys_modify_class
1457 SCM_VALIDATE_CLASS (1, old
);
1458 SCM_VALIDATE_CLASS (2, new);
1462 SCM car
= SCM_CAR (old
);
1463 SCM cdr
= SCM_CDR (old
);
1464 SCM_SETCAR (old
, SCM_CAR (new));
1465 SCM_SETCDR (old
, SCM_CDR (new));
1466 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1467 SCM_SETCAR (new, car
);
1468 SCM_SETCDR (new, cdr
);
1469 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1472 return SCM_UNSPECIFIED
;
1476 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1479 #define FUNC_NAME s_scm_sys_invalidate_class
1481 SCM_VALIDATE_CLASS (1, class);
1482 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1483 return SCM_UNSPECIFIED
;
1487 /* When instances change class, they finally get a new body, but
1488 * before that, they go through purgatory in hell. Odd as it may
1489 * seem, this data structure saves us from eternal suffering in
1490 * infinite recursions.
1493 static scm_t_bits
**hell
;
1494 static long n_hell
= 1; /* one place for the evil one himself */
1495 static long hell_size
= 4;
1496 static SCM hell_mutex
;
1502 for (i
= 1; i
< n_hell
; ++i
)
1503 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1509 go_to_hell (void *o
)
1511 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1512 scm_lock_mutex (hell_mutex
);
1513 if (n_hell
== hell_size
)
1515 long new_size
= 2 * hell_size
;
1516 hell
= scm_realloc (hell
, new_size
);
1517 hell_size
= new_size
;
1519 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1520 scm_unlock_mutex (hell_mutex
);
1524 go_to_heaven (void *o
)
1526 scm_lock_mutex (hell_mutex
);
1527 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1528 scm_unlock_mutex (hell_mutex
);
1532 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1535 purgatory (void *args
)
1537 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1538 SCM_PACK ((scm_t_bits
) args
));
1541 /* This function calls the generic function change-class for all
1542 * instances which aren't currently undergoing class change.
1546 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1549 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1550 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1551 (void *) SCM_UNPACK (obj
));
1554 /******************************************************************************
1560 * GGG E N E R I C F U N C T I O N S
1562 * This implementation provides
1563 * - generic functions (with class specializers)
1566 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1568 ******************************************************************************/
1570 SCM_KEYWORD (k_name
, "name");
1572 SCM_SYMBOL (sym_no_method
, "no-method");
1574 static SCM list_of_no_method
;
1576 SCM_SYMBOL (scm_sym_args
, "args");
1579 scm_make_method_cache (SCM gf
)
1581 return scm_list_5 (SCM_IM_DISPATCH
,
1584 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1590 clear_method_cache (SCM gf
)
1592 SCM cache
= scm_make_method_cache (gf
);
1593 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1594 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1597 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1600 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1603 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1604 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1605 if (!SCM_FALSEP (used_by
))
1607 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1608 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1609 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1610 clear_method_cache (gf
);
1611 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1612 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1615 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1616 /* The sign of n is a flag indicating rest args. */
1617 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1619 return SCM_UNSPECIFIED
;
1623 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1626 #define FUNC_NAME s_scm_generic_capability_p
1628 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1629 proc
, SCM_ARG1
, FUNC_NAME
);
1630 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1636 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1639 #define FUNC_NAME s_scm_enable_primitive_generic_x
1641 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1642 while (!SCM_NULLP (subrs
))
1644 SCM subr
= SCM_CAR (subrs
);
1645 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1646 subr
, SCM_ARGn
, FUNC_NAME
);
1647 *SCM_SUBR_GENERIC (subr
)
1648 = scm_make (scm_list_3 (scm_class_generic
,
1651 subrs
= SCM_CDR (subrs
);
1653 return SCM_UNSPECIFIED
;
1657 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1660 #define FUNC_NAME s_scm_primitive_generic_generic
1662 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1664 if (!*SCM_SUBR_GENERIC (subr
))
1665 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1666 return *SCM_SUBR_GENERIC (subr
);
1668 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1672 typedef struct t_extension
{
1673 struct t_extension
*next
;
1678 static t_extension
*extensions
= 0;
1680 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1683 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1688 if (!*SCM_SUBR_GENERIC (extended
))
1689 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1690 gf
= *SCM_SUBR_GENERIC (extended
);
1691 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1693 SCM_SNAME (extension
));
1694 *SCM_SUBR_GENERIC (extension
) = gext
;
1698 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1699 t_extension
**loc
= &extensions
;
1700 /* Make sure that extensions are placed before their own
1701 * extensions in the extensions list. O(N^2) algorithm, but
1702 * extensions of primitive generics are rare.
1704 while (*loc
&& extension
!= (*loc
)->extended
)
1705 loc
= &(*loc
)->next
;
1707 e
->extended
= extended
;
1708 e
->extension
= extension
;
1714 setup_extended_primitive_generics ()
1718 t_extension
*e
= extensions
;
1719 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1720 extensions
= e
->next
;
1725 /******************************************************************************
1727 * Protocol for calling a generic fumction
1728 * This protocol is roughly equivalent to (parameter are a little bit different
1729 * for efficiency reasons):
1731 * + apply-generic (gf args)
1732 * + compute-applicable-methods (gf args ...)
1733 * + sort-applicable-methods (methods args)
1734 * + apply-methods (gf methods args)
1736 * apply-methods calls make-next-method to build the "continuation" of a a
1737 * method. Applying a next-method will call apply-next-method which in
1738 * turn will call apply again to call effectively the following method.
1740 ******************************************************************************/
1743 applicablep (SCM actual
, SCM formal
)
1745 /* We already know that the cpl is well formed. */
1746 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1750 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1752 register SCM s1
, s2
;
1756 * m1 and m2 can have != length (i.e. one can be one element longer than the
1757 * other when we have a dotted parameter list). For instance, with the call
1760 * (define-method M (a . l) ....)
1761 * (define-method M (a) ....)
1763 * we consider that the second method is more specific.
1765 * BTW, targs is an array of types. We don't need it's size since
1766 * we already know that m1 and m2 are applicable (no risk to go past
1767 * the end of this array).
1770 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1771 if (SCM_NULLP(s1
)) return 1;
1772 if (SCM_NULLP(s2
)) return 0;
1773 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1774 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1776 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1777 if (cs1
== SCM_CAR(l
))
1779 if (cs2
== SCM_CAR(l
))
1782 return 0;/* should not occur! */
1785 return 0; /* should not occur! */
1788 #define BUFFSIZE 32 /* big enough for most uses */
1791 scm_i_vector2list (SCM l
, long len
)
1794 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1796 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1797 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1803 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1806 SCM
*v
, vector
= SCM_EOL
;
1807 SCM buffer
[BUFFSIZE
];
1808 SCM save
= method_list
;
1810 /* For reasonably sized method_lists we can try to avoid all the
1811 * consing and reorder the list in place...
1812 * This idea is due to David McClain <Dave_McClain@msn.com>
1814 if (size
<= BUFFSIZE
)
1816 for (i
= 0; i
< size
; i
++)
1818 buffer
[i
] = SCM_CAR (method_list
);
1819 method_list
= SCM_CDR (method_list
);
1825 /* Too many elements in method_list to keep everything locally */
1826 vector
= scm_i_vector2list (save
, size
);
1829 This is a new vector. Don't worry about the write barrier.
1830 We're not allocating elements in this routine, so this should
1833 v
= SCM_WRITABLE_VELTS (vector
);
1836 /* Use a simple shell sort since it is generally faster than qsort on
1837 * small vectors (which is probably mostly the case when we have to
1838 * sort a list of applicable methods).
1840 for (incr
= size
/ 2; incr
; incr
/= 2)
1842 for (i
= incr
; i
< size
; i
++)
1844 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1846 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1850 SCM tmp
= v
[j
+ incr
];
1858 if (size
<= BUFFSIZE
)
1860 /* We did it in locally, so restore the original list (reordered) in-place */
1861 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1863 SCM_SETCAR (method_list
, *v
);
1864 method_list
= SCM_CDR (method_list
);
1868 /* If we are here, that's that we did it the hard way... */
1869 return scm_vector_to_list (vector
);
1873 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1877 SCM l
, fl
, applicable
= SCM_EOL
;
1879 SCM buffer
[BUFFSIZE
];
1884 /* Build the list of arguments types */
1885 if (len
>= BUFFSIZE
) {
1886 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1887 /* NOTE: Using pointers to malloced memory won't work if we
1888 1. have preemtive threading, and,
1889 2. have a GC which moves objects. */
1890 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1893 note that we don't have to work to reset the generation
1894 count. TMP is a new vector anyway, and it is found
1901 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1902 *p
++ = scm_class_of (SCM_CAR (args
));
1904 /* Build a list of all applicable methods */
1905 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1907 fl
= SPEC_OF (SCM_CAR (l
));
1908 /* Only accept accessors which match exactly in first arg. */
1909 if (SCM_ACCESSORP (SCM_CAR (l
))
1910 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1912 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1914 if (SCM_INSTANCEP (fl
)
1915 /* We have a dotted argument list */
1916 || (i
>= len
&& SCM_NULLP (fl
)))
1917 { /* both list exhausted */
1918 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1924 || !applicablep (types
[i
], SCM_CAR (fl
)))
1933 CALL_GF2 ("no-applicable-method", gf
, save
);
1934 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1938 scm_remember_upto_here_1 (tmp
);
1941 : sort_applicable_methods (applicable
, count
, types
));
1945 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1948 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1951 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1952 #define FUNC_NAME s_sys_compute_applicable_methods
1955 SCM_VALIDATE_GENERIC (1, gf
);
1956 n
= scm_ilength (args
);
1957 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1958 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1962 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1963 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
));
1965 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1968 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1969 #define FUNC_NAME s_atslot_ref
1971 SCM x
= SCM_CDR (xorig
);
1972 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1973 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1974 return scm_cons (SCM_IM_SLOT_REF
, x
);
1979 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1982 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1983 #define FUNC_NAME s_atslot_set_x
1985 SCM x
= SCM_CDR (xorig
);
1986 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1987 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1988 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1993 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1995 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1998 scm_m_atdispatch (SCM xorig
, SCM env
)
1999 #define FUNC_NAME s_atdispatch
2001 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
2002 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
2004 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
2005 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
2007 n
= SCM_XEVALCAR (x
, env
);
2008 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
2009 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
2011 v
= SCM_XEVALCAR (x
, env
);
2012 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
2014 gf
= SCM_XEVALCAR (x
, env
);
2015 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
2016 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
2022 lock_cache_mutex (void *m
)
2024 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2025 scm_lock_mutex (mutex
);
2029 unlock_cache_mutex (void *m
)
2031 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2032 scm_unlock_mutex (mutex
);
2036 call_memoize_method (void *a
)
2038 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2039 SCM gf
= SCM_CAR (args
);
2040 SCM x
= SCM_CADR (args
);
2041 /* First check if another thread has inserted a method between
2042 * the cache miss and locking the mutex.
2044 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2045 if (!SCM_FALSEP (cmethod
))
2047 /*fixme* Use scm_apply */
2048 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2052 scm_memoize_method (SCM x
, SCM args
)
2054 SCM gf
= SCM_CAR (scm_last_pair (x
));
2055 return scm_internal_dynamic_wind (
2057 call_memoize_method
,
2059 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2060 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2063 /******************************************************************************
2065 * A simple make (which will be redefined later in Scheme)
2066 * This version handles only creation of gf, methods and classes (no instances)
2068 * Since this code will disappear when Goops will be fully booted,
2069 * no precaution is taken to be efficient.
2071 ******************************************************************************/
2073 SCM_KEYWORD (k_setter
, "setter");
2074 SCM_KEYWORD (k_specializers
, "specializers");
2075 SCM_KEYWORD (k_procedure
, "procedure");
2076 SCM_KEYWORD (k_dsupers
, "dsupers");
2077 SCM_KEYWORD (k_slots
, "slots");
2078 SCM_KEYWORD (k_gf
, "generic-function");
2080 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2082 "Make a new object. @var{args} must contain the class and\n"
2083 "all necessary initialization information.")
2084 #define FUNC_NAME s_scm_make
2087 long len
= scm_ilength (args
);
2089 if (len
<= 0 || (len
& 1) == 0)
2090 SCM_WRONG_NUM_ARGS ();
2092 class = SCM_CAR(args
);
2093 args
= SCM_CDR(args
);
2095 if (class == scm_class_generic
|| class == scm_class_accessor
)
2097 z
= scm_make_struct (class, SCM_INUM0
,
2098 scm_list_5 (SCM_EOL
,
2103 scm_set_procedure_property_x (z
, scm_sym_name
,
2104 scm_get_keyword (k_name
,
2107 clear_method_cache (z
);
2108 if (class == scm_class_accessor
)
2110 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2111 if (!SCM_FALSEP (setter
))
2112 scm_sys_set_object_setter_x (z
, setter
);
2117 z
= scm_sys_allocate_instance (class, args
);
2119 if (class == scm_class_method
2120 || class == scm_class_simple_method
2121 || class == scm_class_accessor_method
)
2123 SCM_SET_SLOT (z
, scm_si_generic_function
,
2124 scm_i_get_keyword (k_gf
,
2129 SCM_SET_SLOT (z
, scm_si_specializers
,
2130 scm_i_get_keyword (k_specializers
,
2135 SCM_SET_SLOT (z
, scm_si_procedure
,
2136 scm_i_get_keyword (k_procedure
,
2141 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2145 /* In all the others case, make a new class .... No instance here */
2146 SCM_SET_SLOT (z
, scm_si_name
,
2147 scm_i_get_keyword (k_name
,
2150 scm_str2symbol ("???"),
2152 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2153 scm_i_get_keyword (k_dsupers
,
2158 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2159 scm_i_get_keyword (k_slots
,
2170 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2173 #define FUNC_NAME s_scm_find_method
2176 long len
= scm_ilength (l
);
2179 SCM_WRONG_NUM_ARGS ();
2181 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2182 SCM_VALIDATE_GENERIC (1, gf
);
2183 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2184 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2186 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2190 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2191 (SCM m1
, SCM m2
, SCM targs
),
2193 #define FUNC_NAME s_scm_sys_method_more_specific_p
2198 SCM_VALIDATE_METHOD (1, m1
);
2199 SCM_VALIDATE_METHOD (2, m2
);
2200 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2202 /* Verify that all the arguments of targs are classes and place them in a vector*/
2203 v
= scm_c_make_vector (len
, SCM_EOL
);
2205 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2206 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2207 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2209 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2215 /******************************************************************************
2219 ******************************************************************************/
2222 fix_cpl (SCM c
, SCM before
, SCM after
)
2224 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2225 SCM ls
= scm_c_memq (after
, cpl
);
2226 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2227 if (SCM_FALSEP (ls
))
2228 /* if this condition occurs, fix_cpl should not be applied this way */
2230 SCM_SETCAR (ls
, before
);
2231 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2233 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2234 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2235 SCM g_n_s
= compute_getters_n_setters (slots
);
2236 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2237 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2243 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2245 SCM tmp
= scm_str2symbol (name
);
2247 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2251 : scm_list_1 (super
),
2257 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2260 create_standard_classes (void)
2263 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2264 scm_str2symbol ("specializers"),
2266 scm_str2symbol ("code-table"));
2267 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2269 k_slot_definition
));
2270 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2271 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2272 scm_list_3 (scm_str2symbol ("n-specialized"),
2275 scm_list_3 (scm_str2symbol ("used-by"),
2278 scm_list_3 (scm_str2symbol ("cache-mutex"),
2280 scm_closure (scm_list_2 (SCM_EOL
,
2283 scm_list_3 (scm_str2symbol ("extended-by"),
2286 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2289 /* Foreign class slot classes */
2290 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2291 scm_class_class
, scm_class_top
, SCM_EOL
);
2292 make_stdcls (&scm_class_protected
, "<protected-slot>",
2293 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2294 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2295 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2296 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2297 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2298 make_stdcls (&scm_class_self
, "<self-slot>",
2300 scm_class_read_only
,
2302 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2304 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2306 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2308 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2310 make_stdcls (&scm_class_scm
, "<scm-slot>",
2311 scm_class_class
, scm_class_protected
, SCM_EOL
);
2312 make_stdcls (&scm_class_int
, "<int-slot>",
2313 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2314 make_stdcls (&scm_class_float
, "<float-slot>",
2315 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2316 make_stdcls (&scm_class_double
, "<double-slot>",
2317 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2319 /* Continue initialization of class <class> */
2321 slots
= build_class_class_slots ();
2322 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2323 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2324 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2325 compute_getters_n_setters (slots
));
2327 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2328 scm_class_class
, scm_class_class
,
2329 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2332 scm_list_3 (scm_str2symbol ("destructor"),
2334 scm_class_opaque
)));
2335 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2336 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2337 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2339 /* scm_class_generic functions classes */
2340 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2341 scm_class_class
, scm_class_class
, SCM_EOL
);
2342 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2343 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2344 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2345 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2346 make_stdcls (&scm_class_operator_with_setter_class
,
2347 "<operator-with-setter-class>",
2348 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2349 make_stdcls (&scm_class_method
, "<method>",
2350 scm_class_class
, scm_class_object
, method_slots
);
2351 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2352 scm_class_class
, scm_class_method
, SCM_EOL
);
2353 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2354 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2355 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2356 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2357 make_stdcls (&scm_class_applicable
, "<applicable>",
2358 scm_class_class
, scm_class_top
, SCM_EOL
);
2359 make_stdcls (&scm_class_entity
, "<entity>",
2360 scm_class_entity_class
,
2361 scm_list_2 (scm_class_object
, scm_class_applicable
),
2363 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2364 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2365 make_stdcls (&scm_class_generic
, "<generic>",
2366 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2367 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2368 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2369 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2370 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2371 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2372 scm_class_entity_class
,
2373 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2375 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2376 make_stdcls (&scm_class_accessor
, "<accessor>",
2377 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2378 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2379 make_stdcls (&scm_class_extended_generic_with_setter
,
2380 "<extended-generic-with-setter>",
2381 scm_class_entity_class
,
2382 scm_list_2 (scm_class_generic_with_setter
,
2383 scm_class_extended_generic
),
2385 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2386 SCM_CLASSF_PURE_GENERIC
);
2387 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2388 scm_class_entity_class
,
2389 scm_list_2 (scm_class_accessor
,
2390 scm_class_extended_generic_with_setter
),
2392 fix_cpl (scm_class_extended_accessor
,
2393 scm_class_extended_generic
, scm_class_generic
);
2394 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2396 /* Primitive types classes */
2397 make_stdcls (&scm_class_boolean
, "<boolean>",
2398 scm_class_class
, scm_class_top
, SCM_EOL
);
2399 make_stdcls (&scm_class_char
, "<char>",
2400 scm_class_class
, scm_class_top
, SCM_EOL
);
2401 make_stdcls (&scm_class_list
, "<list>",
2402 scm_class_class
, scm_class_top
, SCM_EOL
);
2403 make_stdcls (&scm_class_pair
, "<pair>",
2404 scm_class_class
, scm_class_list
, SCM_EOL
);
2405 make_stdcls (&scm_class_null
, "<null>",
2406 scm_class_class
, scm_class_list
, SCM_EOL
);
2407 make_stdcls (&scm_class_string
, "<string>",
2408 scm_class_class
, scm_class_top
, SCM_EOL
);
2409 make_stdcls (&scm_class_symbol
, "<symbol>",
2410 scm_class_class
, scm_class_top
, SCM_EOL
);
2411 make_stdcls (&scm_class_vector
, "<vector>",
2412 scm_class_class
, scm_class_top
, SCM_EOL
);
2413 make_stdcls (&scm_class_number
, "<number>",
2414 scm_class_class
, scm_class_top
, SCM_EOL
);
2415 make_stdcls (&scm_class_complex
, "<complex>",
2416 scm_class_class
, scm_class_number
, SCM_EOL
);
2417 make_stdcls (&scm_class_real
, "<real>",
2418 scm_class_class
, scm_class_complex
, SCM_EOL
);
2419 make_stdcls (&scm_class_integer
, "<integer>",
2420 scm_class_class
, scm_class_real
, SCM_EOL
);
2421 make_stdcls (&scm_class_keyword
, "<keyword>",
2422 scm_class_class
, scm_class_top
, SCM_EOL
);
2423 make_stdcls (&scm_class_unknown
, "<unknown>",
2424 scm_class_class
, scm_class_top
, SCM_EOL
);
2425 make_stdcls (&scm_class_procedure
, "<procedure>",
2426 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2427 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2428 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2429 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2430 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2431 make_stdcls (&scm_class_port
, "<port>",
2432 scm_class_class
, scm_class_top
, SCM_EOL
);
2433 make_stdcls (&scm_class_input_port
, "<input-port>",
2434 scm_class_class
, scm_class_port
, SCM_EOL
);
2435 make_stdcls (&scm_class_output_port
, "<output-port>",
2436 scm_class_class
, scm_class_port
, SCM_EOL
);
2437 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2439 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2443 /**********************************************************************
2447 **********************************************************************/
2450 make_class_from_template (char *template, char *type_name
, SCM supers
, int applicablep
)
2456 sprintf (buffer
, template, type_name
);
2457 name
= scm_str2symbol (buffer
);
2460 name
= SCM_GOOPS_UNBOUND
;
2462 class = scm_permanent_object (scm_basic_make_class (applicablep
2463 ? scm_class_procedure_class
2469 /* Only define name if doesn't already exist. */
2470 if (!SCM_GOOPS_UNBOUNDP (name
)
2471 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2472 DEFVAR (name
, class);
2477 scm_make_extended_class (char *type_name
, int applicablep
)
2479 return make_class_from_template ("<%s>",
2481 scm_list_1 (applicablep
2482 ? scm_class_applicable
2488 scm_i_inherit_applicable (SCM c
)
2490 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2492 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2493 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2494 /* patch scm_class_applicable into direct-supers */
2495 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2496 if (SCM_FALSEP (top
))
2497 dsupers
= scm_append (scm_list_2 (dsupers
,
2498 scm_list_1 (scm_class_applicable
)));
2501 SCM_SETCAR (top
, scm_class_applicable
);
2502 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2504 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2505 /* patch scm_class_applicable into cpl */
2506 top
= scm_c_memq (scm_class_top
, cpl
);
2507 if (SCM_FALSEP (top
))
2511 SCM_SETCAR (top
, scm_class_applicable
);
2512 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2514 /* add class to direct-subclasses of scm_class_applicable */
2515 SCM_SET_SLOT (scm_class_applicable
,
2516 scm_si_direct_subclasses
,
2517 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2518 scm_si_direct_subclasses
)));
2523 create_smob_classes (void)
2527 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2528 for (i
= 0; i
< 255; ++i
)
2529 scm_smob_class
[i
] = 0;
2531 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2532 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2533 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2534 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2536 for (i
= 0; i
< scm_numsmob
; ++i
)
2537 if (!scm_smob_class
[i
])
2538 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2539 scm_smobs
[i
].apply
!= 0);
2543 scm_make_port_classes (long ptobnum
, char *type_name
)
2545 SCM c
, class = make_class_from_template ("<%s-port>",
2547 scm_list_1 (scm_class_port
),
2549 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2550 = make_class_from_template ("<%s-input-port>",
2552 scm_list_2 (class, scm_class_input_port
),
2554 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2555 = make_class_from_template ("<%s-output-port>",
2557 scm_list_2 (class, scm_class_output_port
),
2559 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2561 = make_class_from_template ("<%s-input-output-port>",
2563 scm_list_2 (class, scm_class_input_output_port
),
2565 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2566 SCM_SET_SLOT (c
, scm_si_cpl
,
2567 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2571 create_port_classes (void)
2575 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2576 for (i
= 0; i
< 3 * 256; ++i
)
2577 scm_port_class
[i
] = 0;
2579 for (i
= 0; i
< scm_numptob
; ++i
)
2580 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2584 make_struct_class (void *closure SCM_UNUSED
,
2585 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2587 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2588 SCM_SET_STRUCT_TABLE_CLASS (data
,
2589 scm_make_extended_class
2590 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
)),
2591 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2592 return SCM_UNSPECIFIED
;
2596 create_struct_classes (void)
2598 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2601 /**********************************************************************
2605 **********************************************************************/
2610 if (!goops_loaded_p
)
2611 scm_c_resolve_module ("oop goops");
2616 scm_make_foreign_object (SCM
class, SCM initargs
)
2617 #define FUNC_NAME s_scm_make
2619 void * (*constructor
) (SCM
)
2620 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2621 if (constructor
== 0)
2622 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2623 return scm_wrap_object (class, constructor (initargs
));
2629 scm_free_foreign_object (SCM
*class, SCM
*data
)
2631 size_t (*destructor
) (void *)
2632 = (size_t (*) (void *)) class[scm_si_destructor
];
2633 return destructor (data
);
2637 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2638 void * (*constructor
) (SCM initargs
),
2639 size_t (*destructor
) (void *))
2642 name
= scm_str2symbol (s_name
);
2643 if (SCM_NULLP (supers
))
2644 supers
= scm_list_1 (scm_class_foreign_object
);
2645 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2646 scm_sys_inherit_magic_x (class, supers
);
2648 if (destructor
!= 0)
2650 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2651 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2655 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2656 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2659 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2660 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2665 SCM_SYMBOL (sym_o
, "o");
2666 SCM_SYMBOL (sym_x
, "x");
2668 SCM_KEYWORD (k_accessor
, "accessor");
2669 SCM_KEYWORD (k_getter
, "getter");
2672 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2674 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2679 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2680 SCM (*getter
) (SCM obj
),
2681 SCM (*setter
) (SCM obj
, SCM x
),
2682 char *accessor_name
)
2685 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2686 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2687 setter
? setter
: default_setter
);
2688 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2689 scm_list_2 (get
, sym_o
)),
2691 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2692 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 gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2705 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2710 scm_add_method (scm_setter (gf
),
2711 scm_make (scm_list_5 (scm_class_accessor_method
,
2713 scm_list_2 (class, scm_class_top
),
2718 SCM_SET_SLOT (class, scm_si_slots
,
2719 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2720 scm_list_1 (slot
))));
2721 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2722 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2723 scm_list_1 (gns
))));
2727 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2729 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2734 scm_wrap_object (SCM
class, void *data
)
2736 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2744 scm_wrap_component (SCM
class, SCM container
, void *data
)
2746 SCM obj
= scm_wrap_object (class, data
);
2747 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2753 SCM_SETCDR (handle
, container
);
2758 scm_ensure_accessor (SCM name
)
2760 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2761 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2763 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2764 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2765 k_name
, name
, k_setter
, gf
));
2770 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2773 scm_add_method (SCM gf
, SCM m
)
2775 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2780 * Debugging utilities
2783 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2785 "Return @code{#t} if @var{obj} is a pure generic.")
2786 #define FUNC_NAME s_scm_pure_generic_p
2788 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2792 #endif /* GUILE_DEBUG */
2798 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2800 "Announce that GOOPS is loaded and perform initialization\n"
2801 "on the C level which depends on the loaded GOOPS modules.")
2802 #define FUNC_NAME s_scm_sys_goops_loaded
2805 var_compute_applicable_methods
=
2806 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2808 setup_extended_primitive_generics ();
2809 return SCM_UNSPECIFIED
;
2813 SCM scm_module_goops
;
2816 scm_init_goops_builtins (void)
2818 scm_module_goops
= scm_current_module ();
2819 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2821 /* Not really necessary right now, but who knows...
2823 scm_permanent_object (scm_module_goops
);
2824 scm_permanent_object (scm_goops_lookup_closure
);
2826 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2827 (SCM_MAKINUM (37)));
2829 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2831 #include "libguile/goops.x"
2833 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2835 hell
= scm_malloc (hell_size
);
2836 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2838 create_basic_classes ();
2839 create_standard_classes ();
2840 create_smob_classes ();
2841 create_struct_classes ();
2842 create_port_classes ();
2845 SCM name
= scm_str2symbol ("no-applicable-method");
2846 scm_no_applicable_method
2847 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2850 DEFVAR (name
, scm_no_applicable_method
);
2853 return SCM_UNSPECIFIED
;
2859 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2860 scm_init_goops_builtins
);