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) \
99 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
100 class = SCM_CLASS_OF (obj); \
104 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
105 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
107 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
108 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
110 static int goops_loaded_p
= 0;
111 static scm_t_rstate
*goops_rstate
;
113 static SCM scm_goops_lookup_closure
;
115 /* Some classes are defined in libguile/objects.c. */
116 SCM scm_class_top
, scm_class_object
, scm_class_class
;
117 SCM scm_class_applicable
;
118 SCM scm_class_entity
, scm_class_entity_with_setter
;
119 SCM scm_class_generic
, scm_class_generic_with_setter
;
120 SCM scm_class_accessor
;
121 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
122 SCM scm_class_extended_accessor
;
123 SCM scm_class_method
;
124 SCM scm_class_simple_method
, scm_class_accessor_method
;
125 SCM scm_class_procedure_class
;
126 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
127 SCM scm_class_entity_class
;
128 SCM scm_class_number
, scm_class_list
;
129 SCM scm_class_keyword
;
130 SCM scm_class_port
, scm_class_input_output_port
;
131 SCM scm_class_input_port
, scm_class_output_port
;
132 SCM scm_class_foreign_class
, scm_class_foreign_object
;
133 SCM scm_class_foreign_slot
;
134 SCM scm_class_self
, scm_class_protected
;
135 SCM scm_class_opaque
, scm_class_read_only
;
136 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
138 SCM scm_class_int
, scm_class_float
, scm_class_double
;
140 SCM_SYMBOL (scm_sym_define_public
, "define-public");
142 static SCM
scm_make_unbound (void);
143 static SCM
scm_unbound_p (SCM obj
);
144 static SCM
scm_assert_bound (SCM value
, SCM obj
);
145 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
146 static SCM
scm_sys_goops_loaded (void);
148 /******************************************************************************
152 * This version doesn't fully handle multiple-inheritance. It serves
153 * only for booting classes and will be overloaded in Scheme
155 ******************************************************************************/
158 map (SCM (*proc
) (SCM
), SCM ls
)
164 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
167 while (!SCM_NULLP (ls
))
169 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
181 while (!SCM_NULLP (ls
))
183 SCM el
= SCM_CAR (ls
);
184 if (SCM_FALSEP (scm_c_memq (el
, res
)))
185 res
= scm_cons (el
, res
);
192 compute_cpl (SCM
class)
195 return CALL_GF1 ("compute-cpl", class);
198 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
199 SCM ls
= scm_append (scm_acons (class, supers
,
200 map (compute_cpl
, supers
)));
201 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
205 /******************************************************************************
209 ******************************************************************************/
212 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
220 if (!SCM_SYMBOLP (tmp
))
221 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
223 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
224 res
= scm_cons (SCM_CAR (l
), res
);
225 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
228 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
232 build_slots_list (SCM dslots
, SCM cpl
)
234 register SCM res
= dslots
;
236 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
237 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
238 scm_si_direct_slots
),
241 /* res contains a list of slots. Remove slots which appears more than once */
242 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
249 while (!SCM_NULLP (ls
))
251 if (!SCM_CONSP (SCM_CAR (ls
)))
252 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
259 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
261 "Return a list consisting of the names of all slots belonging to\n"
262 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
264 #define FUNC_NAME s_scm_sys_compute_slots
266 SCM_VALIDATE_CLASS (1, class);
267 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
268 SCM_SLOT (class, scm_si_cpl
));
273 /******************************************************************************
275 * compute-getters-n-setters
277 * This version doesn't handle slot options. It serves only for booting
278 * classes and will be overloaded in Scheme.
280 ******************************************************************************/
282 SCM_KEYWORD (k_init_value
, "init-value");
283 SCM_KEYWORD (k_init_thunk
, "init-thunk");
286 compute_getters_n_setters (SCM slots
)
292 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
294 SCM init
= SCM_BOOL_F
;
295 SCM options
= SCM_CDAR (slots
);
296 if (!SCM_NULLP (options
))
298 init
= scm_get_keyword (k_init_value
, options
, 0);
300 init
= scm_closure (scm_list_2 (SCM_EOL
,
301 scm_list_2 (scm_sym_quote
, init
)),
304 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
306 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
310 cdrloc
= SCM_CDRLOC (*cdrloc
);
315 /******************************************************************************
319 ******************************************************************************/
321 /*fixme* Manufacture keywords in advance */
323 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
327 for (i
= 0; i
!= len
; i
+= 2)
329 SCM obj
= SCM_CAR (l
);
331 if (!SCM_KEYWORDP (obj
))
332 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
333 else if (SCM_EQ_P (obj
, key
))
339 return default_value
;
343 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
344 (SCM key
, SCM l
, SCM default_value
),
345 "Determine an associated value for the keyword @var{key} from\n"
346 "the list @var{l}. The list @var{l} has to consist of an even\n"
347 "number of elements, where, starting with the first, every\n"
348 "second element is a keyword, followed by its associated value.\n"
349 "If @var{l} does not hold a value for @var{key}, the value\n"
350 "@var{default_value} is returned.")
351 #define FUNC_NAME s_scm_get_keyword
355 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
356 len
= scm_ilength (l
);
357 if (len
< 0 || len
% 2 == 1)
358 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
360 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
365 SCM_KEYWORD (k_init_keyword
, "init-keyword");
367 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
368 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
370 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
371 (SCM obj
, SCM initargs
),
372 "Initialize the object @var{obj} with the given arguments\n"
374 #define FUNC_NAME s_scm_sys_initialize_object
376 SCM tmp
, get_n_set
, slots
;
377 SCM
class = SCM_CLASS_OF (obj
);
380 SCM_VALIDATE_INSTANCE (1, obj
);
381 n_initargs
= scm_ilength (initargs
);
382 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
384 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
385 slots
= SCM_SLOT (class, scm_si_slots
);
387 /* See for each slot how it must be initialized */
390 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
392 SCM slot_name
= SCM_CAR (slots
);
395 if (!SCM_NULLP (SCM_CDR (slot_name
)))
397 /* This slot admits (perhaps) to be initialized at creation time */
398 long n
= scm_ilength (SCM_CDR (slot_name
));
399 if (n
& 1) /* odd or -1 */
400 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
401 scm_list_1 (slot_name
));
402 tmp
= scm_i_get_keyword (k_init_keyword
,
407 slot_name
= SCM_CAR (slot_name
);
410 /* an initarg was provided for this slot */
411 if (!SCM_KEYWORDP (tmp
))
412 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
414 slot_value
= scm_i_get_keyword (tmp
,
423 /* set slot to provided value */
424 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
427 /* set slot to its :init-form if it exists */
428 tmp
= SCM_CADAR (get_n_set
);
429 if (tmp
!= SCM_BOOL_F
)
431 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
432 if (SCM_GOOPS_UNBOUNDP (slot_value
))
434 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
435 set_slot_value (class,
438 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
448 /* NOTE: The following macros are interdependent with code
449 * in goops.scm:compute-getters-n-setters
451 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
452 (SCM_INUMP (SCM_CDDR (gns)) \
453 || (SCM_CONSP (SCM_CDDR (gns)) \
454 && SCM_CONSP (SCM_CDDDR (gns)) \
455 && SCM_CONSP (SCM_CDDDDR (gns))))
456 #define SCM_GNS_INDEX(gns) \
457 (SCM_INUMP (SCM_CDDR (gns)) \
458 ? SCM_INUM (SCM_CDDR (gns)) \
459 : SCM_INUM (SCM_CAR (SCM_CDDDDR (gns))))
460 #define SCM_GNS_SIZE(gns) \
461 (SCM_INUMP (SCM_CDDR (gns)) \
463 : SCM_INUM (SCM_CADR (SCM_CDDDDR (gns))))
465 SCM_KEYWORD (k_class
, "class");
466 SCM_KEYWORD (k_allocation
, "allocation");
467 SCM_KEYWORD (k_instance
, "instance");
469 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
472 #define FUNC_NAME s_scm_sys_prep_layout_x
474 SCM slots
, getters_n_setters
, nfields
;
475 unsigned long int n
, i
;
478 SCM_VALIDATE_INSTANCE (1, class);
479 slots
= SCM_SLOT (class, scm_si_slots
);
480 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
481 nfields
= SCM_SLOT (class, scm_si_nfields
);
482 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
483 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
484 scm_list_1 (nfields
));
485 n
= 2 * SCM_INUM (nfields
);
486 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
487 && SCM_SUBCLASSP (class, scm_class_class
))
488 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
489 scm_list_1 (nfields
));
491 s
= n
> 0 ? scm_malloc (n
) : 0;
493 while (SCM_CONSP (getters_n_setters
))
495 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
498 int len
, index
, size
;
501 if (i
>= n
|| !SCM_CONSP (slots
))
504 /* extract slot type */
505 len
= scm_ilength (SCM_CDAR (slots
));
506 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
507 len
, SCM_BOOL_F
, FUNC_NAME
);
508 /* determine slot GC protection and access mode */
509 if (SCM_FALSEP (type
))
516 if (!SCM_CLASSP (type
))
520 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
522 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
524 if (SCM_SUBCLASSP (type
, scm_class_self
))
526 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
531 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
533 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
545 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
546 if (index
!= (i
>> 1))
548 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
556 slots
= SCM_CDR (slots
);
557 getters_n_setters
= SCM_CDR (getters_n_setters
);
559 if (!SCM_NULLP (slots
))
564 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
566 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
569 return SCM_UNSPECIFIED
;
573 static void prep_hashsets (SCM
);
575 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
576 (SCM
class, SCM dsupers
),
578 #define FUNC_NAME s_scm_sys_inherit_magic_x
582 SCM_VALIDATE_INSTANCE (1, class);
583 while (!SCM_NULLP (ls
))
585 SCM_ASSERT (SCM_CONSP (ls
)
586 && SCM_INSTANCEP (SCM_CAR (ls
)),
590 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
593 flags
&= SCM_CLASSF_INHERIT
;
594 if (flags
& SCM_CLASSF_ENTITY
)
595 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
598 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
601 * We could avoid calling scm_gc_malloc in the allocation code
602 * (in which case the following two lines are needed). Instead
603 * we make 0-slot instances non-light, so that the light case
604 * can be handled without special cases.
607 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
609 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
611 /* NOTE: The following depends on scm_struct_i_size. */
612 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
613 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
616 SCM_SET_CLASS_FLAGS (class, flags
);
618 prep_hashsets (class);
620 return SCM_UNSPECIFIED
;
625 prep_hashsets (SCM
class)
629 for (i
= 0; i
< 7; ++i
)
630 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
633 /******************************************************************************/
636 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
638 SCM z
, cpl
, slots
, nfields
, g_n_s
;
640 /* Allocate one instance */
641 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
643 /* Initialize its slots */
644 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
645 cpl
= compute_cpl (z
);
646 slots
= build_slots_list (maplist (dslots
), cpl
);
647 nfields
= SCM_MAKINUM (scm_ilength (slots
));
648 g_n_s
= compute_getters_n_setters (slots
);
650 SCM_SET_SLOT (z
, scm_si_name
, name
);
651 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
652 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
653 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
654 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
655 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
656 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
657 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
658 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
659 SCM_SET_SLOT (z
, scm_si_environment
,
660 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
662 /* Add this class in the direct-subclasses slot of dsupers */
665 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
666 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
667 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
668 scm_si_direct_subclasses
)));
671 /* Support for the underlying structs: */
672 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
673 ? (SCM_CLASSF_GOOPS_OR_VALID
674 | SCM_CLASSF_OPERATOR
676 : class == scm_class_operator_class
677 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
678 : SCM_CLASSF_GOOPS_OR_VALID
));
683 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
685 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
686 scm_sys_inherit_magic_x (z
, dsupers
);
687 scm_sys_prep_layout_x (z
);
691 /******************************************************************************/
693 SCM_SYMBOL (sym_layout
, "layout");
694 SCM_SYMBOL (sym_vcell
, "vcell");
695 SCM_SYMBOL (sym_vtable
, "vtable");
696 SCM_SYMBOL (sym_print
, "print");
697 SCM_SYMBOL (sym_procedure
, "procedure");
698 SCM_SYMBOL (sym_setter
, "setter");
699 SCM_SYMBOL (sym_redefined
, "redefined");
700 SCM_SYMBOL (sym_h0
, "h0");
701 SCM_SYMBOL (sym_h1
, "h1");
702 SCM_SYMBOL (sym_h2
, "h2");
703 SCM_SYMBOL (sym_h3
, "h3");
704 SCM_SYMBOL (sym_h4
, "h4");
705 SCM_SYMBOL (sym_h5
, "h5");
706 SCM_SYMBOL (sym_h6
, "h6");
707 SCM_SYMBOL (sym_h7
, "h7");
708 SCM_SYMBOL (sym_name
, "name");
709 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
710 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
711 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
712 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
713 SCM_SYMBOL (sym_cpl
, "cpl");
714 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
715 SCM_SYMBOL (sym_slots
, "slots");
716 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
717 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
718 SCM_SYMBOL (sym_nfields
, "nfields");
719 SCM_SYMBOL (sym_environment
, "environment");
723 build_class_class_slots ()
726 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
727 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
728 scm_list_1 (sym_print
),
729 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
730 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
731 scm_list_1 (sym_redefined
),
732 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
733 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
734 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
735 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
736 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
737 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
738 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
739 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
740 scm_list_1 (sym_name
),
741 scm_list_1 (sym_direct_supers
),
742 scm_list_1 (sym_direct_slots
),
743 scm_list_1 (sym_direct_subclasses
),
744 scm_list_1 (sym_direct_methods
),
745 scm_list_1 (sym_cpl
),
746 scm_list_1 (sym_default_slot_definition_class
),
747 scm_list_1 (sym_slots
),
748 scm_list_1 (sym_getters_n_setters
),
749 scm_list_1 (sym_keyword_access
),
750 scm_list_1 (sym_nfields
),
751 scm_list_1 (sym_environment
),
756 create_basic_classes (void)
758 /* SCM slots_of_class = build_class_class_slots (); */
760 /**** <scm_class_class> ****/
761 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
762 + 2 * scm_vtable_offset_user
);
763 SCM name
= scm_str2symbol ("<class>");
764 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
767 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
768 | SCM_CLASSF_METACLASS
));
770 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
771 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
772 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
773 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
774 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
775 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
776 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
777 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
778 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
779 compute_getters_n_setters (slots_of_class)); */
780 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
781 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
782 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
784 prep_hashsets (scm_class_class
);
786 DEFVAR(name
, scm_class_class
);
788 /**** <scm_class_top> ****/
789 name
= scm_str2symbol ("<top>");
790 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
795 DEFVAR(name
, scm_class_top
);
797 /**** <scm_class_object> ****/
798 name
= scm_str2symbol ("<object>");
799 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
801 scm_list_1 (scm_class_top
),
804 DEFVAR (name
, scm_class_object
);
806 /* <top> <object> and <class> were partially initialized. Correct them here */
807 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
809 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
810 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
813 /******************************************************************************/
815 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
817 "Return @code{#t} if @var{obj} is an instance.")
818 #define FUNC_NAME s_scm_instance_p
820 return SCM_BOOL (SCM_INSTANCEP (obj
));
825 /******************************************************************************
827 * Meta object accessors
829 ******************************************************************************/
830 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
832 "Return the class name of @var{obj}.")
833 #define FUNC_NAME s_scm_class_name
835 SCM_VALIDATE_CLASS (1, obj
);
836 return scm_slot_ref (obj
, sym_name
);
840 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
842 "Return the direct superclasses of the class @var{obj}.")
843 #define FUNC_NAME s_scm_class_direct_supers
845 SCM_VALIDATE_CLASS (1, obj
);
846 return scm_slot_ref (obj
, sym_direct_supers
);
850 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
852 "Return the direct slots of the class @var{obj}.")
853 #define FUNC_NAME s_scm_class_direct_slots
855 SCM_VALIDATE_CLASS (1, obj
);
856 return scm_slot_ref (obj
, sym_direct_slots
);
860 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
862 "Return the direct subclasses of the class @var{obj}.")
863 #define FUNC_NAME s_scm_class_direct_subclasses
865 SCM_VALIDATE_CLASS (1, obj
);
866 return scm_slot_ref(obj
, sym_direct_subclasses
);
870 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
872 "Return the direct methods of the class @var{obj}")
873 #define FUNC_NAME s_scm_class_direct_methods
875 SCM_VALIDATE_CLASS (1, obj
);
876 return scm_slot_ref (obj
, sym_direct_methods
);
880 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
882 "Return the class precedence list of the class @var{obj}.")
883 #define FUNC_NAME s_scm_class_precedence_list
885 SCM_VALIDATE_CLASS (1, obj
);
886 return scm_slot_ref (obj
, sym_cpl
);
890 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
892 "Return the slot list of the class @var{obj}.")
893 #define FUNC_NAME s_scm_class_slots
895 SCM_VALIDATE_CLASS (1, obj
);
896 return scm_slot_ref (obj
, sym_slots
);
900 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
902 "Return the environment of the class @var{obj}.")
903 #define FUNC_NAME s_scm_class_environment
905 SCM_VALIDATE_CLASS (1, obj
);
906 return scm_slot_ref(obj
, sym_environment
);
911 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
913 "Return the name of the generic function @var{obj}.")
914 #define FUNC_NAME s_scm_generic_function_name
916 SCM_VALIDATE_GENERIC (1, obj
);
917 return scm_procedure_property (obj
, scm_sym_name
);
921 SCM_SYMBOL (sym_methods
, "methods");
922 SCM_SYMBOL (sym_extended_by
, "extended-by");
923 SCM_SYMBOL (sym_extends
, "extends");
926 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
928 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
929 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
930 while (!SCM_NULLP (gfs
))
932 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
939 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
941 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
943 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
944 while (!SCM_NULLP (gfs
))
946 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
947 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
956 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
958 "Return the methods of the generic function @var{obj}.")
959 #define FUNC_NAME s_scm_generic_function_methods
962 SCM_VALIDATE_GENERIC (1, obj
);
963 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
964 methods
= fold_downward_gf_methods (methods
, obj
);
965 return scm_append (methods
);
969 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
971 "Return the generic function for the method @var{obj}.")
972 #define FUNC_NAME s_scm_method_generic_function
974 SCM_VALIDATE_METHOD (1, obj
);
975 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
979 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
981 "Return specializers of the method @var{obj}.")
982 #define FUNC_NAME s_scm_method_specializers
984 SCM_VALIDATE_METHOD (1, obj
);
985 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
989 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
991 "Return the procedure of the method @var{obj}.")
992 #define FUNC_NAME s_scm_method_procedure
994 SCM_VALIDATE_METHOD (1, obj
);
995 return scm_slot_ref (obj
, sym_procedure
);
999 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1001 "Return the slot definition of the accessor @var{obj}.")
1002 #define FUNC_NAME s_scm_accessor_method_slot_definition
1004 SCM_VALIDATE_ACCESSOR (1, obj
);
1005 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
1009 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1011 "Internal GOOPS magic---don't use this function!")
1012 #define FUNC_NAME s_scm_sys_tag_body
1014 return scm_cons (SCM_IM_LAMBDA
, body
);
1018 /******************************************************************************
1020 * S l o t a c c e s s
1022 ******************************************************************************/
1024 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1026 "Return the unbound value.")
1027 #define FUNC_NAME s_scm_make_unbound
1029 return SCM_GOOPS_UNBOUND
;
1033 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1035 "Return @code{#t} if @var{obj} is unbound.")
1036 #define FUNC_NAME s_scm_unbound_p
1038 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1042 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1043 (SCM value
, SCM obj
),
1044 "Return @var{value} if it is bound, and invoke the\n"
1045 "@var{slot-unbound} method of @var{obj} if it is not.")
1046 #define FUNC_NAME s_scm_assert_bound
1048 if (SCM_GOOPS_UNBOUNDP (value
))
1049 return CALL_GF1 ("slot-unbound", obj
);
1054 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1055 (SCM obj
, SCM index
),
1056 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1057 "the value from @var{obj}.")
1058 #define FUNC_NAME s_scm_at_assert_bound_ref
1060 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1061 if (SCM_GOOPS_UNBOUNDP (value
))
1062 return CALL_GF1 ("slot-unbound", obj
);
1067 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1068 (SCM obj
, SCM index
),
1069 "Return the slot value with index @var{index} from @var{obj}.")
1070 #define FUNC_NAME s_scm_sys_fast_slot_ref
1072 unsigned long int i
;
1074 SCM_VALIDATE_INSTANCE (1, obj
);
1075 SCM_VALIDATE_INUM (2, index
);
1076 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1077 i
= SCM_INUM (index
);
1078 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1080 return SCM_SLOT (obj
, i
);
1084 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1085 (SCM obj
, SCM index
, SCM value
),
1086 "Set the slot with index @var{index} in @var{obj} to\n"
1088 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1090 unsigned long int i
;
1092 SCM_VALIDATE_INSTANCE (1, obj
);
1093 SCM_VALIDATE_INUM (2, index
);
1094 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1095 i
= SCM_INUM (index
);
1096 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1098 SCM_SET_SLOT (obj
, i
, value
);
1100 return SCM_UNSPECIFIED
;
1107 /* In the future, this function will return the effective slot
1108 * definition associated with SLOT_NAME. Now it just returns some of
1109 * the information which will be stored in the effective slot
1114 slot_definition_using_name (SCM
class, SCM slot_name
)
1116 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1117 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1118 if (SCM_CAAR (slots
) == slot_name
)
1119 return SCM_CAR (slots
);
1124 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1126 SCM access
= SCM_CDDR (slotdef
);
1128 * - access is an integer (the offset of this slot in the slots vector)
1129 * - otherwise (car access) is the getter function to apply
1131 if (SCM_INUMP (access
))
1132 return SCM_SLOT (obj
, SCM_INUM (access
));
1135 /* We must evaluate (apply (car access) (list obj))
1136 * where (car access) is known to be a closure of arity 1 */
1137 register SCM code
, env
;
1139 code
= SCM_CAR (access
);
1140 if (!SCM_CLOSUREP (code
))
1141 return SCM_SUBRF (code
) (obj
);
1142 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1145 /* Evaluate the closure body */
1146 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1151 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1153 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1154 if (!SCM_FALSEP (slotdef
))
1155 return get_slot_value (class, obj
, slotdef
);
1157 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1161 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1163 SCM access
= SCM_CDDR (slotdef
);
1165 * - access is an integer (the offset of this slot in the slots vector)
1166 * - otherwise (cadr access) is the setter function to apply
1168 if (SCM_INUMP (access
))
1169 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1172 /* We must evaluate (apply (cadr l) (list obj value))
1173 * where (cadr l) is known to be a closure of arity 2 */
1174 register SCM code
, env
;
1176 code
= SCM_CADR (access
);
1177 if (!SCM_CLOSUREP (code
))
1178 SCM_SUBRF (code
) (obj
, value
);
1181 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1182 scm_list_2 (obj
, value
),
1184 /* Evaluate the closure body */
1185 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1188 return SCM_UNSPECIFIED
;
1192 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1194 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1195 if (!SCM_FALSEP (slotdef
))
1196 return set_slot_value (class, obj
, slotdef
, value
);
1198 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1202 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1206 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1207 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1213 /* ======================================== */
1215 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1216 (SCM
class, SCM obj
, SCM slot_name
),
1218 #define FUNC_NAME s_scm_slot_ref_using_class
1222 SCM_VALIDATE_CLASS (1, class);
1223 SCM_VALIDATE_INSTANCE (2, obj
);
1224 SCM_VALIDATE_SYMBOL (3, slot_name
);
1226 res
= get_slot_value_using_name (class, obj
, slot_name
);
1227 if (SCM_GOOPS_UNBOUNDP (res
))
1228 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1234 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1235 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1237 #define FUNC_NAME s_scm_slot_set_using_class_x
1239 SCM_VALIDATE_CLASS (1, class);
1240 SCM_VALIDATE_INSTANCE (2, obj
);
1241 SCM_VALIDATE_SYMBOL (3, slot_name
);
1243 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1248 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1249 (SCM
class, SCM obj
, SCM slot_name
),
1251 #define FUNC_NAME s_scm_slot_bound_using_class_p
1253 SCM_VALIDATE_CLASS (1, class);
1254 SCM_VALIDATE_INSTANCE (2, obj
);
1255 SCM_VALIDATE_SYMBOL (3, slot_name
);
1257 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1263 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1264 (SCM
class, SCM obj
, SCM slot_name
),
1266 #define FUNC_NAME s_scm_slot_exists_using_class_p
1268 SCM_VALIDATE_CLASS (1, class);
1269 SCM_VALIDATE_INSTANCE (2, obj
);
1270 SCM_VALIDATE_SYMBOL (3, slot_name
);
1271 return test_slot_existence (class, obj
, slot_name
);
1276 /* ======================================== */
1278 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1279 (SCM obj
, SCM slot_name
),
1280 "Return the value from @var{obj}'s slot with the name\n"
1282 #define FUNC_NAME s_scm_slot_ref
1286 SCM_VALIDATE_INSTANCE (1, obj
);
1287 TEST_CHANGE_CLASS (obj
, class);
1289 res
= get_slot_value_using_name (class, obj
, slot_name
);
1290 if (SCM_GOOPS_UNBOUNDP (res
))
1291 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1296 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1297 (SCM obj
, SCM slot_name
, SCM value
),
1298 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1299 #define FUNC_NAME s_scm_slot_set_x
1303 SCM_VALIDATE_INSTANCE (1, obj
);
1304 TEST_CHANGE_CLASS(obj
, class);
1306 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1310 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1312 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1313 (SCM obj
, SCM slot_name
),
1314 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1316 #define FUNC_NAME s_scm_slot_bound_p
1320 SCM_VALIDATE_INSTANCE (1, obj
);
1321 TEST_CHANGE_CLASS(obj
, class);
1323 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1331 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1332 (SCM obj
, SCM slot_name
),
1333 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1334 #define FUNC_NAME s_scm_slot_exists_p
1338 SCM_VALIDATE_INSTANCE (1, obj
);
1339 SCM_VALIDATE_SYMBOL (2, slot_name
);
1340 TEST_CHANGE_CLASS (obj
, class);
1342 return test_slot_existence (class, obj
, slot_name
);
1347 /******************************************************************************
1349 * %allocate-instance (the low level instance allocation primitive)
1351 ******************************************************************************/
1353 static void clear_method_cache (SCM
);
1356 wrap_init (SCM
class, SCM
*m
, long n
)
1360 /* Set all slots to unbound */
1361 for (i
= 0; i
< n
; i
++)
1362 m
[i
] = SCM_GOOPS_UNBOUND
;
1364 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1366 (scm_t_bits
) m
, 0, 0);
1369 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1370 (SCM
class, SCM initargs
),
1371 "Create a new instance of class @var{class} and initialize it\n"
1372 "from the arguments @var{initargs}.")
1373 #define FUNC_NAME s_scm_sys_allocate_instance
1378 SCM_VALIDATE_CLASS (1, class);
1380 /* Most instances */
1381 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1383 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1384 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1385 return wrap_init (class, m
, n
);
1388 /* Foreign objects */
1389 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1390 return scm_make_foreign_object (class, initargs
);
1392 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1395 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1397 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1399 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1400 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1401 /* Generic functions */
1402 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1404 SCM gf
= wrap_init (class, m
, n
);
1405 clear_method_cache (gf
);
1409 return wrap_init (class, m
, n
);
1413 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1417 /* allocate class object */
1418 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1420 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1421 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1422 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1424 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1425 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1426 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1427 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1432 /* Non-light instances */
1434 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1435 return wrap_init (class, m
, n
);
1440 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1441 (SCM obj
, SCM setter
),
1443 #define FUNC_NAME s_scm_sys_set_object_setter_x
1445 SCM_ASSERT (SCM_STRUCTP (obj
)
1446 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1447 || SCM_I_ENTITYP (obj
)),
1451 if (SCM_I_ENTITYP (obj
))
1452 SCM_SET_ENTITY_SETTER (obj
, setter
);
1454 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1455 return SCM_UNSPECIFIED
;
1459 /******************************************************************************
1461 * %modify-instance (used by change-class to modify in place)
1463 ******************************************************************************/
1465 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1468 #define FUNC_NAME s_scm_sys_modify_instance
1470 SCM_VALIDATE_INSTANCE (1, old
);
1471 SCM_VALIDATE_INSTANCE (2, new);
1473 /* Exchange the data contained in old and new. We exchange rather than
1474 * scratch the old value with new to be correct with GC.
1475 * See "Class redefinition protocol above".
1479 SCM car
= SCM_CAR (old
);
1480 SCM cdr
= SCM_CDR (old
);
1481 SCM_SETCAR (old
, SCM_CAR (new));
1482 SCM_SETCDR (old
, SCM_CDR (new));
1483 SCM_SETCAR (new, car
);
1484 SCM_SETCDR (new, cdr
);
1487 return SCM_UNSPECIFIED
;
1491 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1494 #define FUNC_NAME s_scm_sys_modify_class
1496 SCM_VALIDATE_CLASS (1, old
);
1497 SCM_VALIDATE_CLASS (2, new);
1501 SCM car
= SCM_CAR (old
);
1502 SCM cdr
= SCM_CDR (old
);
1503 SCM_SETCAR (old
, SCM_CAR (new));
1504 SCM_SETCDR (old
, SCM_CDR (new));
1505 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1506 SCM_SETCAR (new, car
);
1507 SCM_SETCDR (new, cdr
);
1508 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1511 return SCM_UNSPECIFIED
;
1515 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1518 #define FUNC_NAME s_scm_sys_invalidate_class
1520 SCM_VALIDATE_CLASS (1, class);
1521 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1522 return SCM_UNSPECIFIED
;
1526 /* When instances change class, they finally get a new body, but
1527 * before that, they go through purgatory in hell. Odd as it may
1528 * seem, this data structure saves us from eternal suffering in
1529 * infinite recursions.
1532 static scm_t_bits
**hell
;
1533 static long n_hell
= 1; /* one place for the evil one himself */
1534 static long hell_size
= 4;
1535 static SCM hell_mutex
;
1541 for (i
= 1; i
< n_hell
; ++i
)
1542 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1548 go_to_hell (void *o
)
1550 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1551 scm_lock_mutex (hell_mutex
);
1552 if (n_hell
== hell_size
)
1554 long new_size
= 2 * hell_size
;
1555 hell
= scm_realloc (hell
, new_size
);
1556 hell_size
= new_size
;
1558 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1559 scm_unlock_mutex (hell_mutex
);
1563 go_to_heaven (void *o
)
1565 scm_lock_mutex (hell_mutex
);
1566 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1567 scm_unlock_mutex (hell_mutex
);
1571 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1574 purgatory (void *args
)
1576 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1577 SCM_PACK ((scm_t_bits
) args
));
1580 /* This function calls the generic function change-class for all
1581 * instances which aren't currently undergoing class change.
1585 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1588 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1589 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1590 (void *) SCM_UNPACK (obj
));
1593 /******************************************************************************
1599 * GGG E N E R I C F U N C T I O N S
1601 * This implementation provides
1602 * - generic functions (with class specializers)
1605 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1607 ******************************************************************************/
1609 SCM_KEYWORD (k_name
, "name");
1611 SCM_SYMBOL (sym_no_method
, "no-method");
1613 static SCM list_of_no_method
;
1615 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1618 scm_make_method_cache (SCM gf
)
1620 return scm_list_5 (SCM_IM_DISPATCH
,
1623 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1629 clear_method_cache (SCM gf
)
1631 SCM cache
= scm_make_method_cache (gf
);
1632 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1633 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1636 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1639 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1642 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1643 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1644 if (!SCM_FALSEP (used_by
))
1646 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1647 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1648 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1649 clear_method_cache (gf
);
1650 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1651 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1654 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1655 /* The sign of n is a flag indicating rest args. */
1656 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1658 return SCM_UNSPECIFIED
;
1662 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1665 #define FUNC_NAME s_scm_generic_capability_p
1667 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1668 proc
, SCM_ARG1
, FUNC_NAME
);
1669 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1675 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1678 #define FUNC_NAME s_scm_enable_primitive_generic_x
1680 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1681 while (!SCM_NULLP (subrs
))
1683 SCM subr
= SCM_CAR (subrs
);
1684 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1685 subr
, SCM_ARGn
, FUNC_NAME
);
1686 *SCM_SUBR_GENERIC (subr
)
1687 = scm_make (scm_list_3 (scm_class_generic
,
1690 subrs
= SCM_CDR (subrs
);
1692 return SCM_UNSPECIFIED
;
1696 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1699 #define FUNC_NAME s_scm_primitive_generic_generic
1701 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1703 if (!*SCM_SUBR_GENERIC (subr
))
1704 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1705 return *SCM_SUBR_GENERIC (subr
);
1707 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1711 typedef struct t_extension
{
1712 struct t_extension
*next
;
1717 static t_extension
*extensions
= 0;
1719 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1722 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1727 if (!*SCM_SUBR_GENERIC (extended
))
1728 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1729 gf
= *SCM_SUBR_GENERIC (extended
);
1730 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1732 SCM_SNAME (extension
));
1733 *SCM_SUBR_GENERIC (extension
) = gext
;
1737 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1738 t_extension
**loc
= &extensions
;
1739 /* Make sure that extensions are placed before their own
1740 * extensions in the extensions list. O(N^2) algorithm, but
1741 * extensions of primitive generics are rare.
1743 while (*loc
&& extension
!= (*loc
)->extended
)
1744 loc
= &(*loc
)->next
;
1746 e
->extended
= extended
;
1747 e
->extension
= extension
;
1753 setup_extended_primitive_generics ()
1757 t_extension
*e
= extensions
;
1758 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1759 extensions
= e
->next
;
1764 /******************************************************************************
1766 * Protocol for calling a generic fumction
1767 * This protocol is roughly equivalent to (parameter are a little bit different
1768 * for efficiency reasons):
1770 * + apply-generic (gf args)
1771 * + compute-applicable-methods (gf args ...)
1772 * + sort-applicable-methods (methods args)
1773 * + apply-methods (gf methods args)
1775 * apply-methods calls make-next-method to build the "continuation" of a a
1776 * method. Applying a next-method will call apply-next-method which in
1777 * turn will call apply again to call effectively the following method.
1779 ******************************************************************************/
1782 applicablep (SCM actual
, SCM formal
)
1784 /* We already know that the cpl is well formed. */
1785 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1789 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1791 register SCM s1
, s2
;
1795 * m1 and m2 can have != length (i.e. one can be one element longer than the
1796 * other when we have a dotted parameter list). For instance, with the call
1799 * (define-method M (a . l) ....)
1800 * (define-method M (a) ....)
1802 * we consider that the second method is more specific.
1804 * BTW, targs is an array of types. We don't need it's size since
1805 * we already know that m1 and m2 are applicable (no risk to go past
1806 * the end of this array).
1809 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1810 if (SCM_NULLP(s1
)) return 1;
1811 if (SCM_NULLP(s2
)) return 0;
1812 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1813 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1815 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1816 if (cs1
== SCM_CAR(l
))
1818 if (cs2
== SCM_CAR(l
))
1821 return 0;/* should not occur! */
1824 return 0; /* should not occur! */
1827 #define BUFFSIZE 32 /* big enough for most uses */
1830 scm_i_vector2list (SCM l
, long len
)
1833 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1835 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1836 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1842 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1845 SCM
*v
, vector
= SCM_EOL
;
1846 SCM buffer
[BUFFSIZE
];
1847 SCM save
= method_list
;
1849 /* For reasonably sized method_lists we can try to avoid all the
1850 * consing and reorder the list in place...
1851 * This idea is due to David McClain <Dave_McClain@msn.com>
1853 if (size
<= BUFFSIZE
)
1855 for (i
= 0; i
< size
; i
++)
1857 buffer
[i
] = SCM_CAR (method_list
);
1858 method_list
= SCM_CDR (method_list
);
1864 /* Too many elements in method_list to keep everything locally */
1865 vector
= scm_i_vector2list (save
, size
);
1868 This is a new vector. Don't worry about the write barrier.
1869 We're not allocating elements in this routine, so this should
1872 v
= SCM_WRITABLE_VELTS (vector
);
1875 /* Use a simple shell sort since it is generally faster than qsort on
1876 * small vectors (which is probably mostly the case when we have to
1877 * sort a list of applicable methods).
1879 for (incr
= size
/ 2; incr
; incr
/= 2)
1881 for (i
= incr
; i
< size
; i
++)
1883 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1885 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1889 SCM tmp
= v
[j
+ incr
];
1897 if (size
<= BUFFSIZE
)
1899 /* We did it in locally, so restore the original list (reordered) in-place */
1900 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1902 SCM_SETCAR (method_list
, *v
);
1903 method_list
= SCM_CDR (method_list
);
1907 /* If we are here, that's that we did it the hard way... */
1908 return scm_vector_to_list (vector
);
1912 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1916 SCM l
, fl
, applicable
= SCM_EOL
;
1918 SCM buffer
[BUFFSIZE
];
1923 /* Build the list of arguments types */
1924 if (len
>= BUFFSIZE
) {
1925 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1926 /* NOTE: Using pointers to malloced memory won't work if we
1927 1. have preemtive threading, and,
1928 2. have a GC which moves objects. */
1929 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1932 note that we don't have to work to reset the generation
1933 count. TMP is a new vector anyway, and it is found
1940 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1941 *p
++ = scm_class_of (SCM_CAR (args
));
1943 /* Build a list of all applicable methods */
1944 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1946 fl
= SPEC_OF (SCM_CAR (l
));
1947 /* Only accept accessors which match exactly in first arg. */
1948 if (SCM_ACCESSORP (SCM_CAR (l
))
1949 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1951 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1953 if (SCM_INSTANCEP (fl
)
1954 /* We have a dotted argument list */
1955 || (i
>= len
&& SCM_NULLP (fl
)))
1956 { /* both list exhausted */
1957 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1963 || !applicablep (types
[i
], SCM_CAR (fl
)))
1972 CALL_GF2 ("no-applicable-method", gf
, save
);
1973 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1977 scm_remember_upto_here_1 (tmp
);
1980 : sort_applicable_methods (applicable
, count
, types
));
1984 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1987 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1990 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1991 #define FUNC_NAME s_sys_compute_applicable_methods
1994 SCM_VALIDATE_GENERIC (1, gf
);
1995 n
= scm_ilength (args
);
1996 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1997 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2001 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2002 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
));
2004 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
2007 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
2008 #define FUNC_NAME s_atslot_ref
2010 SCM x
= SCM_CDR (xorig
);
2011 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
2012 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
2013 return scm_cons (SCM_IM_SLOT_REF
, x
);
2018 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
2021 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
2022 #define FUNC_NAME s_atslot_set_x
2024 SCM x
= SCM_CDR (xorig
);
2025 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
2026 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
2027 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
2032 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
2034 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
2037 scm_m_atdispatch (SCM xorig
, SCM env
)
2038 #define FUNC_NAME s_atdispatch
2040 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
2041 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
2043 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
2044 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
2046 n
= SCM_XEVALCAR (x
, env
);
2047 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
2048 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
2050 v
= SCM_XEVALCAR (x
, env
);
2051 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
2053 gf
= SCM_XEVALCAR (x
, env
);
2054 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
2055 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
2061 lock_cache_mutex (void *m
)
2063 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2064 scm_lock_mutex (mutex
);
2068 unlock_cache_mutex (void *m
)
2070 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2071 scm_unlock_mutex (mutex
);
2075 call_memoize_method (void *a
)
2077 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2078 SCM gf
= SCM_CAR (args
);
2079 SCM x
= SCM_CADR (args
);
2080 /* First check if another thread has inserted a method between
2081 * the cache miss and locking the mutex.
2083 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2084 if (!SCM_FALSEP (cmethod
))
2086 /*fixme* Use scm_apply */
2087 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2091 scm_memoize_method (SCM x
, SCM args
)
2093 SCM gf
= SCM_CAR (scm_last_pair (x
));
2094 return scm_internal_dynamic_wind (
2096 call_memoize_method
,
2098 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2099 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2102 /******************************************************************************
2104 * A simple make (which will be redefined later in Scheme)
2105 * This version handles only creation of gf, methods and classes (no instances)
2107 * Since this code will disappear when Goops will be fully booted,
2108 * no precaution is taken to be efficient.
2110 ******************************************************************************/
2112 SCM_KEYWORD (k_setter
, "setter");
2113 SCM_KEYWORD (k_specializers
, "specializers");
2114 SCM_KEYWORD (k_procedure
, "procedure");
2115 SCM_KEYWORD (k_dsupers
, "dsupers");
2116 SCM_KEYWORD (k_slots
, "slots");
2117 SCM_KEYWORD (k_gf
, "generic-function");
2119 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2121 "Make a new object. @var{args} must contain the class and\n"
2122 "all necessary initialization information.")
2123 #define FUNC_NAME s_scm_make
2126 long len
= scm_ilength (args
);
2128 if (len
<= 0 || (len
& 1) == 0)
2129 SCM_WRONG_NUM_ARGS ();
2131 class = SCM_CAR(args
);
2132 args
= SCM_CDR(args
);
2134 if (class == scm_class_generic
|| class == scm_class_accessor
)
2136 z
= scm_make_struct (class, SCM_INUM0
,
2137 scm_list_5 (SCM_EOL
,
2142 scm_set_procedure_property_x (z
, scm_sym_name
,
2143 scm_get_keyword (k_name
,
2146 clear_method_cache (z
);
2147 if (class == scm_class_accessor
)
2149 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2150 if (!SCM_FALSEP (setter
))
2151 scm_sys_set_object_setter_x (z
, setter
);
2156 z
= scm_sys_allocate_instance (class, args
);
2158 if (class == scm_class_method
2159 || class == scm_class_simple_method
2160 || class == scm_class_accessor_method
)
2162 SCM_SET_SLOT (z
, scm_si_generic_function
,
2163 scm_i_get_keyword (k_gf
,
2168 SCM_SET_SLOT (z
, scm_si_specializers
,
2169 scm_i_get_keyword (k_specializers
,
2174 SCM_SET_SLOT (z
, scm_si_procedure
,
2175 scm_i_get_keyword (k_procedure
,
2180 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2184 /* In all the others case, make a new class .... No instance here */
2185 SCM_SET_SLOT (z
, scm_si_name
,
2186 scm_i_get_keyword (k_name
,
2189 scm_str2symbol ("???"),
2191 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2192 scm_i_get_keyword (k_dsupers
,
2197 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2198 scm_i_get_keyword (k_slots
,
2209 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2212 #define FUNC_NAME s_scm_find_method
2215 long len
= scm_ilength (l
);
2218 SCM_WRONG_NUM_ARGS ();
2220 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2221 SCM_VALIDATE_GENERIC (1, gf
);
2222 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2223 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2225 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2229 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2230 (SCM m1
, SCM m2
, SCM targs
),
2232 #define FUNC_NAME s_scm_sys_method_more_specific_p
2237 SCM_VALIDATE_METHOD (1, m1
);
2238 SCM_VALIDATE_METHOD (2, m2
);
2239 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2241 /* Verify that all the arguments of targs are classes and place them in a vector*/
2242 v
= scm_c_make_vector (len
, SCM_EOL
);
2244 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2245 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2246 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2248 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2254 /******************************************************************************
2258 ******************************************************************************/
2261 fix_cpl (SCM c
, SCM before
, SCM after
)
2263 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2264 SCM ls
= scm_c_memq (after
, cpl
);
2265 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2266 if (SCM_FALSEP (ls
))
2267 /* if this condition occurs, fix_cpl should not be applied this way */
2269 SCM_SETCAR (ls
, before
);
2270 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2272 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2273 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2274 SCM g_n_s
= compute_getters_n_setters (slots
);
2275 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2276 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2282 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2284 SCM tmp
= scm_str2symbol (name
);
2286 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2290 : scm_list_1 (super
),
2296 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2299 create_standard_classes (void)
2302 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2303 scm_str2symbol ("specializers"),
2305 scm_str2symbol ("code-table"));
2306 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2308 k_slot_definition
));
2309 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2310 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2311 scm_list_3 (scm_str2symbol ("n-specialized"),
2314 scm_list_3 (scm_str2symbol ("used-by"),
2317 scm_list_3 (scm_str2symbol ("cache-mutex"),
2319 scm_closure (scm_list_2 (SCM_EOL
,
2322 scm_list_3 (scm_str2symbol ("extended-by"),
2325 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2328 /* Foreign class slot classes */
2329 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2330 scm_class_class
, scm_class_top
, SCM_EOL
);
2331 make_stdcls (&scm_class_protected
, "<protected-slot>",
2332 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2333 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2334 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2335 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2336 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2337 make_stdcls (&scm_class_self
, "<self-slot>",
2339 scm_class_read_only
,
2341 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2343 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2345 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2347 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2349 make_stdcls (&scm_class_scm
, "<scm-slot>",
2350 scm_class_class
, scm_class_protected
, SCM_EOL
);
2351 make_stdcls (&scm_class_int
, "<int-slot>",
2352 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2353 make_stdcls (&scm_class_float
, "<float-slot>",
2354 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2355 make_stdcls (&scm_class_double
, "<double-slot>",
2356 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2358 /* Continue initialization of class <class> */
2360 slots
= build_class_class_slots ();
2361 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2362 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2363 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2364 compute_getters_n_setters (slots
));
2366 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2367 scm_class_class
, scm_class_class
,
2368 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2371 scm_list_3 (scm_str2symbol ("destructor"),
2373 scm_class_opaque
)));
2374 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2375 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2376 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2378 /* scm_class_generic functions classes */
2379 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2380 scm_class_class
, scm_class_class
, SCM_EOL
);
2381 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2382 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2383 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2384 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2385 make_stdcls (&scm_class_operator_with_setter_class
,
2386 "<operator-with-setter-class>",
2387 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2388 make_stdcls (&scm_class_method
, "<method>",
2389 scm_class_class
, scm_class_object
, method_slots
);
2390 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2391 scm_class_class
, scm_class_method
, SCM_EOL
);
2392 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2393 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2394 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2395 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2396 make_stdcls (&scm_class_applicable
, "<applicable>",
2397 scm_class_class
, scm_class_top
, SCM_EOL
);
2398 make_stdcls (&scm_class_entity
, "<entity>",
2399 scm_class_entity_class
,
2400 scm_list_2 (scm_class_object
, scm_class_applicable
),
2402 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2403 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2404 make_stdcls (&scm_class_generic
, "<generic>",
2405 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2406 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2407 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2408 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2409 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2410 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2411 scm_class_entity_class
,
2412 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2414 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2415 make_stdcls (&scm_class_accessor
, "<accessor>",
2416 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2417 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2418 make_stdcls (&scm_class_extended_generic_with_setter
,
2419 "<extended-generic-with-setter>",
2420 scm_class_entity_class
,
2421 scm_list_2 (scm_class_generic_with_setter
,
2422 scm_class_extended_generic
),
2424 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2425 SCM_CLASSF_PURE_GENERIC
);
2426 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2427 scm_class_entity_class
,
2428 scm_list_2 (scm_class_accessor
,
2429 scm_class_extended_generic_with_setter
),
2431 fix_cpl (scm_class_extended_accessor
,
2432 scm_class_extended_generic
, scm_class_generic
);
2433 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2435 /* Primitive types classes */
2436 make_stdcls (&scm_class_boolean
, "<boolean>",
2437 scm_class_class
, scm_class_top
, SCM_EOL
);
2438 make_stdcls (&scm_class_char
, "<char>",
2439 scm_class_class
, scm_class_top
, SCM_EOL
);
2440 make_stdcls (&scm_class_list
, "<list>",
2441 scm_class_class
, scm_class_top
, SCM_EOL
);
2442 make_stdcls (&scm_class_pair
, "<pair>",
2443 scm_class_class
, scm_class_list
, SCM_EOL
);
2444 make_stdcls (&scm_class_null
, "<null>",
2445 scm_class_class
, scm_class_list
, SCM_EOL
);
2446 make_stdcls (&scm_class_string
, "<string>",
2447 scm_class_class
, scm_class_top
, SCM_EOL
);
2448 make_stdcls (&scm_class_symbol
, "<symbol>",
2449 scm_class_class
, scm_class_top
, SCM_EOL
);
2450 make_stdcls (&scm_class_vector
, "<vector>",
2451 scm_class_class
, scm_class_top
, SCM_EOL
);
2452 make_stdcls (&scm_class_number
, "<number>",
2453 scm_class_class
, scm_class_top
, SCM_EOL
);
2454 make_stdcls (&scm_class_complex
, "<complex>",
2455 scm_class_class
, scm_class_number
, SCM_EOL
);
2456 make_stdcls (&scm_class_real
, "<real>",
2457 scm_class_class
, scm_class_complex
, SCM_EOL
);
2458 make_stdcls (&scm_class_integer
, "<integer>",
2459 scm_class_class
, scm_class_real
, SCM_EOL
);
2460 make_stdcls (&scm_class_keyword
, "<keyword>",
2461 scm_class_class
, scm_class_top
, SCM_EOL
);
2462 make_stdcls (&scm_class_unknown
, "<unknown>",
2463 scm_class_class
, scm_class_top
, SCM_EOL
);
2464 make_stdcls (&scm_class_procedure
, "<procedure>",
2465 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2466 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2467 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2468 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2469 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2470 make_stdcls (&scm_class_port
, "<port>",
2471 scm_class_class
, scm_class_top
, SCM_EOL
);
2472 make_stdcls (&scm_class_input_port
, "<input-port>",
2473 scm_class_class
, scm_class_port
, SCM_EOL
);
2474 make_stdcls (&scm_class_output_port
, "<output-port>",
2475 scm_class_class
, scm_class_port
, SCM_EOL
);
2476 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2478 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2482 /**********************************************************************
2486 **********************************************************************/
2489 make_class_from_template (char *template, char *type_name
, SCM supers
, int applicablep
)
2495 sprintf (buffer
, template, type_name
);
2496 name
= scm_str2symbol (buffer
);
2499 name
= SCM_GOOPS_UNBOUND
;
2501 class = scm_permanent_object (scm_basic_make_class (applicablep
2502 ? scm_class_procedure_class
2508 /* Only define name if doesn't already exist. */
2509 if (!SCM_GOOPS_UNBOUNDP (name
)
2510 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2511 DEFVAR (name
, class);
2516 scm_make_extended_class (char *type_name
, int applicablep
)
2518 return make_class_from_template ("<%s>",
2520 scm_list_1 (applicablep
2521 ? scm_class_applicable
2527 scm_i_inherit_applicable (SCM c
)
2529 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2531 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2532 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2533 /* patch scm_class_applicable into direct-supers */
2534 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2535 if (SCM_FALSEP (top
))
2536 dsupers
= scm_append (scm_list_2 (dsupers
,
2537 scm_list_1 (scm_class_applicable
)));
2540 SCM_SETCAR (top
, scm_class_applicable
);
2541 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2543 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2544 /* patch scm_class_applicable into cpl */
2545 top
= scm_c_memq (scm_class_top
, cpl
);
2546 if (SCM_FALSEP (top
))
2550 SCM_SETCAR (top
, scm_class_applicable
);
2551 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2553 /* add class to direct-subclasses of scm_class_applicable */
2554 SCM_SET_SLOT (scm_class_applicable
,
2555 scm_si_direct_subclasses
,
2556 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2557 scm_si_direct_subclasses
)));
2562 create_smob_classes (void)
2566 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2567 for (i
= 0; i
< 255; ++i
)
2568 scm_smob_class
[i
] = 0;
2570 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2571 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2572 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2573 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2575 for (i
= 0; i
< scm_numsmob
; ++i
)
2576 if (!scm_smob_class
[i
])
2577 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2578 scm_smobs
[i
].apply
!= 0);
2582 scm_make_port_classes (long ptobnum
, char *type_name
)
2584 SCM c
, class = make_class_from_template ("<%s-port>",
2586 scm_list_1 (scm_class_port
),
2588 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2589 = make_class_from_template ("<%s-input-port>",
2591 scm_list_2 (class, scm_class_input_port
),
2593 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2594 = make_class_from_template ("<%s-output-port>",
2596 scm_list_2 (class, scm_class_output_port
),
2598 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2600 = make_class_from_template ("<%s-input-output-port>",
2602 scm_list_2 (class, scm_class_input_output_port
),
2604 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2605 SCM_SET_SLOT (c
, scm_si_cpl
,
2606 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2610 create_port_classes (void)
2614 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2615 for (i
= 0; i
< 3 * 256; ++i
)
2616 scm_port_class
[i
] = 0;
2618 for (i
= 0; i
< scm_numptob
; ++i
)
2619 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2623 make_struct_class (void *closure SCM_UNUSED
,
2624 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2626 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2627 SCM_SET_STRUCT_TABLE_CLASS (data
,
2628 scm_make_extended_class
2629 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
)),
2630 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2631 return SCM_UNSPECIFIED
;
2635 create_struct_classes (void)
2637 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2640 /**********************************************************************
2644 **********************************************************************/
2649 if (!goops_loaded_p
)
2650 scm_c_resolve_module ("oop goops");
2655 scm_make_foreign_object (SCM
class, SCM initargs
)
2656 #define FUNC_NAME s_scm_make
2658 void * (*constructor
) (SCM
)
2659 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2660 if (constructor
== 0)
2661 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2662 return scm_wrap_object (class, constructor (initargs
));
2668 scm_free_foreign_object (SCM
*class, SCM
*data
)
2670 size_t (*destructor
) (void *)
2671 = (size_t (*) (void *)) class[scm_si_destructor
];
2672 return destructor (data
);
2676 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2677 void * (*constructor
) (SCM initargs
),
2678 size_t (*destructor
) (void *))
2681 name
= scm_str2symbol (s_name
);
2682 if (SCM_NULLP (supers
))
2683 supers
= scm_list_1 (scm_class_foreign_object
);
2684 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2685 scm_sys_inherit_magic_x (class, supers
);
2687 if (destructor
!= 0)
2689 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2690 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2694 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2695 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2698 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2699 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2704 SCM_SYMBOL (sym_o
, "o");
2705 SCM_SYMBOL (sym_x
, "x");
2707 SCM_KEYWORD (k_accessor
, "accessor");
2708 SCM_KEYWORD (k_getter
, "getter");
2711 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2713 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2718 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2719 SCM (*getter
) (SCM obj
),
2720 SCM (*setter
) (SCM obj
, SCM x
),
2721 char *accessor_name
)
2724 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2725 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2726 setter
? setter
: default_setter
);
2727 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2728 scm_list_2 (get
, sym_o
)),
2730 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2731 scm_list_3 (set
, sym_o
, sym_x
)),
2734 SCM name
= scm_str2symbol (slot_name
);
2735 SCM aname
= scm_str2symbol (accessor_name
);
2736 SCM gf
= scm_ensure_accessor (aname
);
2737 SCM slot
= scm_list_5 (name
,
2740 setter
? k_accessor
: k_getter
,
2742 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2747 scm_add_method (scm_setter (gf
),
2748 scm_make (scm_list_5 (scm_class_accessor_method
,
2750 scm_list_2 (class, scm_class_top
),
2755 SCM_SET_SLOT (class, scm_si_slots
,
2756 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2757 scm_list_1 (slot
))));
2759 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2760 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, SCM_MAKINUM (1));
2761 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2762 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2763 scm_list_1 (gns
))));
2764 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (SCM_INUM (n
) + 1));
2771 scm_wrap_object (SCM
class, void *data
)
2773 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2781 scm_wrap_component (SCM
class, SCM container
, void *data
)
2783 SCM obj
= scm_wrap_object (class, data
);
2784 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2790 SCM_SETCDR (handle
, container
);
2795 scm_ensure_accessor (SCM name
)
2797 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2798 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2800 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2801 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2802 k_name
, name
, k_setter
, gf
));
2807 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2810 scm_add_method (SCM gf
, SCM m
)
2812 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2817 * Debugging utilities
2820 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2822 "Return @code{#t} if @var{obj} is a pure generic.")
2823 #define FUNC_NAME s_scm_pure_generic_p
2825 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2829 #endif /* GUILE_DEBUG */
2835 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2837 "Announce that GOOPS is loaded and perform initialization\n"
2838 "on the C level which depends on the loaded GOOPS modules.")
2839 #define FUNC_NAME s_scm_sys_goops_loaded
2842 var_compute_applicable_methods
=
2843 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2845 setup_extended_primitive_generics ();
2846 return SCM_UNSPECIFIED
;
2850 SCM scm_module_goops
;
2853 scm_init_goops_builtins (void)
2855 scm_module_goops
= scm_current_module ();
2856 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2858 /* Not really necessary right now, but who knows...
2860 scm_permanent_object (scm_module_goops
);
2861 scm_permanent_object (scm_goops_lookup_closure
);
2863 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2864 (SCM_MAKINUM (37)));
2866 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2868 #include "libguile/goops.x"
2870 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2872 hell
= scm_malloc (hell_size
);
2873 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2875 create_basic_classes ();
2876 create_standard_classes ();
2877 create_smob_classes ();
2878 create_struct_classes ();
2879 create_port_classes ();
2882 SCM name
= scm_str2symbol ("no-applicable-method");
2883 scm_no_applicable_method
2884 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2887 DEFVAR (name
, scm_no_applicable_method
);
2890 return SCM_UNSPECIFIED
;
2896 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2897 scm_init_goops_builtins
);