1 /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
43 /* This software is a derivative work of other copyrighted softwares; the
44 * copyright notices of these softwares are placed in the file COPYRIGHTS
46 * This file is based upon stklos.c from the STk distribution by
47 * Erick Gallesio <eg@unice.fr>.
52 #include "libguile/_scm.h"
53 #include "libguile/alist.h"
54 #include "libguile/debug.h"
55 #include "libguile/dynl.h"
56 #include "libguile/dynwind.h"
57 #include "libguile/eval.h"
58 #include "libguile/hashtab.h"
59 #include "libguile/keywords.h"
60 #include "libguile/macros.h"
61 #include "libguile/modules.h"
62 #include "libguile/objects.h"
63 #include "libguile/ports.h"
64 #include "libguile/procprop.h"
65 #include "libguile/random.h"
66 #include "libguile/root.h"
67 #include "libguile/smob.h"
68 #include "libguile/strings.h"
69 #include "libguile/strports.h"
70 #include "libguile/vectors.h"
71 #include "libguile/weaks.h"
73 #include "libguile/validate.h"
74 #include "libguile/goops.h"
76 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
78 #define DEFVAR(v, val) \
79 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
81 /* Temporary hack until we get the new module system */
82 /*fixme* Should optimize by keeping track of the variable object itself */
83 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
86 /* Fixme: Should use already interned symbols */
87 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \
89 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \
91 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \
93 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \
96 /* Class redefinition protocol:
98 A class is represented by a heap header h1 which points to a
99 malloc:ed memory block m1.
101 When a new version of a class is created, a new header h2 and
102 memory block m2 are allocated. The headers h1 and h2 then switch
103 pointers so that h1 refers to m2 and h2 to m1. In this way, names
104 bound to h1 will point to the new class at the same time as h2 will
105 be a handle which the GC will us to free m1.
107 The `redefined' slot of m1 will be set to point to h1. An old
108 instance will have it's class pointer (the CAR of the heap header)
109 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
110 the class modification and the new class pointer can be found via
114 /* The following definition is located in libguile/objects.h:
115 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
118 #define TEST_CHANGE_CLASS(obj, class) \
120 class = SCM_CLASS_OF (obj); \
121 if (SCM_OBJ_CLASS_REDEF (obj) != SCM_BOOL_F) \
122 CALL_GF3 ("change-object-class", \
123 obj, class, SCM_OBJ_CLASS_REDEF (obj)); \
126 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
127 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
129 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
130 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
132 static int goops_loaded_p
= 0;
133 static scm_t_rstate
*goops_rstate
;
135 static SCM scm_goops_lookup_closure
;
137 /* Some classes are defined in libguile/objects.c. */
138 SCM scm_class_top
, scm_class_object
, scm_class_class
;
139 SCM scm_class_entity
, scm_class_entity_with_setter
;
140 SCM scm_class_generic
, scm_class_generic_with_setter
, scm_class_method
;
141 SCM scm_class_simple_method
, scm_class_accessor
;
142 SCM scm_class_procedure_class
;
143 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
144 SCM scm_class_entity_class
;
145 SCM scm_class_number
, scm_class_list
;
146 SCM scm_class_keyword
;
147 SCM scm_class_port
, scm_class_input_output_port
;
148 SCM scm_class_input_port
, scm_class_output_port
;
149 SCM scm_class_foreign_class
, scm_class_foreign_object
;
150 SCM scm_class_foreign_slot
;
151 SCM scm_class_self
, scm_class_protected
;
152 SCM scm_class_opaque
, scm_class_read_only
;
153 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
155 SCM scm_class_int
, scm_class_float
, scm_class_double
;
157 SCM_SYMBOL (scm_sym_define_public
, "define-public");
159 static SCM
scm_make_unbound (void);
160 static SCM
scm_unbound_p (SCM obj
);
161 static SCM
scm_assert_bound (SCM value
, SCM obj
);
162 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
163 static SCM
scm_sys_goops_loaded (void);
165 /******************************************************************************
169 * This version doesn't handle multiple-inheritance. It serves only for
170 * booting classes and will be overloaded in Scheme
172 ******************************************************************************/
176 compute_cpl (SCM supers
, SCM res
)
178 return (SCM_NULLP (supers
)
180 : compute_cpl (SCM_SLOT (SCM_CAR (supers
), scm_si_direct_supers
),
181 scm_cons (SCM_CAR (supers
), res
)));
186 map (SCM (*proc
) (SCM
), SCM ls
)
192 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
195 while (!SCM_NULLP (ls
))
197 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
209 while (!SCM_NULLP (ls
))
211 SCM el
= SCM_CAR (ls
);
212 if (SCM_FALSEP (scm_c_memq (el
, res
)))
213 res
= scm_cons (el
, res
);
220 compute_cpl (SCM
class)
223 return CALL_GF1 ("compute-cpl", class);
226 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
227 SCM ls
= scm_append (scm_acons (class, supers
,
228 map (compute_cpl
, supers
)));
229 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
233 /******************************************************************************
237 ******************************************************************************/
240 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
248 if (!SCM_SYMBOLP (tmp
))
249 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
251 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
252 res
= scm_cons (SCM_CAR (l
), res
);
253 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
256 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
260 build_slots_list (SCM dslots
, SCM cpl
)
262 register SCM res
= dslots
;
264 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
265 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
266 scm_si_direct_slots
),
269 /* res contains a list of slots. Remove slots which appears more than once */
270 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
277 while (!SCM_NULLP (ls
))
279 if (!SCM_CONSP (SCM_CAR (ls
)))
280 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
287 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
289 "Return a list consisting of the names of all slots belonging to\n"
290 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
292 #define FUNC_NAME s_scm_sys_compute_slots
294 SCM_VALIDATE_CLASS (1, class);
295 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
296 SCM_SLOT (class, scm_si_cpl
));
301 /******************************************************************************
303 * compute-getters-n-setters
305 * This version doesn't handle slot options. It serves only for booting
306 * classes and will be overloaded in Scheme.
308 ******************************************************************************/
310 SCM_KEYWORD (k_init_value
, "init-value");
311 SCM_KEYWORD (k_init_thunk
, "init-thunk");
314 compute_getters_n_setters (SCM slots
)
320 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
322 SCM init
= SCM_BOOL_F
;
323 SCM options
= SCM_CDAR (slots
);
324 if (!SCM_NULLP (options
))
326 init
= scm_get_keyword (k_init_value
, options
, 0);
328 init
= scm_closure (scm_list_2 (SCM_EOL
, init
), SCM_EOL
);
330 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
332 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
336 cdrloc
= SCM_CDRLOC (*cdrloc
);
341 /******************************************************************************
345 ******************************************************************************/
347 /*fixme* Manufacture keywords in advance */
349 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
353 for (i
= 0; i
!= len
; i
+= 2)
355 SCM obj
= SCM_CAR (l
);
357 if (!SCM_KEYWORDP (obj
))
358 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
359 else if (SCM_EQ_P (obj
, key
))
365 return default_value
;
369 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
370 (SCM key
, SCM l
, SCM default_value
),
371 "Determine an associated value for the keyword @var{key} from\n"
372 "the list @var{l}. The list @var{l} has to consist of an even\n"
373 "number of elements, where, starting with the first, every\n"
374 "second element is a keyword, followed by its associated value.\n"
375 "If @var{l} does not hold a value for @var{key}, the value\n"
376 "@var{default_value} is returned.")
377 #define FUNC_NAME s_scm_get_keyword
381 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
382 len
= scm_ilength (l
);
383 if (len
< 0 || len
% 2 == 1)
384 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
386 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
391 SCM_KEYWORD (k_init_keyword
, "init-keyword");
393 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
394 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
396 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
397 (SCM obj
, SCM initargs
),
398 "Initialize the object @var{obj} with the given arguments\n"
400 #define FUNC_NAME s_scm_sys_initialize_object
402 SCM tmp
, get_n_set
, slots
;
403 SCM
class = SCM_CLASS_OF (obj
);
406 SCM_VALIDATE_INSTANCE (1, obj
);
407 n_initargs
= scm_ilength (initargs
);
408 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
410 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
411 slots
= SCM_SLOT (class, scm_si_slots
);
413 /* See for each slot how it must be initialized */
416 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
418 SCM slot_name
= SCM_CAR (slots
);
421 if (!SCM_NULLP (SCM_CDR (slot_name
)))
423 /* This slot admits (perhaps) to be initialized at creation time */
424 long n
= scm_ilength (SCM_CDR (slot_name
));
425 if (n
& 1) /* odd or -1 */
426 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
427 scm_list_1 (slot_name
));
428 tmp
= scm_i_get_keyword (k_init_keyword
,
433 slot_name
= SCM_CAR (slot_name
);
436 /* an initarg was provided for this slot */
437 if (!SCM_KEYWORDP (tmp
))
438 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
440 slot_value
= scm_i_get_keyword (tmp
,
449 /* set slot to provided value */
450 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
453 /* set slot to its :init-form if it exists */
454 tmp
= SCM_CADAR (get_n_set
);
455 if (tmp
!= SCM_BOOL_F
)
457 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
458 if (SCM_GOOPS_UNBOUNDP (slot_value
))
460 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
461 set_slot_value (class,
464 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
475 SCM_KEYWORD (k_class
, "class");
477 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
480 #define FUNC_NAME s_scm_sys_prep_layout_x
483 unsigned long int n
, i
;
486 SCM_VALIDATE_INSTANCE (1, class);
487 slots
= SCM_SLOT (class, scm_si_slots
);
488 nfields
= SCM_SLOT (class, scm_si_nfields
);
489 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
490 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
491 scm_list_1 (nfields
));
492 n
= 2 * SCM_INUM (nfields
);
493 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
494 && SCM_SUBCLASSP (class, scm_class_class
))
495 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
496 scm_list_1 (nfields
));
498 s
= n
> 0 ? scm_malloc (n
) : 0;
499 for (i
= 0; i
< n
; i
+= 2)
505 if (!SCM_CONSP (slots
))
506 SCM_MISC_ERROR ("too few slot definitions", SCM_EOL
);
507 len
= scm_ilength (SCM_CDAR (slots
));
508 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
), len
, SCM_BOOL_F
,
510 if (SCM_FALSEP (type
))
517 if (!SCM_CLASSP (type
))
518 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
519 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
521 if (SCM_SUBCLASSP (type
, scm_class_self
))
523 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
528 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
530 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
543 slots
= SCM_CDR (slots
);
545 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
548 return SCM_UNSPECIFIED
;
552 static void prep_hashsets (SCM
);
554 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
555 (SCM
class, SCM dsupers
),
557 #define FUNC_NAME s_scm_sys_inherit_magic_x
561 SCM_VALIDATE_INSTANCE (1, class);
562 while (!SCM_NULLP (ls
))
564 SCM_ASSERT (SCM_CONSP (ls
)
565 && SCM_INSTANCEP (SCM_CAR (ls
)),
569 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
572 flags
&= SCM_CLASSF_INHERIT
;
573 if (flags
& SCM_CLASSF_ENTITY
)
574 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
577 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
580 * We could avoid calling scm_gc_malloc in the allocation code
581 * (in which case the following two lines are needed). Instead
582 * we make 0-slot instances non-light, so that the light case
583 * can be handled without special cases.
586 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
588 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
590 /* NOTE: The following depends on scm_struct_i_size. */
591 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
592 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
595 SCM_SET_CLASS_FLAGS (class, flags
);
597 prep_hashsets (class);
599 return SCM_UNSPECIFIED
;
604 prep_hashsets (SCM
class)
608 for (i
= 0; i
< 7; ++i
)
609 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
612 /******************************************************************************/
615 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
617 SCM z
, cpl
, slots
, nfields
, g_n_s
;
619 /* Allocate one instance */
620 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
622 /* Initialize its slots */
624 cpl
= compute_cpl (dsupers
, scm_list_1 (z
));
626 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
627 cpl
= compute_cpl (z
);
628 slots
= build_slots_list (maplist (dslots
), cpl
);
629 nfields
= SCM_MAKINUM (scm_ilength (slots
));
630 g_n_s
= compute_getters_n_setters (slots
);
632 SCM_SET_SLOT (z
, scm_si_name
, name
);
633 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
634 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
635 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
636 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
637 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
638 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
639 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
640 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
641 SCM_SET_SLOT (z
, scm_si_environment
,
642 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
644 /* Add this class in the direct-subclasses slot of dsupers */
647 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
648 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
649 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
650 scm_si_direct_subclasses
)));
653 /* Support for the underlying structs: */
654 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
655 ? (SCM_CLASSF_GOOPS_OR_VALID
656 | SCM_CLASSF_OPERATOR
658 : class == scm_class_operator_class
659 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
660 : SCM_CLASSF_GOOPS_OR_VALID
));
665 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
667 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
668 scm_sys_inherit_magic_x (z
, dsupers
);
669 scm_sys_prep_layout_x (z
);
673 /******************************************************************************/
675 SCM_SYMBOL (sym_layout
, "layout");
676 SCM_SYMBOL (sym_vcell
, "vcell");
677 SCM_SYMBOL (sym_vtable
, "vtable");
678 SCM_SYMBOL (sym_print
, "print");
679 SCM_SYMBOL (sym_procedure
, "procedure");
680 SCM_SYMBOL (sym_setter
, "setter");
681 SCM_SYMBOL (sym_redefined
, "redefined");
682 SCM_SYMBOL (sym_h0
, "h0");
683 SCM_SYMBOL (sym_h1
, "h1");
684 SCM_SYMBOL (sym_h2
, "h2");
685 SCM_SYMBOL (sym_h3
, "h3");
686 SCM_SYMBOL (sym_h4
, "h4");
687 SCM_SYMBOL (sym_h5
, "h5");
688 SCM_SYMBOL (sym_h6
, "h6");
689 SCM_SYMBOL (sym_h7
, "h7");
690 SCM_SYMBOL (sym_name
, "name");
691 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
692 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
693 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
694 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
695 SCM_SYMBOL (sym_cpl
, "cpl");
696 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
697 SCM_SYMBOL (sym_slots
, "slots");
698 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
699 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
700 SCM_SYMBOL (sym_nfields
, "nfields");
701 SCM_SYMBOL (sym_environment
, "environment");
705 build_class_class_slots ()
708 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
709 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
710 scm_list_1 (sym_print
),
711 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
712 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
713 scm_list_1 (sym_redefined
),
714 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
715 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
716 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
717 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
718 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
719 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
720 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
721 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
722 scm_list_1 (sym_name
),
723 scm_list_1 (sym_direct_supers
),
724 scm_list_1 (sym_direct_slots
),
725 scm_list_1 (sym_direct_subclasses
),
726 scm_list_1 (sym_direct_methods
),
727 scm_list_1 (sym_cpl
),
728 scm_list_1 (sym_default_slot_definition_class
),
729 scm_list_1 (sym_slots
),
730 scm_list_1 (sym_getters_n_setters
),
731 scm_list_1 (sym_keyword_access
),
732 scm_list_1 (sym_nfields
),
733 scm_list_1 (sym_environment
),
738 create_basic_classes (void)
740 /* SCM slots_of_class = build_class_class_slots (); */
742 /**** <scm_class_class> ****/
743 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
744 + 2 * scm_vtable_offset_user
);
745 SCM name
= scm_str2symbol ("<class>");
746 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
749 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
750 | SCM_CLASSF_METACLASS
));
752 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
753 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
754 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
755 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
756 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
757 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
758 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
759 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
760 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
761 compute_getters_n_setters (slots_of_class)); */
762 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
763 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
764 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
766 prep_hashsets (scm_class_class
);
768 DEFVAR(name
, scm_class_class
);
770 /**** <scm_class_top> ****/
771 name
= scm_str2symbol ("<top>");
772 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
777 DEFVAR(name
, scm_class_top
);
779 /**** <scm_class_object> ****/
780 name
= scm_str2symbol ("<object>");
781 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
783 scm_list_1 (scm_class_top
),
786 DEFVAR (name
, scm_class_object
);
788 /* <top> <object> and <class> were partially initialized. Correct them here */
789 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
791 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
792 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
795 /******************************************************************************/
797 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
799 "Return @code{#t} if @var{obj} is an instance.")
800 #define FUNC_NAME s_scm_instance_p
802 return SCM_BOOL (SCM_INSTANCEP (obj
));
807 /******************************************************************************
809 * Meta object accessors
811 ******************************************************************************/
812 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
814 "Return the class name of @var{obj}.")
815 #define FUNC_NAME s_scm_class_name
817 SCM_VALIDATE_CLASS (1, obj
);
818 return scm_slot_ref (obj
, sym_name
);
822 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
824 "Return the direct superclasses of the class @var{obj}.")
825 #define FUNC_NAME s_scm_class_direct_supers
827 SCM_VALIDATE_CLASS (1, obj
);
828 return scm_slot_ref (obj
, sym_direct_supers
);
832 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
834 "Return the direct slots of the class @var{obj}.")
835 #define FUNC_NAME s_scm_class_direct_slots
837 SCM_VALIDATE_CLASS (1, obj
);
838 return scm_slot_ref (obj
, sym_direct_slots
);
842 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
844 "Return the direct subclasses of the class @var{obj}.")
845 #define FUNC_NAME s_scm_class_direct_subclasses
847 SCM_VALIDATE_CLASS (1, obj
);
848 return scm_slot_ref(obj
, sym_direct_subclasses
);
852 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
854 "Return the direct methods of the class @var{obj}")
855 #define FUNC_NAME s_scm_class_direct_methods
857 SCM_VALIDATE_CLASS (1, obj
);
858 return scm_slot_ref (obj
, sym_direct_methods
);
862 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
864 "Return the class precedence list of the class @var{obj}.")
865 #define FUNC_NAME s_scm_class_precedence_list
867 SCM_VALIDATE_CLASS (1, obj
);
868 return scm_slot_ref (obj
, sym_cpl
);
872 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
874 "Return the slot list of the class @var{obj}.")
875 #define FUNC_NAME s_scm_class_slots
877 SCM_VALIDATE_CLASS (1, obj
);
878 return scm_slot_ref (obj
, sym_slots
);
882 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
884 "Return the environment of the class @var{obj}.")
885 #define FUNC_NAME s_scm_class_environment
887 SCM_VALIDATE_CLASS (1, obj
);
888 return scm_slot_ref(obj
, sym_environment
);
893 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
895 "Return the name of the generic function @var{obj}.")
896 #define FUNC_NAME s_scm_generic_function_name
898 SCM_VALIDATE_GENERIC (1, obj
);
899 return scm_procedure_property (obj
, scm_sym_name
);
903 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
905 "Return the methods of the generic function @var{obj}.")
906 #define FUNC_NAME s_scm_generic_function_methods
908 SCM_VALIDATE_GENERIC (1, obj
);
909 return scm_slot_ref (obj
, scm_str2symbol ("methods"));
914 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
916 "Return the generic function for the method @var{obj}.")
917 #define FUNC_NAME s_scm_method_generic_function
919 SCM_VALIDATE_METHOD (1, obj
);
920 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
924 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
926 "Return specializers of the method @var{obj}.")
927 #define FUNC_NAME s_scm_method_specializers
929 SCM_VALIDATE_METHOD (1, obj
);
930 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
934 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
936 "Return the procedure of the method @var{obj}.")
937 #define FUNC_NAME s_scm_method_procedure
939 SCM_VALIDATE_METHOD (1, obj
);
940 return scm_slot_ref (obj
, sym_procedure
);
944 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
946 "Return the slot definition of the accessor @var{obj}.")
947 #define FUNC_NAME s_scm_accessor_method_slot_definition
949 SCM_VALIDATE_ACCESSOR (1, obj
);
950 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
954 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
956 "Internal GOOPS magic---don't use this function!")
957 #define FUNC_NAME s_scm_sys_tag_body
959 return scm_cons (SCM_IM_LAMBDA
, body
);
963 /******************************************************************************
965 * S l o t a c c e s s
967 ******************************************************************************/
969 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
971 "Return the unbound value.")
972 #define FUNC_NAME s_scm_make_unbound
974 return SCM_GOOPS_UNBOUND
;
978 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
980 "Return @code{#t} if @var{obj} is unbound.")
981 #define FUNC_NAME s_scm_unbound_p
983 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
987 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
988 (SCM value
, SCM obj
),
989 "Return @var{value} if it is bound, and invoke the\n"
990 "@var{slot-unbound} method of @var{obj} if it is not.")
991 #define FUNC_NAME s_scm_assert_bound
993 if (SCM_GOOPS_UNBOUNDP (value
))
994 return CALL_GF1 ("slot-unbound", obj
);
999 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1000 (SCM obj
, SCM index
),
1001 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1002 "the value from @var{obj}.")
1003 #define FUNC_NAME s_scm_at_assert_bound_ref
1005 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1006 if (SCM_GOOPS_UNBOUNDP (value
))
1007 return CALL_GF1 ("slot-unbound", obj
);
1012 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1013 (SCM obj
, SCM index
),
1014 "Return the slot value with index @var{index} from @var{obj}.")
1015 #define FUNC_NAME s_scm_sys_fast_slot_ref
1017 unsigned long int i
;
1019 SCM_VALIDATE_INSTANCE (1, obj
);
1020 SCM_VALIDATE_INUM (2, index
);
1021 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1022 i
= SCM_INUM (index
);
1023 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1025 return scm_at_assert_bound_ref (obj
, index
);
1029 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1030 (SCM obj
, SCM index
, SCM value
),
1031 "Set the slot with index @var{index} in @var{obj} to\n"
1033 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1035 unsigned long int i
;
1037 SCM_VALIDATE_INSTANCE (1, obj
);
1038 SCM_VALIDATE_INUM (2, index
);
1039 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1040 i
= SCM_INUM (index
);
1041 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1043 SCM_SET_SLOT (obj
, i
, value
);
1045 return SCM_UNSPECIFIED
;
1052 /* In the future, this function will return the effective slot
1053 * definition associated with SLOT_NAME. Now it just returns some of
1054 * the information which will be stored in the effective slot
1059 slot_definition_using_name (SCM
class, SCM slot_name
)
1061 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1062 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1063 if (SCM_CAAR (slots
) == slot_name
)
1064 return SCM_CAR (slots
);
1069 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1071 SCM access
= SCM_CDDR (slotdef
);
1073 * - access is an integer (the offset of this slot in the slots vector)
1074 * - otherwise (car access) is the getter function to apply
1076 if (SCM_INUMP (access
))
1077 return SCM_SLOT (obj
, SCM_INUM (access
));
1080 /* We must evaluate (apply (car access) (list obj))
1081 * where (car access) is known to be a closure of arity 1 */
1082 register SCM code
, env
;
1084 code
= SCM_CAR (access
);
1085 if (!SCM_CLOSUREP (code
))
1086 return SCM_SUBRF (code
) (obj
);
1087 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1090 /* Evaluate the closure body */
1091 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1096 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1098 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1099 if (!SCM_FALSEP (slotdef
))
1100 return get_slot_value (class, obj
, slotdef
);
1102 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1106 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1108 SCM access
= SCM_CDDR (slotdef
);
1110 * - access is an integer (the offset of this slot in the slots vector)
1111 * - otherwise (cadr access) is the setter function to apply
1113 if (SCM_INUMP (access
))
1114 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1117 /* We must evaluate (apply (cadr l) (list obj value))
1118 * where (cadr l) is known to be a closure of arity 2 */
1119 register SCM code
, env
;
1121 code
= SCM_CADR (access
);
1122 if (!SCM_CLOSUREP (code
))
1123 SCM_SUBRF (code
) (obj
, value
);
1126 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1127 scm_list_2 (obj
, value
),
1129 /* Evaluate the closure body */
1130 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1133 return SCM_UNSPECIFIED
;
1137 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1139 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1140 if (!SCM_FALSEP (slotdef
))
1141 return set_slot_value (class, obj
, slotdef
, value
);
1143 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1147 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1151 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1152 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1158 /* ======================================== */
1160 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1161 (SCM
class, SCM obj
, SCM slot_name
),
1163 #define FUNC_NAME s_scm_slot_ref_using_class
1167 SCM_VALIDATE_CLASS (1, class);
1168 SCM_VALIDATE_INSTANCE (2, obj
);
1169 SCM_VALIDATE_SYMBOL (3, slot_name
);
1171 res
= get_slot_value_using_name (class, obj
, slot_name
);
1172 if (SCM_GOOPS_UNBOUNDP (res
))
1173 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1179 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1180 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1182 #define FUNC_NAME s_scm_slot_set_using_class_x
1184 SCM_VALIDATE_CLASS (1, class);
1185 SCM_VALIDATE_INSTANCE (2, obj
);
1186 SCM_VALIDATE_SYMBOL (3, slot_name
);
1188 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1193 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1194 (SCM
class, SCM obj
, SCM slot_name
),
1196 #define FUNC_NAME s_scm_slot_bound_using_class_p
1198 SCM_VALIDATE_CLASS (1, class);
1199 SCM_VALIDATE_INSTANCE (2, obj
);
1200 SCM_VALIDATE_SYMBOL (3, slot_name
);
1202 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1208 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1209 (SCM
class, SCM obj
, SCM slot_name
),
1211 #define FUNC_NAME s_scm_slot_exists_using_class_p
1213 SCM_VALIDATE_CLASS (1, class);
1214 SCM_VALIDATE_INSTANCE (2, obj
);
1215 SCM_VALIDATE_SYMBOL (3, slot_name
);
1216 return test_slot_existence (class, obj
, slot_name
);
1221 /* ======================================== */
1223 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1224 (SCM obj
, SCM slot_name
),
1225 "Return the value from @var{obj}'s slot with the name\n"
1227 #define FUNC_NAME s_scm_slot_ref
1231 SCM_VALIDATE_INSTANCE (1, obj
);
1232 TEST_CHANGE_CLASS (obj
, class);
1234 res
= get_slot_value_using_name (class, obj
, slot_name
);
1235 if (SCM_GOOPS_UNBOUNDP (res
))
1236 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1241 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1242 (SCM obj
, SCM slot_name
, SCM value
),
1243 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1244 #define FUNC_NAME s_scm_slot_set_x
1248 SCM_VALIDATE_INSTANCE (1, obj
);
1249 TEST_CHANGE_CLASS(obj
, class);
1251 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1255 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1257 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1258 (SCM obj
, SCM slot_name
),
1259 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1261 #define FUNC_NAME s_scm_slot_bound_p
1265 SCM_VALIDATE_INSTANCE (1, obj
);
1266 TEST_CHANGE_CLASS(obj
, class);
1268 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1276 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1277 (SCM obj
, SCM slot_name
),
1278 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1279 #define FUNC_NAME s_scm_slot_exists_p
1283 SCM_VALIDATE_INSTANCE (1, obj
);
1284 SCM_VALIDATE_SYMBOL (2, slot_name
);
1285 TEST_CHANGE_CLASS (obj
, class);
1287 return test_slot_existence (class, obj
, slot_name
);
1292 /******************************************************************************
1294 * %allocate-instance (the low level instance allocation primitive)
1296 ******************************************************************************/
1298 static void clear_method_cache (SCM
);
1301 wrap_init (SCM
class, SCM
*m
, long n
)
1305 /* Set all slots to unbound */
1306 for (i
= 0; i
< n
; i
++)
1307 m
[i
] = SCM_GOOPS_UNBOUND
;
1309 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1311 (scm_t_bits
) m
, 0, 0);
1314 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1315 (SCM
class, SCM initargs
),
1316 "Create a new instance of class @var{class} and initialize it\n"
1317 "from the arguments @var{initargs}.")
1318 #define FUNC_NAME s_scm_sys_allocate_instance
1323 SCM_VALIDATE_CLASS (1, class);
1325 /* Most instances */
1326 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1328 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1329 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1330 return wrap_init (class, m
, n
);
1333 /* Foreign objects */
1334 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1335 return scm_make_foreign_object (class, initargs
);
1337 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1340 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1342 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1344 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1345 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1346 /* Generic functions */
1347 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1349 SCM gf
= wrap_init (class, m
, n
);
1350 clear_method_cache (gf
);
1354 return wrap_init (class, m
, n
);
1358 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1362 /* allocate class object */
1363 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1365 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1366 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1367 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1369 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1370 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1371 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1372 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1377 /* Non-light instances */
1379 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1380 return wrap_init (class, m
, n
);
1385 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1386 (SCM obj
, SCM setter
),
1388 #define FUNC_NAME s_scm_sys_set_object_setter_x
1390 SCM_ASSERT (SCM_STRUCTP (obj
)
1391 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1392 || SCM_I_ENTITYP (obj
)),
1396 if (SCM_I_ENTITYP (obj
))
1397 SCM_SET_ENTITY_SETTER (obj
, setter
);
1399 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1400 return SCM_UNSPECIFIED
;
1404 /******************************************************************************
1406 * %modify-instance (used by change-class to modify in place)
1408 ******************************************************************************/
1410 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1413 #define FUNC_NAME s_scm_sys_modify_instance
1415 SCM_VALIDATE_INSTANCE (1, old
);
1416 SCM_VALIDATE_INSTANCE (2, new);
1418 /* Exchange the data contained in old and new. We exchange rather than
1419 * scratch the old value with new to be correct with GC.
1420 * See "Class redefinition protocol above".
1424 SCM car
= SCM_CAR (old
);
1425 SCM cdr
= SCM_CDR (old
);
1426 SCM_SETCAR (old
, SCM_CAR (new));
1427 SCM_SETCDR (old
, SCM_CDR (new));
1428 SCM_SETCAR (new, car
);
1429 SCM_SETCDR (new, cdr
);
1432 return SCM_UNSPECIFIED
;
1436 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1439 #define FUNC_NAME s_scm_sys_modify_class
1441 SCM_VALIDATE_CLASS (1, old
);
1442 SCM_VALIDATE_CLASS (2, new);
1446 SCM car
= SCM_CAR (old
);
1447 SCM cdr
= SCM_CDR (old
);
1448 SCM_SETCAR (old
, SCM_CAR (new));
1449 SCM_SETCDR (old
, SCM_CDR (new));
1450 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1451 SCM_SETCAR (new, car
);
1452 SCM_SETCDR (new, cdr
);
1453 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1456 return SCM_UNSPECIFIED
;
1460 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1463 #define FUNC_NAME s_scm_sys_invalidate_class
1465 SCM_VALIDATE_CLASS (1, class);
1466 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1467 return SCM_UNSPECIFIED
;
1471 /* When instances change class, they finally get a new body, but
1472 * before that, they go through purgatory in hell. Odd as it may
1473 * seem, this data structure saves us from eternal suffering in
1474 * infinite recursions.
1477 static scm_t_bits
**hell
;
1478 static long n_hell
= 1; /* one place for the evil one himself */
1479 static long hell_size
= 4;
1481 static scm_t_mutex hell_mutex
;
1488 for (i
= 1; i
< n_hell
; ++i
)
1489 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1495 go_to_hell (void *o
)
1497 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1499 scm_mutex_lock (&hell_mutex
);
1501 if (n_hell
== hell_size
)
1503 long new_size
= 2 * hell_size
;
1504 hell
= scm_realloc (hell
, new_size
);
1505 hell_size
= new_size
;
1507 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1509 scm_mutex_unlock (&hell_mutex
);
1514 go_to_heaven (void *o
)
1517 scm_mutex_lock (&hell_mutex
);
1519 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1521 scm_mutex_unlock (&hell_mutex
);
1526 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1529 purgatory (void *args
)
1531 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1532 SCM_PACK ((scm_t_bits
) args
));
1536 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1539 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1540 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1541 (void *) SCM_UNPACK (obj
));
1544 /******************************************************************************
1550 * GGG E N E R I C F U N C T I O N S
1552 * This implementation provides
1553 * - generic functions (with class specializers)
1556 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1558 ******************************************************************************/
1560 SCM_KEYWORD (k_name
, "name");
1562 SCM_SYMBOL (sym_no_method
, "no-method");
1564 static SCM list_of_no_method
;
1566 SCM_SYMBOL (scm_sym_args
, "args");
1569 scm_make_method_cache (SCM gf
)
1571 return scm_list_5 (SCM_IM_DISPATCH
,
1574 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1580 clear_method_cache (SCM gf
)
1582 SCM cache
= scm_make_method_cache (gf
);
1583 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1584 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1587 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1590 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1593 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1594 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1595 if (!SCM_FALSEP (used_by
))
1597 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1598 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1599 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1600 clear_method_cache (gf
);
1601 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1602 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1605 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1606 /* The sign of n is a flag indicating rest args. */
1607 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1609 return SCM_UNSPECIFIED
;
1613 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1616 #define FUNC_NAME s_scm_generic_capability_p
1618 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1619 proc
, SCM_ARG1
, FUNC_NAME
);
1620 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1626 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1629 #define FUNC_NAME s_scm_enable_primitive_generic_x
1631 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1632 while (!SCM_NULLP (subrs
))
1634 SCM subr
= SCM_CAR (subrs
);
1635 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1636 subr
, SCM_ARGn
, FUNC_NAME
);
1637 *SCM_SUBR_GENERIC (subr
)
1638 = scm_make (scm_list_3 (scm_class_generic
,
1641 subrs
= SCM_CDR (subrs
);
1643 return SCM_UNSPECIFIED
;
1647 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1650 #define FUNC_NAME s_scm_primitive_generic_generic
1652 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1654 SCM gf
= *SCM_SUBR_GENERIC (subr
);
1658 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1662 /******************************************************************************
1664 * Protocol for calling a generic fumction
1665 * This protocol is roughly equivalent to (parameter are a little bit different
1666 * for efficiency reasons):
1668 * + apply-generic (gf args)
1669 * + compute-applicable-methods (gf args ...)
1670 * + sort-applicable-methods (methods args)
1671 * + apply-methods (gf methods args)
1673 * apply-methods calls make-next-method to build the "continuation" of a a
1674 * method. Applying a next-method will call apply-next-method which in
1675 * turn will call apply again to call effectively the following method.
1677 ******************************************************************************/
1680 applicablep (SCM actual
, SCM formal
)
1682 /* We already know that the cpl is well formed. */
1683 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1687 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1689 register SCM s1
, s2
;
1693 * m1 and m2 can have != length (i.e. one can be one element longer than the
1694 * other when we have a dotted parameter list). For instance, with the call
1697 * (define-method M (a . l) ....)
1698 * (define-method M (a) ....)
1700 * we consider that the second method is more specific.
1702 * BTW, targs is an array of types. We don't need it's size since
1703 * we already know that m1 and m2 are applicable (no risk to go past
1704 * the end of this array).
1707 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1708 if (SCM_NULLP(s1
)) return 1;
1709 if (SCM_NULLP(s2
)) return 0;
1710 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1711 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1713 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1714 if (cs1
== SCM_CAR(l
))
1716 if (cs2
== SCM_CAR(l
))
1719 return 0;/* should not occur! */
1722 return 0; /* should not occur! */
1725 #define BUFFSIZE 32 /* big enough for most uses */
1728 scm_i_vector2list (SCM l
, long len
)
1731 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1733 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1734 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1740 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1743 SCM
*v
, vector
= SCM_EOL
;
1744 SCM buffer
[BUFFSIZE
];
1745 SCM save
= method_list
;
1747 /* For reasonably sized method_lists we can try to avoid all the
1748 * consing and reorder the list in place...
1749 * This idea is due to David McClain <Dave_McClain@msn.com>
1751 if (size
<= BUFFSIZE
)
1753 for (i
= 0; i
< size
; i
++)
1755 buffer
[i
] = SCM_CAR (method_list
);
1756 method_list
= SCM_CDR (method_list
);
1762 /* Too many elements in method_list to keep everything locally */
1763 vector
= scm_i_vector2list (save
, size
);
1766 This is a new vector. Don't worry about the write barrier.
1767 We're not allocating elements in this routine, so this should
1770 v
= SCM_WRITABLE_VELTS (vector
);
1773 /* Use a simple shell sort since it is generally faster than qsort on
1774 * small vectors (which is probably mostly the case when we have to
1775 * sort a list of applicable methods).
1777 for (incr
= size
/ 2; incr
; incr
/= 2)
1779 for (i
= incr
; i
< size
; i
++)
1781 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1783 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1787 SCM tmp
= v
[j
+ incr
];
1795 if (size
<= BUFFSIZE
)
1797 /* We did it in locally, so restore the original list (reordered) in-place */
1798 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1800 SCM_SETCAR (method_list
, *v
);
1801 method_list
= SCM_CDR (method_list
);
1805 /* If we are here, that's that we did it the hard way... */
1806 return scm_vector_to_list (vector
);
1810 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1814 SCM l
, fl
, applicable
= SCM_EOL
;
1816 SCM buffer
[BUFFSIZE
];
1821 /* Build the list of arguments types */
1822 if (len
>= BUFFSIZE
) {
1823 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1824 /* NOTE: Using pointers to malloced memory won't work if we
1825 1. have preemtive threading, and,
1826 2. have a GC which moves objects. */
1827 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1830 note that we don't have to work to reset the generation
1831 count. TMP is a new vector anyway, and it is found
1838 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1839 *p
++ = scm_class_of (SCM_CAR (args
));
1841 /* Build a list of all applicable methods */
1842 for (l
= SCM_SLOT (gf
, scm_si_methods
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1844 fl
= SPEC_OF (SCM_CAR (l
));
1845 /* Only accept accessors which match exactly in first arg. */
1846 if (SCM_ACCESSORP (SCM_CAR (l
))
1847 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1849 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1851 if (SCM_INSTANCEP (fl
)
1852 /* We have a dotted argument list */
1853 || (i
>= len
&& SCM_NULLP (fl
)))
1854 { /* both list exhausted */
1855 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1861 || !applicablep (types
[i
], SCM_CAR (fl
)))
1870 CALL_GF2 ("no-applicable-method", gf
, save
);
1871 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1875 scm_remember_upto_here (tmp
);
1878 : sort_applicable_methods (applicable
, count
, types
));
1882 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1885 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1888 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1889 #define FUNC_NAME s_sys_compute_applicable_methods
1892 SCM_VALIDATE_GENERIC (1, gf
);
1893 n
= scm_ilength (args
);
1894 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1895 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1899 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1900 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
));
1902 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1905 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1906 #define FUNC_NAME s_atslot_ref
1908 SCM x
= SCM_CDR (xorig
);
1909 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1910 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1911 return scm_cons (SCM_IM_SLOT_REF
, x
);
1916 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1919 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1920 #define FUNC_NAME s_atslot_set_x
1922 SCM x
= SCM_CDR (xorig
);
1923 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1924 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1925 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1930 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1932 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1935 scm_m_atdispatch (SCM xorig
, SCM env
)
1936 #define FUNC_NAME s_atdispatch
1938 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1939 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
1941 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
1942 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
1944 n
= SCM_XEVALCAR (x
, env
);
1945 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
1946 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1948 v
= SCM_XEVALCAR (x
, env
);
1949 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
1951 gf
= SCM_XEVALCAR (x
, env
);
1952 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
1953 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1960 lock_cache_mutex (void *m
)
1962 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
1963 scm_lock_mutex (mutex
);
1967 unlock_cache_mutex (void *m
)
1969 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
1970 scm_unlock_mutex (mutex
);
1975 call_memoize_method (void *a
)
1977 SCM args
= SCM_PACK ((scm_t_bits
) a
);
1978 SCM gf
= SCM_CAR (args
);
1979 SCM x
= SCM_CADR (args
);
1980 /* First check if another thread has inserted a method between
1981 * the cache miss and locking the mutex.
1983 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
1984 if (!SCM_FALSEP (cmethod
))
1986 /*fixme* Use scm_apply */
1987 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
1991 scm_memoize_method (SCM x
, SCM args
)
1993 SCM gf
= SCM_CAR (scm_last_pair (x
));
1995 return scm_internal_dynamic_wind (
1997 call_memoize_method
,
1999 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2000 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2002 return call_memoize_method ((void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)));
2006 /******************************************************************************
2008 * A simple make (which will be redefined later in Scheme)
2009 * This version handles only creation of gf, methods and classes (no instances)
2011 * Since this code will disappear when Goops will be fully booted,
2012 * no precaution is taken to be efficient.
2014 ******************************************************************************/
2016 SCM_KEYWORD (k_setter
, "setter");
2017 SCM_KEYWORD (k_specializers
, "specializers");
2018 SCM_KEYWORD (k_procedure
, "procedure");
2019 SCM_KEYWORD (k_dsupers
, "dsupers");
2020 SCM_KEYWORD (k_slots
, "slots");
2021 SCM_KEYWORD (k_gf
, "generic-function");
2023 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2025 "Make a new object. @var{args} must contain the class and\n"
2026 "all necessary initialization information.")
2027 #define FUNC_NAME s_scm_make
2030 long len
= scm_ilength (args
);
2032 if (len
<= 0 || (len
& 1) == 0)
2033 SCM_WRONG_NUM_ARGS ();
2035 class = SCM_CAR(args
);
2036 args
= SCM_CDR(args
);
2038 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
2041 z
= scm_make_struct (class, SCM_INUM0
,
2042 scm_list_4 (SCM_EOL
,
2045 scm_make_mutex ()));
2047 z
= scm_make_struct (class, SCM_INUM0
,
2048 scm_list_3 (SCM_EOL
, SCM_INUM0
, SCM_BOOL_F
));
2050 scm_set_procedure_property_x (z
, scm_sym_name
,
2051 scm_get_keyword (k_name
,
2054 clear_method_cache (z
);
2055 if (class == scm_class_generic_with_setter
)
2057 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2058 if (!SCM_FALSEP (setter
))
2059 scm_sys_set_object_setter_x (z
, setter
);
2064 z
= scm_sys_allocate_instance (class, args
);
2066 if (class == scm_class_method
2067 || class == scm_class_simple_method
2068 || class == scm_class_accessor
)
2070 SCM_SET_SLOT (z
, scm_si_generic_function
,
2071 scm_i_get_keyword (k_gf
,
2076 SCM_SET_SLOT (z
, scm_si_specializers
,
2077 scm_i_get_keyword (k_specializers
,
2082 SCM_SET_SLOT (z
, scm_si_procedure
,
2083 scm_i_get_keyword (k_procedure
,
2088 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2092 /* In all the others case, make a new class .... No instance here */
2093 SCM_SET_SLOT (z
, scm_si_name
,
2094 scm_i_get_keyword (k_name
,
2097 scm_str2symbol ("???"),
2099 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2100 scm_i_get_keyword (k_dsupers
,
2105 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2106 scm_i_get_keyword (k_slots
,
2117 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2120 #define FUNC_NAME s_scm_find_method
2123 long len
= scm_ilength (l
);
2126 SCM_WRONG_NUM_ARGS ();
2128 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2129 SCM_VALIDATE_GENERIC (1, gf
);
2130 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2131 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2133 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2137 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2138 (SCM m1
, SCM m2
, SCM targs
),
2140 #define FUNC_NAME s_scm_sys_method_more_specific_p
2145 SCM_VALIDATE_METHOD (1, m1
);
2146 SCM_VALIDATE_METHOD (2, m2
);
2147 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2149 /* Verify that all the arguments of targs are classes and place them in a vector*/
2150 v
= scm_c_make_vector (len
, SCM_EOL
);
2152 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2153 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2154 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2156 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2162 /******************************************************************************
2166 ******************************************************************************/
2170 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2172 SCM tmp
= scm_str2symbol (name
);
2174 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2178 : scm_list_1 (super
),
2184 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2187 create_standard_classes (void)
2190 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2191 scm_str2symbol ("specializers"),
2193 scm_str2symbol ("code-table"));
2194 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2196 k_slot_definition
));
2198 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2200 SCM mutex_slot
= SCM_BOOL_F
;
2202 SCM gf_slots
= scm_list_4 (scm_str2symbol ("methods"),
2203 scm_list_3 (scm_str2symbol ("n-specialized"),
2206 scm_list_3 (scm_str2symbol ("used-by"),
2209 scm_list_3 (scm_str2symbol ("cache-mutex"),
2211 scm_closure (scm_list_2 (SCM_EOL
,
2215 /* Foreign class slot classes */
2216 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2217 scm_class_class
, scm_class_top
, SCM_EOL
);
2218 make_stdcls (&scm_class_protected
, "<protected-slot>",
2219 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2220 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2221 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2222 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2223 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2224 make_stdcls (&scm_class_self
, "<self-slot>",
2226 scm_list_2 (scm_class_foreign_slot
, scm_class_read_only
),
2228 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2230 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2232 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2234 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2236 make_stdcls (&scm_class_scm
, "<scm-slot>",
2237 scm_class_class
, scm_class_protected
, SCM_EOL
);
2238 make_stdcls (&scm_class_int
, "<int-slot>",
2239 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2240 make_stdcls (&scm_class_float
, "<float-slot>",
2241 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2242 make_stdcls (&scm_class_double
, "<double-slot>",
2243 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2245 /* Continue initialization of class <class> */
2247 slots
= build_class_class_slots ();
2248 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2249 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2250 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2251 compute_getters_n_setters (slots
));
2253 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2254 scm_class_class
, scm_class_class
,
2255 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2258 scm_list_3 (scm_str2symbol ("destructor"),
2260 scm_class_opaque
)));
2261 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2262 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2263 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2265 /* scm_class_generic functions classes */
2266 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2267 scm_class_class
, scm_class_class
, SCM_EOL
);
2268 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2269 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2270 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2271 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2272 make_stdcls (&scm_class_operator_with_setter_class
,
2273 "<operator-with-setter-class>",
2274 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2275 make_stdcls (&scm_class_method
, "<method>",
2276 scm_class_class
, scm_class_object
, method_slots
);
2277 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2278 scm_class_class
, scm_class_method
, SCM_EOL
);
2279 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2280 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2281 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2282 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2283 make_stdcls (&scm_class_entity
, "<entity>",
2284 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2285 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2286 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2287 make_stdcls (&scm_class_generic
, "<generic>",
2288 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2289 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2290 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2291 scm_class_entity_class
,
2292 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2295 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2296 SCM_SET_SLOT (scm_class_generic_with_setter
, scm_si_cpl
,
2297 scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter
,
2299 SCM_SLOT (scm_class_entity_with_setter
,
2303 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2305 /* Primitive types classes */
2306 make_stdcls (&scm_class_boolean
, "<boolean>",
2307 scm_class_class
, scm_class_top
, SCM_EOL
);
2308 make_stdcls (&scm_class_char
, "<char>",
2309 scm_class_class
, scm_class_top
, SCM_EOL
);
2310 make_stdcls (&scm_class_list
, "<list>",
2311 scm_class_class
, scm_class_top
, SCM_EOL
);
2312 make_stdcls (&scm_class_pair
, "<pair>",
2313 scm_class_class
, scm_class_list
, SCM_EOL
);
2314 make_stdcls (&scm_class_null
, "<null>",
2315 scm_class_class
, scm_class_list
, SCM_EOL
);
2316 make_stdcls (&scm_class_string
, "<string>",
2317 scm_class_class
, scm_class_top
, SCM_EOL
);
2318 make_stdcls (&scm_class_symbol
, "<symbol>",
2319 scm_class_class
, scm_class_top
, SCM_EOL
);
2320 make_stdcls (&scm_class_vector
, "<vector>",
2321 scm_class_class
, scm_class_top
, SCM_EOL
);
2322 make_stdcls (&scm_class_number
, "<number>",
2323 scm_class_class
, scm_class_top
, SCM_EOL
);
2324 make_stdcls (&scm_class_complex
, "<complex>",
2325 scm_class_class
, scm_class_number
, SCM_EOL
);
2326 make_stdcls (&scm_class_real
, "<real>",
2327 scm_class_class
, scm_class_complex
, SCM_EOL
);
2328 make_stdcls (&scm_class_integer
, "<integer>",
2329 scm_class_class
, scm_class_real
, SCM_EOL
);
2330 make_stdcls (&scm_class_keyword
, "<keyword>",
2331 scm_class_class
, scm_class_top
, SCM_EOL
);
2332 make_stdcls (&scm_class_unknown
, "<unknown>",
2333 scm_class_class
, scm_class_top
, SCM_EOL
);
2334 make_stdcls (&scm_class_procedure
, "<procedure>",
2335 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2336 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2337 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2338 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2339 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2340 make_stdcls (&scm_class_port
, "<port>",
2341 scm_class_class
, scm_class_top
, SCM_EOL
);
2342 make_stdcls (&scm_class_input_port
, "<input-port>",
2343 scm_class_class
, scm_class_port
, SCM_EOL
);
2344 make_stdcls (&scm_class_output_port
, "<output-port>",
2345 scm_class_class
, scm_class_port
, SCM_EOL
);
2346 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2348 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2352 /**********************************************************************
2356 **********************************************************************/
2359 make_class_from_template (char *template, char *type_name
, SCM supers
)
2365 sprintf (buffer
, template, type_name
);
2366 name
= scm_str2symbol (buffer
);
2369 name
= SCM_GOOPS_UNBOUND
;
2371 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2376 /* Only define name if doesn't already exist. */
2377 if (!SCM_GOOPS_UNBOUNDP (name
)
2378 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2379 DEFVAR (name
, class);
2384 scm_make_extended_class (char *type_name
)
2386 return make_class_from_template ("<%s>",
2388 scm_list_1 (scm_class_top
));
2392 create_smob_classes (void)
2396 scm_smob_class
= (SCM
*) malloc (255 * sizeof (SCM
));
2397 for (i
= 0; i
< 255; ++i
)
2398 scm_smob_class
[i
] = 0;
2400 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2401 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2402 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2403 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2405 for (i
= 0; i
< scm_numsmob
; ++i
)
2406 if (!scm_smob_class
[i
])
2407 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2411 scm_make_port_classes (long ptobnum
, char *type_name
)
2413 SCM c
, class = make_class_from_template ("<%s-port>",
2415 scm_list_1 (scm_class_port
));
2416 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2417 = make_class_from_template ("<%s-input-port>",
2419 scm_list_2 (class, scm_class_input_port
));
2420 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2421 = make_class_from_template ("<%s-output-port>",
2423 scm_list_2 (class, scm_class_output_port
));
2424 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2426 = make_class_from_template ("<%s-input-output-port>",
2428 scm_list_2 (class, scm_class_input_output_port
));
2429 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2430 SCM_SET_SLOT (c
, scm_si_cpl
,
2431 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2435 create_port_classes (void)
2439 scm_port_class
= (SCM
*) malloc (3 * 256 * sizeof (SCM
));
2440 for (i
= 0; i
< 3 * 256; ++i
)
2441 scm_port_class
[i
] = 0;
2443 for (i
= 0; i
< scm_numptob
; ++i
)
2444 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2448 make_struct_class (void *closure SCM_UNUSED
, SCM key SCM_UNUSED
,
2449 SCM data
, SCM prev SCM_UNUSED
)
2451 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2452 SCM_SET_STRUCT_TABLE_CLASS (data
,
2453 scm_make_extended_class
2454 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2455 return SCM_UNSPECIFIED
;
2459 create_struct_classes (void)
2461 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2464 /**********************************************************************
2468 **********************************************************************/
2473 if (!goops_loaded_p
)
2474 scm_c_resolve_module ("oop goops");
2479 scm_make_foreign_object (SCM
class, SCM initargs
)
2480 #define FUNC_NAME s_scm_make
2482 void * (*constructor
) (SCM
)
2483 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2484 if (constructor
== 0)
2485 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2486 return scm_wrap_object (class, constructor (initargs
));
2492 scm_free_foreign_object (SCM
*class, SCM
*data
)
2494 size_t (*destructor
) (void *)
2495 = (size_t (*) (void *)) class[scm_si_destructor
];
2496 return destructor (data
);
2500 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2501 void * (*constructor
) (SCM initargs
),
2502 size_t (*destructor
) (void *))
2505 name
= scm_str2symbol (s_name
);
2506 if (SCM_NULLP (supers
))
2507 supers
= scm_list_1 (scm_class_foreign_object
);
2508 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2509 scm_sys_inherit_magic_x (class, supers
);
2511 if (destructor
!= 0)
2513 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2514 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2518 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2519 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2522 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2523 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2528 SCM_SYMBOL (sym_o
, "o");
2529 SCM_SYMBOL (sym_x
, "x");
2531 SCM_KEYWORD (k_accessor
, "accessor");
2532 SCM_KEYWORD (k_getter
, "getter");
2535 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2537 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2542 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2543 SCM (*getter
) (SCM obj
),
2544 SCM (*setter
) (SCM obj
, SCM x
),
2545 char *accessor_name
)
2548 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2549 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2550 setter
? setter
: default_setter
);
2551 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2552 scm_list_2 (get
, sym_o
)),
2554 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2555 scm_list_3 (set
, sym_o
, sym_x
)),
2558 SCM name
= scm_str2symbol (slot_name
);
2559 SCM aname
= scm_str2symbol (accessor_name
);
2560 SCM gf
= scm_ensure_accessor (aname
);
2561 SCM slot
= scm_list_5 (name
,
2564 setter
? k_accessor
: k_getter
,
2566 SCM gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2568 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor
,
2573 scm_add_method (scm_setter (gf
),
2574 scm_make (scm_list_5 (scm_class_accessor
,
2576 scm_list_2 (class, scm_class_top
),
2581 SCM_SET_SLOT (class, scm_si_slots
,
2582 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2583 scm_list_1 (slot
))));
2584 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2585 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2586 scm_list_1 (gns
))));
2590 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2592 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2597 scm_wrap_object (SCM
class, void *data
)
2599 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2607 scm_wrap_component (SCM
class, SCM container
, void *data
)
2609 SCM obj
= scm_wrap_object (class, data
);
2610 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2616 SCM_SETCDR (handle
, container
);
2621 scm_ensure_accessor (SCM name
)
2623 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2624 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2626 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2627 gf
= scm_make (scm_list_5 (scm_class_generic_with_setter
,
2628 k_name
, name
, k_setter
, gf
));
2633 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2636 scm_add_method (SCM gf
, SCM m
)
2638 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2643 * Debugging utilities
2646 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2648 "Return @code{#t} if @var{obj} is a pure generic.")
2649 #define FUNC_NAME s_scm_pure_generic_p
2651 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2655 #endif /* GUILE_DEBUG */
2661 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2663 "Announce that GOOPS is loaded and perform initialization\n"
2664 "on the C level which depends on the loaded GOOPS modules.")
2665 #define FUNC_NAME s_scm_sys_goops_loaded
2668 var_compute_applicable_methods
=
2669 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2671 return SCM_UNSPECIFIED
;
2675 SCM scm_module_goops
;
2678 scm_init_goops_builtins (void)
2680 scm_module_goops
= scm_current_module ();
2681 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2683 /* Not really necessary right now, but who knows...
2685 scm_permanent_object (scm_module_goops
);
2686 scm_permanent_object (scm_goops_lookup_closure
);
2688 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2689 (SCM_MAKINUM (37)));
2691 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2693 #include "libguile/goops.x"
2695 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2697 hell
= scm_malloc (hell_size
);
2699 scm_mutex_init (&hell_mutex
);
2702 create_basic_classes ();
2703 create_standard_classes ();
2704 create_smob_classes ();
2705 create_struct_classes ();
2706 create_port_classes ();
2709 SCM name
= scm_str2symbol ("no-applicable-method");
2710 scm_no_applicable_method
2711 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2714 DEFVAR (name
, scm_no_applicable_method
);
2717 return SCM_UNSPECIFIED
;
2723 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2724 scm_init_goops_builtins
);