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_CDR (SCM_CODE (tmp
)),
476 SCM_KEYWORD (k_class
, "class");
478 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
481 #define FUNC_NAME s_scm_sys_prep_layout_x
484 unsigned long int n
, i
;
487 SCM_VALIDATE_INSTANCE (1, class);
488 slots
= SCM_SLOT (class, scm_si_slots
);
489 nfields
= SCM_SLOT (class, scm_si_nfields
);
490 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
491 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
492 scm_list_1 (nfields
));
493 n
= 2 * SCM_INUM (nfields
);
494 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
495 && SCM_SUBCLASSP (class, scm_class_class
))
496 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
497 scm_list_1 (nfields
));
499 s
= n
> 0 ? scm_must_malloc (n
, FUNC_NAME
) : 0;
500 for (i
= 0; i
< n
; i
+= 2)
506 if (!SCM_CONSP (slots
))
507 SCM_MISC_ERROR ("too few slot definitions", SCM_EOL
);
508 len
= scm_ilength (SCM_CDAR (slots
));
509 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
), len
, SCM_BOOL_F
,
511 if (SCM_FALSEP (type
))
518 if (!SCM_CLASSP (type
))
519 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
520 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
522 if (SCM_SUBCLASSP (type
, scm_class_self
))
524 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
529 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
531 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
544 slots
= SCM_CDR (slots
);
546 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
549 return SCM_UNSPECIFIED
;
553 static void prep_hashsets (SCM
);
555 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
556 (SCM
class, SCM dsupers
),
558 #define FUNC_NAME s_scm_sys_inherit_magic_x
562 SCM_VALIDATE_INSTANCE (1, class);
563 while (!SCM_NULLP (ls
))
565 SCM_ASSERT (SCM_CONSP (ls
)
566 && SCM_INSTANCEP (SCM_CAR (ls
)),
570 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
573 flags
&= SCM_CLASSF_INHERIT
;
574 if (flags
& SCM_CLASSF_ENTITY
)
575 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
578 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
581 * We could avoid calling scm_must_malloc in the allocation code
582 * (in which case the following two lines are needed). Instead
583 * we make 0-slot instances non-light, so that the light case
584 * can be handled without special cases.
587 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
589 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
591 /* NOTE: The following depends on scm_struct_i_size. */
592 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
593 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
596 SCM_SET_CLASS_FLAGS (class, flags
);
598 prep_hashsets (class);
600 return SCM_UNSPECIFIED
;
605 prep_hashsets (SCM
class)
609 for (i
= 0; i
< 7; ++i
)
610 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
613 /******************************************************************************/
616 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
618 SCM z
, cpl
, slots
, nfields
, g_n_s
;
620 /* Allocate one instance */
621 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
623 /* Initialize its slots */
625 cpl
= compute_cpl (dsupers
, scm_list_1 (z
));
627 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
628 cpl
= compute_cpl (z
);
629 slots
= build_slots_list (maplist (dslots
), cpl
);
630 nfields
= SCM_MAKINUM (scm_ilength (slots
));
631 g_n_s
= compute_getters_n_setters (slots
);
633 SCM_SET_SLOT (z
, scm_si_name
, name
);
634 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
635 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
636 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
637 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
638 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
639 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
640 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
641 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
642 SCM_SET_SLOT (z
, scm_si_environment
,
643 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
645 /* Add this class in the direct-subclasses slot of dsupers */
648 for (tmp
= dsupers
; !SCM_NULLP (tmp
); tmp
= SCM_CDR (tmp
))
649 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
650 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
651 scm_si_direct_subclasses
)));
654 /* Support for the underlying structs: */
655 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
656 ? (SCM_CLASSF_GOOPS_OR_VALID
657 | SCM_CLASSF_OPERATOR
659 : class == scm_class_operator_class
660 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
661 : SCM_CLASSF_GOOPS_OR_VALID
));
666 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
668 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
669 scm_sys_inherit_magic_x (z
, dsupers
);
670 scm_sys_prep_layout_x (z
);
674 /******************************************************************************/
676 SCM_SYMBOL (sym_layout
, "layout");
677 SCM_SYMBOL (sym_vcell
, "vcell");
678 SCM_SYMBOL (sym_vtable
, "vtable");
679 SCM_SYMBOL (sym_print
, "print");
680 SCM_SYMBOL (sym_procedure
, "procedure");
681 SCM_SYMBOL (sym_setter
, "setter");
682 SCM_SYMBOL (sym_redefined
, "redefined");
683 SCM_SYMBOL (sym_h0
, "h0");
684 SCM_SYMBOL (sym_h1
, "h1");
685 SCM_SYMBOL (sym_h2
, "h2");
686 SCM_SYMBOL (sym_h3
, "h3");
687 SCM_SYMBOL (sym_h4
, "h4");
688 SCM_SYMBOL (sym_h5
, "h5");
689 SCM_SYMBOL (sym_h6
, "h6");
690 SCM_SYMBOL (sym_h7
, "h7");
691 SCM_SYMBOL (sym_name
, "name");
692 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
693 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
694 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
695 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
696 SCM_SYMBOL (sym_cpl
, "cpl");
697 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
698 SCM_SYMBOL (sym_slots
, "slots");
699 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
700 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
701 SCM_SYMBOL (sym_nfields
, "nfields");
702 SCM_SYMBOL (sym_environment
, "environment");
706 build_class_class_slots ()
709 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
710 scm_list_3 (sym_vcell
, k_class
, scm_class_opaque
),
711 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
712 scm_list_1 (sym_print
),
713 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
714 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
715 scm_list_1 (sym_redefined
),
716 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
717 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
718 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
719 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
720 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
721 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
722 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
723 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
724 scm_list_1 (sym_name
),
725 scm_list_1 (sym_direct_supers
),
726 scm_list_1 (sym_direct_slots
),
727 scm_list_1 (sym_direct_subclasses
),
728 scm_list_1 (sym_direct_methods
),
729 scm_list_1 (sym_cpl
),
730 scm_list_1 (sym_default_slot_definition_class
),
731 scm_list_1 (sym_slots
),
732 scm_list_1 (sym_getters_n_setters
),
733 scm_list_1 (sym_keyword_access
),
734 scm_list_1 (sym_nfields
),
735 scm_list_1 (sym_environment
),
740 create_basic_classes (void)
742 /* SCM slots_of_class = build_class_class_slots (); */
744 /**** <scm_class_class> ****/
745 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
746 + 2 * scm_vtable_offset_user
);
747 SCM name
= scm_str2symbol ("<class>");
748 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
751 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
752 | SCM_CLASSF_METACLASS
));
754 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
755 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
756 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
757 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
758 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
759 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
760 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
761 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
762 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
763 compute_getters_n_setters (slots_of_class)); */
764 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
765 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
766 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
768 prep_hashsets (scm_class_class
);
770 DEFVAR(name
, scm_class_class
);
772 /**** <scm_class_top> ****/
773 name
= scm_str2symbol ("<top>");
774 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
779 DEFVAR(name
, scm_class_top
);
781 /**** <scm_class_object> ****/
782 name
= scm_str2symbol ("<object>");
783 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
785 scm_list_1 (scm_class_top
),
788 DEFVAR (name
, scm_class_object
);
790 /* <top> <object> and <class> were partially initialized. Correct them here */
791 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
793 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
794 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
797 /******************************************************************************/
799 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
801 "Return @code{#t} if @var{obj} is an instance.")
802 #define FUNC_NAME s_scm_instance_p
804 return SCM_BOOL (SCM_INSTANCEP (obj
));
809 /******************************************************************************
811 * Meta object accessors
813 ******************************************************************************/
814 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
816 "Return the class name of @var{obj}.")
817 #define FUNC_NAME s_scm_class_name
819 SCM_VALIDATE_CLASS (1, obj
);
820 return scm_slot_ref (obj
, sym_name
);
824 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
826 "Return the direct superclasses of the class @var{obj}.")
827 #define FUNC_NAME s_scm_class_direct_supers
829 SCM_VALIDATE_CLASS (1, obj
);
830 return scm_slot_ref (obj
, sym_direct_supers
);
834 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
836 "Return the direct slots of the class @var{obj}.")
837 #define FUNC_NAME s_scm_class_direct_slots
839 SCM_VALIDATE_CLASS (1, obj
);
840 return scm_slot_ref (obj
, sym_direct_slots
);
844 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
846 "Return the direct subclasses of the class @var{obj}.")
847 #define FUNC_NAME s_scm_class_direct_subclasses
849 SCM_VALIDATE_CLASS (1, obj
);
850 return scm_slot_ref(obj
, sym_direct_subclasses
);
854 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
856 "Return the direct methods of the class @var{obj}")
857 #define FUNC_NAME s_scm_class_direct_methods
859 SCM_VALIDATE_CLASS (1, obj
);
860 return scm_slot_ref (obj
, sym_direct_methods
);
864 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
866 "Return the class precedence list of the class @var{obj}.")
867 #define FUNC_NAME s_scm_class_precedence_list
869 SCM_VALIDATE_CLASS (1, obj
);
870 return scm_slot_ref (obj
, sym_cpl
);
874 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
876 "Return the slot list of the class @var{obj}.")
877 #define FUNC_NAME s_scm_class_slots
879 SCM_VALIDATE_CLASS (1, obj
);
880 return scm_slot_ref (obj
, sym_slots
);
884 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
886 "Return the environment of the class @var{obj}.")
887 #define FUNC_NAME s_scm_class_environment
889 SCM_VALIDATE_CLASS (1, obj
);
890 return scm_slot_ref(obj
, sym_environment
);
895 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
897 "Return the name of the generic function @var{obj}.")
898 #define FUNC_NAME s_scm_generic_function_name
900 SCM_VALIDATE_GENERIC (1, obj
);
901 return scm_procedure_property (obj
, scm_sym_name
);
905 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
907 "Return the methods of the generic function @var{obj}.")
908 #define FUNC_NAME s_scm_generic_function_methods
910 SCM_VALIDATE_GENERIC (1, obj
);
911 return scm_slot_ref (obj
, scm_str2symbol ("methods"));
916 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
918 "Return the generic function fot the method @var{obj}.")
919 #define FUNC_NAME s_scm_method_generic_function
921 SCM_VALIDATE_METHOD (1, obj
);
922 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
926 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
928 "Return specializers of the method @var{obj}.")
929 #define FUNC_NAME s_scm_method_specializers
931 SCM_VALIDATE_METHOD (1, obj
);
932 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
936 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
938 "Return the procedure of the method @var{obj}.")
939 #define FUNC_NAME s_scm_method_procedure
941 SCM_VALIDATE_METHOD (1, obj
);
942 return scm_slot_ref (obj
, sym_procedure
);
946 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
948 "Return the slot definition of the accessor @var{obj}.")
949 #define FUNC_NAME s_scm_accessor_method_slot_definition
951 SCM_VALIDATE_ACCESSOR (1, obj
);
952 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
956 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
958 "Internal GOOPS magic---don't use this function!")
959 #define FUNC_NAME s_scm_sys_tag_body
961 return scm_cons (SCM_IM_LAMBDA
, body
);
965 /******************************************************************************
967 * S l o t a c c e s s
969 ******************************************************************************/
971 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
973 "Return the unbound value.")
974 #define FUNC_NAME s_scm_make_unbound
976 return SCM_GOOPS_UNBOUND
;
980 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
982 "Return @code{#t} if @var{obj} is unbound.")
983 #define FUNC_NAME s_scm_unbound_p
985 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
989 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
990 (SCM value
, SCM obj
),
991 "Return @var{value} if it is bound, and invoke the\n"
992 "@var{slot-unbound} method of @var{obj} if it is not.")
993 #define FUNC_NAME s_scm_assert_bound
995 if (SCM_GOOPS_UNBOUNDP (value
))
996 return CALL_GF1 ("slot-unbound", obj
);
1001 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1002 (SCM obj
, SCM index
),
1003 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1004 "the value from @var{obj}.")
1005 #define FUNC_NAME s_scm_at_assert_bound_ref
1007 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1008 if (SCM_GOOPS_UNBOUNDP (value
))
1009 return CALL_GF1 ("slot-unbound", obj
);
1014 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1015 (SCM obj
, SCM index
),
1016 "Return the slot value with index @var{index} from @var{obj}.")
1017 #define FUNC_NAME s_scm_sys_fast_slot_ref
1019 unsigned long int i
;
1021 SCM_VALIDATE_INSTANCE (1, obj
);
1022 SCM_VALIDATE_INUM (2, index
);
1023 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1024 i
= SCM_INUM (index
);
1025 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1027 return scm_at_assert_bound_ref (obj
, index
);
1031 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1032 (SCM obj
, SCM index
, SCM value
),
1033 "Set the slot with index @var{index} in @var{obj} to\n"
1035 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1037 unsigned long int i
;
1039 SCM_VALIDATE_INSTANCE (1, obj
);
1040 SCM_VALIDATE_INUM (2, index
);
1041 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1042 i
= SCM_INUM (index
);
1043 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1045 SCM_SET_SLOT (obj
, i
, value
);
1047 return SCM_UNSPECIFIED
;
1054 /* In the future, this function will return the effective slot
1055 * definition associated with SLOT_NAME. Now it just returns some of
1056 * the information which will be stored in the effective slot
1061 slot_definition_using_name (SCM
class, SCM slot_name
)
1063 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1064 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1065 if (SCM_CAAR (slots
) == slot_name
)
1066 return SCM_CAR (slots
);
1071 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1073 SCM access
= SCM_CDDR (slotdef
);
1075 * - access is an integer (the offset of this slot in the slots vector)
1076 * - otherwise (car access) is the getter function to apply
1078 if (SCM_INUMP (access
))
1079 return SCM_SLOT (obj
, SCM_INUM (access
));
1082 /* We must evaluate (apply (car access) (list obj))
1083 * where (car access) is known to be a closure of arity 1 */
1084 register SCM code
, env
;
1086 code
= SCM_CAR (access
);
1087 if (!SCM_CLOSUREP (code
))
1088 return SCM_SUBRF (code
) (obj
);
1089 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1092 /* Evaluate the closure body */
1093 return scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1098 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1100 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1101 if (!SCM_FALSEP (slotdef
))
1102 return get_slot_value (class, obj
, slotdef
);
1104 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1108 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1110 SCM access
= SCM_CDDR (slotdef
);
1112 * - access is an integer (the offset of this slot in the slots vector)
1113 * - otherwise (cadr access) is the setter function to apply
1115 if (SCM_INUMP (access
))
1116 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1119 /* We must evaluate (apply (cadr l) (list obj value))
1120 * where (cadr l) is known to be a closure of arity 2 */
1121 register SCM code
, env
;
1123 code
= SCM_CADR (access
);
1124 if (!SCM_CLOSUREP (code
))
1125 SCM_SUBRF (code
) (obj
, value
);
1128 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1129 scm_list_2 (obj
, value
),
1131 /* Evaluate the closure body */
1132 scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
);
1135 return SCM_UNSPECIFIED
;
1139 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1141 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1142 if (!SCM_FALSEP (slotdef
))
1143 return set_slot_value (class, obj
, slotdef
, value
);
1145 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1149 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1153 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1154 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1160 /* ======================================== */
1162 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1163 (SCM
class, SCM obj
, SCM slot_name
),
1165 #define FUNC_NAME s_scm_slot_ref_using_class
1169 SCM_VALIDATE_CLASS (1, class);
1170 SCM_VALIDATE_INSTANCE (2, obj
);
1171 SCM_VALIDATE_SYMBOL (3, slot_name
);
1173 res
= get_slot_value_using_name (class, obj
, slot_name
);
1174 if (SCM_GOOPS_UNBOUNDP (res
))
1175 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1181 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1182 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1184 #define FUNC_NAME s_scm_slot_set_using_class_x
1186 SCM_VALIDATE_CLASS (1, class);
1187 SCM_VALIDATE_INSTANCE (2, obj
);
1188 SCM_VALIDATE_SYMBOL (3, slot_name
);
1190 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1195 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1196 (SCM
class, SCM obj
, SCM slot_name
),
1198 #define FUNC_NAME s_scm_slot_bound_using_class_p
1200 SCM_VALIDATE_CLASS (1, class);
1201 SCM_VALIDATE_INSTANCE (2, obj
);
1202 SCM_VALIDATE_SYMBOL (3, slot_name
);
1204 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1210 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1211 (SCM
class, SCM obj
, SCM slot_name
),
1213 #define FUNC_NAME s_scm_slot_exists_using_class_p
1215 SCM_VALIDATE_CLASS (1, class);
1216 SCM_VALIDATE_INSTANCE (2, obj
);
1217 SCM_VALIDATE_SYMBOL (3, slot_name
);
1218 return test_slot_existence (class, obj
, slot_name
);
1223 /* ======================================== */
1225 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1226 (SCM obj
, SCM slot_name
),
1227 "Return the value from @var{obj}'s slot with the name\n"
1229 #define FUNC_NAME s_scm_slot_ref
1233 SCM_VALIDATE_INSTANCE (1, obj
);
1234 TEST_CHANGE_CLASS (obj
, class);
1236 res
= get_slot_value_using_name (class, obj
, slot_name
);
1237 if (SCM_GOOPS_UNBOUNDP (res
))
1238 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1243 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1244 (SCM obj
, SCM slot_name
, SCM value
),
1245 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1246 #define FUNC_NAME s_scm_slot_set_x
1250 SCM_VALIDATE_INSTANCE (1, obj
);
1251 TEST_CHANGE_CLASS(obj
, class);
1253 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1257 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1259 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1260 (SCM obj
, SCM slot_name
),
1261 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1263 #define FUNC_NAME s_scm_slot_bound_p
1267 SCM_VALIDATE_INSTANCE (1, obj
);
1268 TEST_CHANGE_CLASS(obj
, class);
1270 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1278 SCM_DEFINE (scm_slots_exists_p
, "slot-exists?", 2, 0, 0,
1279 (SCM obj
, SCM slot_name
),
1280 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1281 #define FUNC_NAME s_scm_slots_exists_p
1285 SCM_VALIDATE_INSTANCE (1, obj
);
1286 SCM_VALIDATE_SYMBOL (2, slot_name
);
1287 TEST_CHANGE_CLASS (obj
, class);
1289 return test_slot_existence (class, obj
, slot_name
);
1294 /******************************************************************************
1296 * %allocate-instance (the low level instance allocation primitive)
1298 ******************************************************************************/
1300 static void clear_method_cache (SCM
);
1303 wrap_init (SCM
class, SCM
*m
, long n
)
1308 /* Set all slots to unbound */
1309 for (i
= 0; i
< n
; i
++)
1310 m
[i
] = SCM_GOOPS_UNBOUND
;
1313 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
1314 SCM_SET_CELL_WORD_1 (z
, m
);
1315 SCM_SET_CELL_WORD_0 (z
, (scm_t_bits
) SCM_STRUCT_DATA (class)
1321 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1322 (SCM
class, SCM initargs
),
1323 "Create a new instance of class @var{class} and initialize it\n"
1324 "from the arguments @var{initargs}.")
1325 #define FUNC_NAME s_scm_sys_allocate_instance
1330 SCM_VALIDATE_CLASS (1, class);
1332 /* Most instances */
1333 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1335 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1336 m
= (SCM
*) scm_must_malloc (n
* sizeof (SCM
), "instance");
1337 return wrap_init (class, m
, n
);
1340 /* Foreign objects */
1341 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1342 return scm_make_foreign_object (class, initargs
);
1344 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1347 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1349 m
= (SCM
*) scm_alloc_struct (n
,
1350 scm_struct_entity_n_extra_words
,
1352 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1353 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1354 /* Generic functions */
1355 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1357 SCM gf
= wrap_init (class, m
, n
);
1358 clear_method_cache (gf
);
1362 return wrap_init (class, m
, n
);
1366 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1370 /* allocate class object */
1371 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1373 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1374 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1375 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1377 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1378 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1379 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1380 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1385 /* Non-light instances */
1387 m
= (SCM
*) scm_alloc_struct (n
,
1388 scm_struct_n_extra_words
,
1390 return wrap_init (class, m
, n
);
1395 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1396 (SCM obj
, SCM setter
),
1398 #define FUNC_NAME s_scm_sys_set_object_setter_x
1400 SCM_ASSERT (SCM_STRUCTP (obj
)
1401 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1402 || SCM_I_ENTITYP (obj
)),
1406 if (SCM_I_ENTITYP (obj
))
1407 SCM_SET_ENTITY_SETTER (obj
, setter
);
1409 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1410 return SCM_UNSPECIFIED
;
1414 /******************************************************************************
1416 * %modify-instance (used by change-class to modify in place)
1418 ******************************************************************************/
1420 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1423 #define FUNC_NAME s_scm_sys_modify_instance
1425 SCM_VALIDATE_INSTANCE (1, old
);
1426 SCM_VALIDATE_INSTANCE (2, new);
1428 /* Exchange the data contained in old and new. We exchange rather than
1429 * scratch the old value with new to be correct with GC.
1430 * See "Class redefinition protocol above".
1434 SCM car
= SCM_CAR (old
);
1435 SCM cdr
= SCM_CDR (old
);
1436 SCM_SETCAR (old
, SCM_CAR (new));
1437 SCM_SETCDR (old
, SCM_CDR (new));
1438 SCM_SETCAR (new, car
);
1439 SCM_SETCDR (new, cdr
);
1442 return SCM_UNSPECIFIED
;
1446 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1449 #define FUNC_NAME s_scm_sys_modify_class
1451 SCM_VALIDATE_CLASS (1, old
);
1452 SCM_VALIDATE_CLASS (2, new);
1456 SCM car
= SCM_CAR (old
);
1457 SCM cdr
= SCM_CDR (old
);
1458 SCM_SETCAR (old
, SCM_CAR (new));
1459 SCM_SETCDR (old
, SCM_CDR (new));
1460 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1461 SCM_SETCAR (new, car
);
1462 SCM_SETCDR (new, cdr
);
1463 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1466 return SCM_UNSPECIFIED
;
1470 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1473 #define FUNC_NAME s_scm_sys_invalidate_class
1475 SCM_VALIDATE_CLASS (1, class);
1476 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1477 return SCM_UNSPECIFIED
;
1481 /* When instances change class, they finally get a new body, but
1482 * before that, they go through purgatory in hell. Odd as it may
1483 * seem, this data structure saves us from eternal suffering in
1484 * infinite recursions.
1487 static scm_t_bits
**hell
;
1488 static long n_hell
= 1; /* one place for the evil one himself */
1489 static long hell_size
= 4;
1491 static scm_t_mutex hell_mutex
;
1498 for (i
= 1; i
< n_hell
; ++i
)
1499 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1505 go_to_hell (void *o
)
1507 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1509 scm_mutex_lock (&hell_mutex
);
1511 if (n_hell
== hell_size
)
1513 long new_size
= 2 * hell_size
;
1514 hell
= scm_must_realloc (hell
, hell_size
, new_size
, "hell");
1515 hell_size
= new_size
;
1517 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1519 scm_mutex_unlock (&hell_mutex
);
1524 go_to_heaven (void *o
)
1527 scm_mutex_lock (&hell_mutex
);
1529 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1531 scm_mutex_unlock (&hell_mutex
);
1536 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1539 purgatory (void *args
)
1541 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1542 SCM_PACK ((scm_t_bits
) args
));
1546 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1549 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1550 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1551 (void *) SCM_UNPACK (obj
));
1554 /******************************************************************************
1560 * GGG E N E R I C F U N C T I O N S
1562 * This implementation provides
1563 * - generic functions (with class specializers)
1566 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1568 ******************************************************************************/
1570 SCM_KEYWORD (k_name
, "name");
1572 SCM_SYMBOL (sym_no_method
, "no-method");
1574 static SCM list_of_no_method
;
1576 SCM_SYMBOL (scm_sym_args
, "args");
1579 scm_make_method_cache (SCM gf
)
1581 return scm_list_5 (SCM_IM_DISPATCH
,
1584 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1590 clear_method_cache (SCM gf
)
1592 SCM cache
= scm_make_method_cache (gf
);
1593 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1594 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1597 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1600 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1603 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1604 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1605 if (!SCM_FALSEP (used_by
))
1607 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1608 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1609 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1610 clear_method_cache (gf
);
1611 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1612 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1615 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1616 /* The sign of n is a flag indicating rest args. */
1617 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1619 return SCM_UNSPECIFIED
;
1623 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1626 #define FUNC_NAME s_scm_generic_capability_p
1628 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1629 proc
, SCM_ARG1
, FUNC_NAME
);
1630 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1636 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1639 #define FUNC_NAME s_scm_enable_primitive_generic_x
1641 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1642 while (!SCM_NULLP (subrs
))
1644 SCM subr
= SCM_CAR (subrs
);
1645 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1646 subr
, SCM_ARGn
, FUNC_NAME
);
1647 *SCM_SUBR_GENERIC (subr
)
1648 = scm_make (scm_list_3 (scm_class_generic
,
1651 subrs
= SCM_CDR (subrs
);
1653 return SCM_UNSPECIFIED
;
1657 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1660 #define FUNC_NAME s_scm_primitive_generic_generic
1662 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1664 SCM gf
= *SCM_SUBR_GENERIC (subr
);
1668 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1672 /******************************************************************************
1674 * Protocol for calling a generic fumction
1675 * This protocol is roughly equivalent to (parameter are a little bit different
1676 * for efficiency reasons):
1678 * + apply-generic (gf args)
1679 * + compute-applicable-methods (gf args ...)
1680 * + sort-applicable-methods (methods args)
1681 * + apply-methods (gf methods args)
1683 * apply-methods calls make-next-method to build the "continuation" of a a
1684 * method. Applying a next-method will call apply-next-method which in
1685 * turn will call apply again to call effectively the following method.
1687 ******************************************************************************/
1690 applicablep (SCM actual
, SCM formal
)
1692 /* We already know that the cpl is well formed. */
1693 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1697 more_specificp (SCM m1
, SCM m2
, SCM
*targs
)
1699 register SCM s1
, s2
;
1703 * m1 and m2 can have != length (i.e. one can be one element longer than the
1704 * other when we have a dotted parameter list). For instance, with the call
1707 * (define-method M (a . l) ....)
1708 * (define-method M (a) ....)
1710 * we consider that the second method is more specific.
1712 * BTW, targs is an array of types. We don't need it's size since
1713 * we already know that m1 and m2 are applicable (no risk to go past
1714 * the end of this array).
1717 for (i
=0,s1
=SPEC_OF(m1
),s2
=SPEC_OF(m2
); ; i
++,s1
=SCM_CDR(s1
),s2
=SCM_CDR(s2
)) {
1718 if (SCM_NULLP(s1
)) return 1;
1719 if (SCM_NULLP(s2
)) return 0;
1720 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1721 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1723 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1724 if (cs1
== SCM_CAR(l
))
1726 if (cs2
== SCM_CAR(l
))
1729 return 0;/* should not occur! */
1732 return 0; /* should not occur! */
1735 #define BUFFSIZE 32 /* big enough for most uses */
1738 scm_i_vector2list (SCM l
, long len
)
1741 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1743 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1744 SCM_VELTS (z
)[j
] = SCM_CAR (l
);
1750 sort_applicable_methods (SCM method_list
, long size
, SCM
*targs
)
1753 SCM
*v
, vector
= SCM_EOL
;
1754 SCM buffer
[BUFFSIZE
];
1755 SCM save
= method_list
;
1757 /* For reasonably sized method_lists we can try to avoid all the
1758 * consing and reorder the list in place...
1759 * This idea is due to David McClain <Dave_McClain@msn.com>
1761 if (size
<= BUFFSIZE
)
1763 for (i
= 0; i
< size
; i
++)
1765 buffer
[i
] = SCM_CAR (method_list
);
1766 method_list
= SCM_CDR (method_list
);
1772 /* Too many elements in method_list to keep everything locally */
1773 vector
= scm_i_vector2list (save
, size
);
1774 v
= SCM_VELTS (vector
);
1777 /* Use a simple shell sort since it is generally faster than qsort on
1778 * small vectors (which is probably mostly the case when we have to
1779 * sort a list of applicable methods).
1781 for (incr
= size
/ 2; incr
; incr
/= 2)
1783 for (i
= incr
; i
< size
; i
++)
1785 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1787 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1791 SCM tmp
= v
[j
+ incr
];
1799 if (size
<= BUFFSIZE
)
1801 /* We did it in locally, so restore the original list (reordered) in-place */
1802 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1804 SCM_SETCAR (method_list
, *v
);
1805 method_list
= SCM_CDR (method_list
);
1809 /* If we are here, that's that we did it the hard way... */
1810 return scm_vector_to_list (vector
);
1814 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1818 SCM l
, fl
, applicable
= SCM_EOL
;
1820 SCM buffer
[BUFFSIZE
], *types
, *p
;
1823 /* Build the list of arguments types */
1824 if (len
>= BUFFSIZE
) {
1825 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1826 /* NOTE: Using pointers to malloced memory won't work if we
1827 1. have preemtive threading, and,
1828 2. have a GC which moves objects. */
1829 types
= p
= SCM_VELTS(tmp
);
1834 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1835 *p
++ = scm_class_of (SCM_CAR (args
));
1837 /* Build a list of all applicable methods */
1838 for (l
= SCM_SLOT (gf
, scm_si_methods
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1840 fl
= SPEC_OF (SCM_CAR (l
));
1841 /* Only accept accessors which match exactly in first arg. */
1842 if (SCM_ACCESSORP (SCM_CAR (l
))
1843 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1845 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1847 if (SCM_INSTANCEP (fl
)
1848 /* We have a dotted argument list */
1849 || (i
>= len
&& SCM_NULLP (fl
)))
1850 { /* both list exhausted */
1851 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1857 || !applicablep (types
[i
], SCM_CAR (fl
)))
1866 CALL_GF2 ("no-applicable-method", gf
, save
);
1867 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1872 : sort_applicable_methods (applicable
, count
, types
));
1876 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1879 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1882 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1883 #define FUNC_NAME s_sys_compute_applicable_methods
1886 SCM_VALIDATE_GENERIC (1, gf
);
1887 n
= scm_ilength (args
);
1888 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1889 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1893 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1894 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
));
1896 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1899 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1900 #define FUNC_NAME s_atslot_ref
1902 SCM x
= SCM_CDR (xorig
);
1903 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1904 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1905 return scm_cons (SCM_IM_SLOT_REF
, x
);
1910 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1913 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1914 #define FUNC_NAME s_atslot_set_x
1916 SCM x
= SCM_CDR (xorig
);
1917 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1918 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1919 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1924 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1926 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1929 scm_m_atdispatch (SCM xorig
, SCM env
)
1930 #define FUNC_NAME s_atdispatch
1932 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1933 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
1935 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
1936 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
1938 n
= SCM_XEVALCAR (x
, env
);
1939 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
1940 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1942 v
= SCM_XEVALCAR (x
, env
);
1943 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
1945 gf
= SCM_XEVALCAR (x
, env
);
1946 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
1947 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1954 lock_cache_mutex (void *m
)
1956 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
1957 scm_lock_mutex (mutex
);
1961 unlock_cache_mutex (void *m
)
1963 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
1964 scm_unlock_mutex (mutex
);
1969 call_memoize_method (void *a
)
1971 SCM args
= SCM_PACK ((scm_t_bits
) a
);
1972 SCM gf
= SCM_CAR (args
);
1973 SCM x
= SCM_CADR (args
);
1974 /* First check if another thread has inserted a method between
1975 * the cache miss and locking the mutex.
1977 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
1978 if (!SCM_FALSEP (cmethod
))
1980 /*fixme* Use scm_apply */
1981 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
1985 scm_memoize_method (SCM x
, SCM args
)
1987 SCM gf
= SCM_CAR (scm_last_pair (x
));
1989 return scm_internal_dynamic_wind (
1991 call_memoize_method
,
1993 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
1994 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
1996 return call_memoize_method ((void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)));
2000 /******************************************************************************
2002 * A simple make (which will be redefined later in Scheme)
2003 * This version handles only creation of gf, methods and classes (no instances)
2005 * Since this code will disappear when Goops will be fully booted,
2006 * no precaution is taken to be efficient.
2008 ******************************************************************************/
2010 SCM_KEYWORD (k_setter
, "setter");
2011 SCM_KEYWORD (k_specializers
, "specializers");
2012 SCM_KEYWORD (k_procedure
, "procedure");
2013 SCM_KEYWORD (k_dsupers
, "dsupers");
2014 SCM_KEYWORD (k_slots
, "slots");
2015 SCM_KEYWORD (k_gf
, "generic-function");
2017 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2019 "Make a new object. @var{args} must contain the class and\n"
2020 "all necessary initialization information.")
2021 #define FUNC_NAME s_scm_make
2024 long len
= scm_ilength (args
);
2026 if (len
<= 0 || (len
& 1) == 0)
2027 SCM_WRONG_NUM_ARGS ();
2029 class = SCM_CAR(args
);
2030 args
= SCM_CDR(args
);
2032 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
2035 z
= scm_make_struct (class, SCM_INUM0
,
2036 scm_list_4 (SCM_EOL
,
2039 scm_make_mutex ()));
2041 z
= scm_make_struct (class, SCM_INUM0
,
2042 scm_list_3 (SCM_EOL
, SCM_INUM0
, SCM_BOOL_F
));
2044 scm_set_procedure_property_x (z
, scm_sym_name
,
2045 scm_get_keyword (k_name
,
2048 clear_method_cache (z
);
2049 if (class == scm_class_generic_with_setter
)
2051 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2052 if (!SCM_FALSEP (setter
))
2053 scm_sys_set_object_setter_x (z
, setter
);
2058 z
= scm_sys_allocate_instance (class, args
);
2060 if (class == scm_class_method
2061 || class == scm_class_simple_method
2062 || class == scm_class_accessor
)
2064 SCM_SET_SLOT (z
, scm_si_generic_function
,
2065 scm_i_get_keyword (k_gf
,
2070 SCM_SET_SLOT (z
, scm_si_specializers
,
2071 scm_i_get_keyword (k_specializers
,
2076 SCM_SET_SLOT (z
, scm_si_procedure
,
2077 scm_i_get_keyword (k_procedure
,
2082 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2086 /* In all the others case, make a new class .... No instance here */
2087 SCM_SET_SLOT (z
, scm_si_name
,
2088 scm_i_get_keyword (k_name
,
2091 scm_str2symbol ("???"),
2093 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2094 scm_i_get_keyword (k_dsupers
,
2099 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2100 scm_i_get_keyword (k_slots
,
2111 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2114 #define FUNC_NAME s_scm_find_method
2117 long len
= scm_ilength (l
);
2120 SCM_WRONG_NUM_ARGS ();
2122 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2123 SCM_VALIDATE_GENERIC (1, gf
);
2124 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2125 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2127 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2131 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2132 (SCM m1
, SCM m2
, SCM targs
),
2134 #define FUNC_NAME s_scm_sys_method_more_specific_p
2139 SCM_VALIDATE_METHOD (1, m1
);
2140 SCM_VALIDATE_METHOD (2, m2
);
2141 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2143 /* Verify that all the arguments of targs are classes and place them in a vector*/
2144 v
= scm_c_make_vector (len
, SCM_EOL
);
2146 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2147 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2148 SCM_VELTS(v
)[i
] = SCM_CAR(l
);
2150 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2156 /******************************************************************************
2160 ******************************************************************************/
2164 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2166 SCM tmp
= scm_str2symbol (name
);
2168 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2172 : scm_list_1 (super
),
2178 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2181 create_standard_classes (void)
2184 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2185 scm_str2symbol ("specializers"),
2187 scm_str2symbol ("code-table"));
2188 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2190 k_slot_definition
));
2192 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2194 SCM mutex_slot
= SCM_BOOL_F
;
2196 SCM gf_slots
= scm_list_4 (scm_str2symbol ("methods"),
2197 scm_list_3 (scm_str2symbol ("n-specialized"),
2200 scm_list_3 (scm_str2symbol ("used-by"),
2203 scm_list_3 (scm_str2symbol ("cache-mutex"),
2205 scm_closure (scm_list_2 (SCM_EOL
,
2209 /* Foreign class slot classes */
2210 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2211 scm_class_class
, scm_class_top
, SCM_EOL
);
2212 make_stdcls (&scm_class_protected
, "<protected-slot>",
2213 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2214 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2215 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2216 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2217 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2218 make_stdcls (&scm_class_self
, "<self-slot>",
2220 scm_list_2 (scm_class_foreign_slot
, scm_class_read_only
),
2222 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2224 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2226 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2228 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2230 make_stdcls (&scm_class_scm
, "<scm-slot>",
2231 scm_class_class
, scm_class_protected
, SCM_EOL
);
2232 make_stdcls (&scm_class_int
, "<int-slot>",
2233 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2234 make_stdcls (&scm_class_float
, "<float-slot>",
2235 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2236 make_stdcls (&scm_class_double
, "<double-slot>",
2237 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2239 /* Continue initialization of class <class> */
2241 slots
= build_class_class_slots ();
2242 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2243 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2244 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2245 compute_getters_n_setters (slots
));
2247 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2248 scm_class_class
, scm_class_class
,
2249 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2252 scm_list_3 (scm_str2symbol ("destructor"),
2254 scm_class_opaque
)));
2255 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2256 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2257 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2259 /* scm_class_generic functions classes */
2260 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2261 scm_class_class
, scm_class_class
, SCM_EOL
);
2262 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2263 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2264 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2265 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2266 make_stdcls (&scm_class_operator_with_setter_class
,
2267 "<operator-with-setter-class>",
2268 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2269 make_stdcls (&scm_class_method
, "<method>",
2270 scm_class_class
, scm_class_object
, method_slots
);
2271 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2272 scm_class_class
, scm_class_method
, SCM_EOL
);
2273 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2274 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2275 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2276 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2277 make_stdcls (&scm_class_entity
, "<entity>",
2278 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2279 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2280 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2281 make_stdcls (&scm_class_generic
, "<generic>",
2282 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2283 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2284 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2285 scm_class_entity_class
,
2286 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2289 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */
2290 SCM_SET_SLOT (scm_class_generic_with_setter
, scm_si_cpl
,
2291 scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter
,
2293 SCM_SLOT (scm_class_entity_with_setter
,
2297 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2299 /* Primitive types classes */
2300 make_stdcls (&scm_class_boolean
, "<boolean>",
2301 scm_class_class
, scm_class_top
, SCM_EOL
);
2302 make_stdcls (&scm_class_char
, "<char>",
2303 scm_class_class
, scm_class_top
, SCM_EOL
);
2304 make_stdcls (&scm_class_list
, "<list>",
2305 scm_class_class
, scm_class_top
, SCM_EOL
);
2306 make_stdcls (&scm_class_pair
, "<pair>",
2307 scm_class_class
, scm_class_list
, SCM_EOL
);
2308 make_stdcls (&scm_class_null
, "<null>",
2309 scm_class_class
, scm_class_list
, SCM_EOL
);
2310 make_stdcls (&scm_class_string
, "<string>",
2311 scm_class_class
, scm_class_top
, SCM_EOL
);
2312 make_stdcls (&scm_class_symbol
, "<symbol>",
2313 scm_class_class
, scm_class_top
, SCM_EOL
);
2314 make_stdcls (&scm_class_vector
, "<vector>",
2315 scm_class_class
, scm_class_top
, SCM_EOL
);
2316 make_stdcls (&scm_class_number
, "<number>",
2317 scm_class_class
, scm_class_top
, SCM_EOL
);
2318 make_stdcls (&scm_class_complex
, "<complex>",
2319 scm_class_class
, scm_class_number
, SCM_EOL
);
2320 make_stdcls (&scm_class_real
, "<real>",
2321 scm_class_class
, scm_class_complex
, SCM_EOL
);
2322 make_stdcls (&scm_class_integer
, "<integer>",
2323 scm_class_class
, scm_class_real
, SCM_EOL
);
2324 make_stdcls (&scm_class_keyword
, "<keyword>",
2325 scm_class_class
, scm_class_top
, SCM_EOL
);
2326 make_stdcls (&scm_class_unknown
, "<unknown>",
2327 scm_class_class
, scm_class_top
, SCM_EOL
);
2328 make_stdcls (&scm_class_procedure
, "<procedure>",
2329 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2330 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2331 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2332 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2333 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2334 make_stdcls (&scm_class_port
, "<port>",
2335 scm_class_class
, scm_class_top
, SCM_EOL
);
2336 make_stdcls (&scm_class_input_port
, "<input-port>",
2337 scm_class_class
, scm_class_port
, SCM_EOL
);
2338 make_stdcls (&scm_class_output_port
, "<output-port>",
2339 scm_class_class
, scm_class_port
, SCM_EOL
);
2340 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2342 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2346 /**********************************************************************
2350 **********************************************************************/
2353 make_class_from_template (char *template, char *type_name
, SCM supers
)
2359 sprintf (buffer
, template, type_name
);
2360 name
= scm_str2symbol (buffer
);
2363 name
= SCM_GOOPS_UNBOUND
;
2365 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2370 /* Only define name if doesn't already exist. */
2371 if (!SCM_GOOPS_UNBOUNDP (name
)
2372 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2373 DEFVAR (name
, class);
2378 scm_make_extended_class (char *type_name
)
2380 return make_class_from_template ("<%s>",
2382 scm_list_1 (scm_class_top
));
2386 create_smob_classes (void)
2390 scm_smob_class
= (SCM
*) malloc (255 * sizeof (SCM
));
2391 for (i
= 0; i
< 255; ++i
)
2392 scm_smob_class
[i
] = 0;
2394 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2395 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2396 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2397 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2399 for (i
= 0; i
< scm_numsmob
; ++i
)
2400 if (!scm_smob_class
[i
])
2401 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2405 scm_make_port_classes (long ptobnum
, char *type_name
)
2407 SCM c
, class = make_class_from_template ("<%s-port>",
2409 scm_list_1 (scm_class_port
));
2410 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2411 = make_class_from_template ("<%s-input-port>",
2413 scm_list_2 (class, scm_class_input_port
));
2414 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2415 = make_class_from_template ("<%s-output-port>",
2417 scm_list_2 (class, scm_class_output_port
));
2418 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2420 = make_class_from_template ("<%s-input-output-port>",
2422 scm_list_2 (class, scm_class_input_output_port
));
2423 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2424 SCM_SET_SLOT (c
, scm_si_cpl
,
2425 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2429 create_port_classes (void)
2433 scm_port_class
= (SCM
*) malloc (3 * 256 * sizeof (SCM
));
2434 for (i
= 0; i
< 3 * 256; ++i
)
2435 scm_port_class
[i
] = 0;
2437 for (i
= 0; i
< scm_numptob
; ++i
)
2438 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2442 make_struct_class (void *closure SCM_UNUSED
, SCM key SCM_UNUSED
,
2443 SCM data
, SCM prev SCM_UNUSED
)
2445 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2446 SCM_SET_STRUCT_TABLE_CLASS (data
,
2447 scm_make_extended_class
2448 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2449 return SCM_UNSPECIFIED
;
2453 create_struct_classes (void)
2455 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2458 /**********************************************************************
2462 **********************************************************************/
2467 if (!goops_loaded_p
)
2468 scm_c_resolve_module ("oop goops");
2473 scm_make_foreign_object (SCM
class, SCM initargs
)
2474 #define FUNC_NAME s_scm_make
2476 void * (*constructor
) (SCM
)
2477 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2478 if (constructor
== 0)
2479 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2480 return scm_wrap_object (class, constructor (initargs
));
2486 scm_free_foreign_object (SCM
*class, SCM
*data
)
2488 size_t (*destructor
) (void *)
2489 = (size_t (*) (void *)) class[scm_si_destructor
];
2490 return destructor (data
);
2494 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2495 void * (*constructor
) (SCM initargs
),
2496 size_t (*destructor
) (void *))
2499 name
= scm_str2symbol (s_name
);
2500 if (SCM_NULLP (supers
))
2501 supers
= scm_list_1 (scm_class_foreign_object
);
2502 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2503 scm_sys_inherit_magic_x (class, supers
);
2505 if (destructor
!= 0)
2507 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2508 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2512 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2513 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2516 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2517 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2522 SCM_SYMBOL (sym_o
, "o");
2523 SCM_SYMBOL (sym_x
, "x");
2525 SCM_KEYWORD (k_accessor
, "accessor");
2526 SCM_KEYWORD (k_getter
, "getter");
2529 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2531 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2536 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2537 SCM (*getter
) (SCM obj
),
2538 SCM (*setter
) (SCM obj
, SCM x
),
2539 char *accessor_name
)
2542 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2543 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2544 setter
? setter
: default_setter
);
2545 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2546 scm_list_2 (get
, sym_o
)),
2548 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2549 scm_list_3 (set
, sym_o
, sym_x
)),
2552 SCM name
= scm_str2symbol (slot_name
);
2553 SCM aname
= scm_str2symbol (accessor_name
);
2554 SCM gf
= scm_ensure_accessor (aname
);
2555 SCM slot
= scm_list_5 (name
,
2558 setter
? k_accessor
: k_getter
,
2560 SCM gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2562 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor
,
2567 scm_add_method (scm_setter (gf
),
2568 scm_make (scm_list_5 (scm_class_accessor
,
2570 scm_list_2 (class, scm_class_top
),
2575 SCM_SET_SLOT (class, scm_si_slots
,
2576 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2577 scm_list_1 (slot
))));
2578 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2579 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2580 scm_list_1 (gns
))));
2584 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2586 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2591 scm_wrap_object (SCM
class, void *data
)
2595 SCM_SETCDR (z
, SCM_PACK ((scm_t_bits
) data
));
2596 SCM_SET_STRUCT_GC_CHAIN (z
, 0);
2597 SCM_SETCAR (z
, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
);
2604 scm_wrap_component (SCM
class, SCM container
, void *data
)
2606 SCM obj
= scm_wrap_object (class, data
);
2607 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2613 SCM_SETCDR (handle
, container
);
2618 scm_ensure_accessor (SCM name
)
2620 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2621 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2623 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2624 gf
= scm_make (scm_list_5 (scm_class_generic_with_setter
,
2625 k_name
, name
, k_setter
, gf
));
2630 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2633 scm_add_method (SCM gf
, SCM m
)
2635 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2640 * Debugging utilities
2643 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2645 "Return @code{#t} if @var{obj} is a pure generic.")
2646 #define FUNC_NAME s_scm_pure_generic_p
2648 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2652 #endif /* GUILE_DEBUG */
2658 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2660 "Announce that GOOPS is loaded and perform initialization\n"
2661 "on the C level which depends on the loaded GOOPS modules.")
2662 #define FUNC_NAME s_scm_sys_goops_loaded
2665 var_compute_applicable_methods
=
2666 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2668 return SCM_UNSPECIFIED
;
2672 SCM scm_module_goops
;
2675 scm_init_goops_builtins (void)
2677 scm_module_goops
= scm_current_module ();
2678 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2680 /* Not really necessary right now, but who knows...
2682 scm_permanent_object (scm_module_goops
);
2683 scm_permanent_object (scm_goops_lookup_closure
);
2685 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2686 (SCM_MAKINUM (37)));
2688 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2690 #ifndef SCM_MAGIC_SNARFER
2691 #include "libguile/goops.x"
2694 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2696 hell
= scm_must_malloc (hell_size
, "hell");
2698 scm_mutex_init (&hell_mutex
);
2701 create_basic_classes ();
2702 create_standard_classes ();
2703 create_smob_classes ();
2704 create_struct_classes ();
2705 create_port_classes ();
2708 SCM name
= scm_str2symbol ("no-applicable-method");
2709 scm_no_applicable_method
2710 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2713 DEFVAR (name
, scm_no_applicable_method
);
2716 return SCM_UNSPECIFIED
;
2722 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2723 scm_init_goops_builtins
);