1 /* Copyright (C) 1998,1999,2000,2001, 2002, 2003 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
;
141 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
142 SCM scm_class_method
;
143 SCM scm_class_simple_method
, scm_class_accessor
;
144 SCM scm_class_procedure_class
;
145 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
146 SCM scm_class_entity_class
;
147 SCM scm_class_number
, scm_class_list
;
148 SCM scm_class_keyword
;
149 SCM scm_class_port
, scm_class_input_output_port
;
150 SCM scm_class_input_port
, scm_class_output_port
;
151 SCM scm_class_foreign_class
, scm_class_foreign_object
;
152 SCM scm_class_foreign_slot
;
153 SCM scm_class_self
, scm_class_protected
;
154 SCM scm_class_opaque
, scm_class_read_only
;
155 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
157 SCM scm_class_int
, scm_class_float
, scm_class_double
;
159 SCM_SYMBOL (scm_sym_define_public
, "define-public");
161 static SCM
scm_make_unbound (void);
162 static SCM
scm_unbound_p (SCM obj
);
163 static SCM
scm_assert_bound (SCM value
, SCM obj
);
164 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
165 static SCM
scm_sys_goops_loaded (void);
167 /******************************************************************************
171 * This version doesn't fully handle multiple-inheritance. It serves
172 * only for booting classes and will be overloaded in Scheme
174 ******************************************************************************/
177 map (SCM (*proc
) (SCM
), SCM ls
)
183 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
186 while (!SCM_NULLP (ls
))
188 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
200 while (!SCM_NULLP (ls
))
202 SCM el
= SCM_CAR (ls
);
203 if (SCM_FALSEP (scm_c_memq (el
, res
)))
204 res
= scm_cons (el
, res
);
211 compute_cpl (SCM
class)
214 return CALL_GF1 ("compute-cpl", class);
217 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
218 SCM ls
= scm_append (scm_acons (class, supers
,
219 map (compute_cpl
, supers
)));
220 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
224 /******************************************************************************
228 ******************************************************************************/
231 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
239 if (!SCM_SYMBOLP (tmp
))
240 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
242 if (SCM_FALSEP (scm_c_memq (tmp
, slots_already_seen
))) {
243 res
= scm_cons (SCM_CAR (l
), res
);
244 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
247 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
251 build_slots_list (SCM dslots
, SCM cpl
)
253 register SCM res
= dslots
;
255 for (cpl
= SCM_CDR (cpl
); !SCM_NULLP (cpl
); cpl
= SCM_CDR (cpl
))
256 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
257 scm_si_direct_slots
),
260 /* res contains a list of slots. Remove slots which appears more than once */
261 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
268 while (!SCM_NULLP (ls
))
270 if (!SCM_CONSP (SCM_CAR (ls
)))
271 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
278 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
280 "Return a list consisting of the names of all slots belonging to\n"
281 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
283 #define FUNC_NAME s_scm_sys_compute_slots
285 SCM_VALIDATE_CLASS (1, class);
286 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
287 SCM_SLOT (class, scm_si_cpl
));
292 /******************************************************************************
294 * compute-getters-n-setters
296 * This version doesn't handle slot options. It serves only for booting
297 * classes and will be overloaded in Scheme.
299 ******************************************************************************/
301 SCM_KEYWORD (k_init_value
, "init-value");
302 SCM_KEYWORD (k_init_thunk
, "init-thunk");
305 compute_getters_n_setters (SCM slots
)
311 for ( ; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
313 SCM init
= SCM_BOOL_F
;
314 SCM options
= SCM_CDAR (slots
);
315 if (!SCM_NULLP (options
))
317 init
= scm_get_keyword (k_init_value
, options
, 0);
319 init
= scm_closure (scm_list_2 (SCM_EOL
,
320 scm_list_2 (scm_sym_quote
, init
)),
323 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
325 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
329 cdrloc
= SCM_CDRLOC (*cdrloc
);
334 /******************************************************************************
338 ******************************************************************************/
340 /*fixme* Manufacture keywords in advance */
342 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
346 for (i
= 0; i
!= len
; i
+= 2)
348 SCM obj
= SCM_CAR (l
);
350 if (!SCM_KEYWORDP (obj
))
351 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
352 else if (SCM_EQ_P (obj
, key
))
358 return default_value
;
362 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
363 (SCM key
, SCM l
, SCM default_value
),
364 "Determine an associated value for the keyword @var{key} from\n"
365 "the list @var{l}. The list @var{l} has to consist of an even\n"
366 "number of elements, where, starting with the first, every\n"
367 "second element is a keyword, followed by its associated value.\n"
368 "If @var{l} does not hold a value for @var{key}, the value\n"
369 "@var{default_value} is returned.")
370 #define FUNC_NAME s_scm_get_keyword
374 SCM_ASSERT (SCM_KEYWORDP (key
), key
, SCM_ARG1
, FUNC_NAME
);
375 len
= scm_ilength (l
);
376 if (len
< 0 || len
% 2 == 1)
377 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
379 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
384 SCM_KEYWORD (k_init_keyword
, "init-keyword");
386 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
387 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
389 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
390 (SCM obj
, SCM initargs
),
391 "Initialize the object @var{obj} with the given arguments\n"
393 #define FUNC_NAME s_scm_sys_initialize_object
395 SCM tmp
, get_n_set
, slots
;
396 SCM
class = SCM_CLASS_OF (obj
);
399 SCM_VALIDATE_INSTANCE (1, obj
);
400 n_initargs
= scm_ilength (initargs
);
401 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
403 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
404 slots
= SCM_SLOT (class, scm_si_slots
);
406 /* See for each slot how it must be initialized */
409 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
411 SCM slot_name
= SCM_CAR (slots
);
414 if (!SCM_NULLP (SCM_CDR (slot_name
)))
416 /* This slot admits (perhaps) to be initialized at creation time */
417 long n
= scm_ilength (SCM_CDR (slot_name
));
418 if (n
& 1) /* odd or -1 */
419 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
420 scm_list_1 (slot_name
));
421 tmp
= scm_i_get_keyword (k_init_keyword
,
426 slot_name
= SCM_CAR (slot_name
);
429 /* an initarg was provided for this slot */
430 if (!SCM_KEYWORDP (tmp
))
431 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
433 slot_value
= scm_i_get_keyword (tmp
,
442 /* set slot to provided value */
443 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
446 /* set slot to its :init-form if it exists */
447 tmp
= SCM_CADAR (get_n_set
);
448 if (tmp
!= SCM_BOOL_F
)
450 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
451 if (SCM_GOOPS_UNBOUNDP (slot_value
))
453 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
454 set_slot_value (class,
457 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
468 SCM_KEYWORD (k_class
, "class");
469 SCM_KEYWORD (k_allocation
, "allocation");
470 SCM_KEYWORD (k_instance
, "instance");
472 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
475 #define FUNC_NAME s_scm_sys_prep_layout_x
478 unsigned long int n
, i
;
481 SCM_VALIDATE_INSTANCE (1, class);
482 slots
= SCM_SLOT (class, scm_si_slots
);
483 nfields
= SCM_SLOT (class, scm_si_nfields
);
484 if (!SCM_INUMP (nfields
) || SCM_INUM (nfields
) < 0)
485 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
486 scm_list_1 (nfields
));
487 n
= 2 * SCM_INUM (nfields
);
488 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
489 && SCM_SUBCLASSP (class, scm_class_class
))
490 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
491 scm_list_1 (nfields
));
493 s
= n
> 0 ? scm_malloc (n
) : 0;
494 for (i
= 0; i
< n
; i
+= 2)
497 SCM type
, allocation
;
500 if (!SCM_CONSP (slots
))
501 SCM_MISC_ERROR ("too few slot definitions", SCM_EOL
);
502 len
= scm_ilength (SCM_CDAR (slots
));
503 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
504 len
, k_instance
, FUNC_NAME
);
505 while (!SCM_EQ_P (allocation
, k_instance
))
507 slots
= SCM_CDR (slots
);
508 len
= scm_ilength (SCM_CDAR (slots
));
509 allocation
= scm_i_get_keyword (k_allocation
, SCM_CDAR (slots
),
510 len
, k_instance
, FUNC_NAME
);
512 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
513 len
, SCM_BOOL_F
, FUNC_NAME
);
514 if (SCM_FALSEP (type
))
521 if (!SCM_CLASSP (type
))
522 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
523 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
525 if (SCM_SUBCLASSP (type
, scm_class_self
))
527 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
532 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
534 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
547 slots
= SCM_CDR (slots
);
549 SCM_SET_SLOT (class, scm_si_layout
, scm_mem2symbol (s
, n
));
552 return SCM_UNSPECIFIED
;
556 static void prep_hashsets (SCM
);
558 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
559 (SCM
class, SCM dsupers
),
561 #define FUNC_NAME s_scm_sys_inherit_magic_x
565 SCM_VALIDATE_INSTANCE (1, class);
566 while (!SCM_NULLP (ls
))
568 SCM_ASSERT (SCM_CONSP (ls
)
569 && SCM_INSTANCEP (SCM_CAR (ls
)),
573 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
576 flags
&= SCM_CLASSF_INHERIT
;
577 if (flags
& SCM_CLASSF_ENTITY
)
578 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
581 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
584 * We could avoid calling scm_gc_malloc in the allocation code
585 * (in which case the following two lines are needed). Instead
586 * we make 0-slot instances non-light, so that the light case
587 * can be handled without special cases.
590 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
592 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
594 /* NOTE: The following depends on scm_struct_i_size. */
595 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
596 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
599 SCM_SET_CLASS_FLAGS (class, flags
);
601 prep_hashsets (class);
603 return SCM_UNSPECIFIED
;
608 prep_hashsets (SCM
class)
612 for (i
= 0; i
< 7; ++i
)
613 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
616 /******************************************************************************/
619 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
621 SCM z
, cpl
, slots
, nfields
, g_n_s
;
623 /* Allocate one instance */
624 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
626 /* Initialize its slots */
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_vtable
, k_class
, scm_class_self
),
711 scm_list_1 (sym_print
),
712 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
713 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
714 scm_list_1 (sym_redefined
),
715 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
716 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
717 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
718 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
719 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
720 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
721 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
722 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
723 scm_list_1 (sym_name
),
724 scm_list_1 (sym_direct_supers
),
725 scm_list_1 (sym_direct_slots
),
726 scm_list_1 (sym_direct_subclasses
),
727 scm_list_1 (sym_direct_methods
),
728 scm_list_1 (sym_cpl
),
729 scm_list_1 (sym_default_slot_definition_class
),
730 scm_list_1 (sym_slots
),
731 scm_list_1 (sym_getters_n_setters
),
732 scm_list_1 (sym_keyword_access
),
733 scm_list_1 (sym_nfields
),
734 scm_list_1 (sym_environment
),
739 create_basic_classes (void)
741 /* SCM slots_of_class = build_class_class_slots (); */
743 /**** <scm_class_class> ****/
744 SCM cs
= scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT
745 + 2 * scm_vtable_offset_user
);
746 SCM name
= scm_str2symbol ("<class>");
747 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
750 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
751 | SCM_CLASSF_METACLASS
));
753 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
754 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
755 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
756 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
757 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
758 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
759 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
760 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, SCM_MAKINUM (SCM_N_CLASS_SLOTS
));
761 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
762 compute_getters_n_setters (slots_of_class)); */
763 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
764 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
765 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
767 prep_hashsets (scm_class_class
);
769 DEFVAR(name
, scm_class_class
);
771 /**** <scm_class_top> ****/
772 name
= scm_str2symbol ("<top>");
773 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
778 DEFVAR(name
, scm_class_top
);
780 /**** <scm_class_object> ****/
781 name
= scm_str2symbol ("<object>");
782 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
784 scm_list_1 (scm_class_top
),
787 DEFVAR (name
, scm_class_object
);
789 /* <top> <object> and <class> were partially initialized. Correct them here */
790 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
792 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
793 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
796 /******************************************************************************/
798 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
800 "Return @code{#t} if @var{obj} is an instance.")
801 #define FUNC_NAME s_scm_instance_p
803 return SCM_BOOL (SCM_INSTANCEP (obj
));
808 /******************************************************************************
810 * Meta object accessors
812 ******************************************************************************/
813 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
815 "Return the class name of @var{obj}.")
816 #define FUNC_NAME s_scm_class_name
818 SCM_VALIDATE_CLASS (1, obj
);
819 return scm_slot_ref (obj
, sym_name
);
823 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
825 "Return the direct superclasses of the class @var{obj}.")
826 #define FUNC_NAME s_scm_class_direct_supers
828 SCM_VALIDATE_CLASS (1, obj
);
829 return scm_slot_ref (obj
, sym_direct_supers
);
833 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
835 "Return the direct slots of the class @var{obj}.")
836 #define FUNC_NAME s_scm_class_direct_slots
838 SCM_VALIDATE_CLASS (1, obj
);
839 return scm_slot_ref (obj
, sym_direct_slots
);
843 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
845 "Return the direct subclasses of the class @var{obj}.")
846 #define FUNC_NAME s_scm_class_direct_subclasses
848 SCM_VALIDATE_CLASS (1, obj
);
849 return scm_slot_ref(obj
, sym_direct_subclasses
);
853 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
855 "Return the direct methods of the class @var{obj}")
856 #define FUNC_NAME s_scm_class_direct_methods
858 SCM_VALIDATE_CLASS (1, obj
);
859 return scm_slot_ref (obj
, sym_direct_methods
);
863 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
865 "Return the class precedence list of the class @var{obj}.")
866 #define FUNC_NAME s_scm_class_precedence_list
868 SCM_VALIDATE_CLASS (1, obj
);
869 return scm_slot_ref (obj
, sym_cpl
);
873 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
875 "Return the slot list of the class @var{obj}.")
876 #define FUNC_NAME s_scm_class_slots
878 SCM_VALIDATE_CLASS (1, obj
);
879 return scm_slot_ref (obj
, sym_slots
);
883 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
885 "Return the environment of the class @var{obj}.")
886 #define FUNC_NAME s_scm_class_environment
888 SCM_VALIDATE_CLASS (1, obj
);
889 return scm_slot_ref(obj
, sym_environment
);
894 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
896 "Return the name of the generic function @var{obj}.")
897 #define FUNC_NAME s_scm_generic_function_name
899 SCM_VALIDATE_GENERIC (1, obj
);
900 return scm_procedure_property (obj
, scm_sym_name
);
904 SCM_SYMBOL (sym_methods
, "methods");
905 SCM_SYMBOL (sym_extended_by
, "extended-by");
906 SCM_SYMBOL (sym_extends
, "extends");
909 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
911 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
912 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
913 while (!SCM_NULLP (gfs
))
915 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
922 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
924 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
926 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
927 while (!SCM_NULLP (gfs
))
929 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
930 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
939 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
941 "Return the methods of the generic function @var{obj}.")
942 #define FUNC_NAME s_scm_generic_function_methods
945 SCM_VALIDATE_GENERIC (1, obj
);
946 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
947 methods
= fold_downward_gf_methods (methods
, obj
);
948 return scm_append (methods
);
952 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
954 "Return the generic function for the method @var{obj}.")
955 #define FUNC_NAME s_scm_method_generic_function
957 SCM_VALIDATE_METHOD (1, obj
);
958 return scm_slot_ref (obj
, scm_str2symbol ("generic-function"));
962 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
964 "Return specializers of the method @var{obj}.")
965 #define FUNC_NAME s_scm_method_specializers
967 SCM_VALIDATE_METHOD (1, obj
);
968 return scm_slot_ref (obj
, scm_str2symbol ("specializers"));
972 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
974 "Return the procedure of the method @var{obj}.")
975 #define FUNC_NAME s_scm_method_procedure
977 SCM_VALIDATE_METHOD (1, obj
);
978 return scm_slot_ref (obj
, sym_procedure
);
982 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
984 "Return the slot definition of the accessor @var{obj}.")
985 #define FUNC_NAME s_scm_accessor_method_slot_definition
987 SCM_VALIDATE_ACCESSOR (1, obj
);
988 return scm_slot_ref (obj
, scm_str2symbol ("slot-definition"));
992 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
994 "Internal GOOPS magic---don't use this function!")
995 #define FUNC_NAME s_scm_sys_tag_body
997 return scm_cons (SCM_IM_LAMBDA
, body
);
1001 /******************************************************************************
1003 * S l o t a c c e s s
1005 ******************************************************************************/
1007 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1009 "Return the unbound value.")
1010 #define FUNC_NAME s_scm_make_unbound
1012 return SCM_GOOPS_UNBOUND
;
1016 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1018 "Return @code{#t} if @var{obj} is unbound.")
1019 #define FUNC_NAME s_scm_unbound_p
1021 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1025 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1026 (SCM value
, SCM obj
),
1027 "Return @var{value} if it is bound, and invoke the\n"
1028 "@var{slot-unbound} method of @var{obj} if it is not.")
1029 #define FUNC_NAME s_scm_assert_bound
1031 if (SCM_GOOPS_UNBOUNDP (value
))
1032 return CALL_GF1 ("slot-unbound", obj
);
1037 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1038 (SCM obj
, SCM index
),
1039 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1040 "the value from @var{obj}.")
1041 #define FUNC_NAME s_scm_at_assert_bound_ref
1043 SCM value
= SCM_SLOT (obj
, SCM_INUM (index
));
1044 if (SCM_GOOPS_UNBOUNDP (value
))
1045 return CALL_GF1 ("slot-unbound", obj
);
1050 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1051 (SCM obj
, SCM index
),
1052 "Return the slot value with index @var{index} from @var{obj}.")
1053 #define FUNC_NAME s_scm_sys_fast_slot_ref
1055 unsigned long int i
;
1057 SCM_VALIDATE_INSTANCE (1, obj
);
1058 SCM_VALIDATE_INUM (2, index
);
1059 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1060 i
= SCM_INUM (index
);
1061 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1063 return scm_at_assert_bound_ref (obj
, index
);
1067 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1068 (SCM obj
, SCM index
, SCM value
),
1069 "Set the slot with index @var{index} in @var{obj} to\n"
1071 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1073 unsigned long int i
;
1075 SCM_VALIDATE_INSTANCE (1, obj
);
1076 SCM_VALIDATE_INUM (2, index
);
1077 SCM_ASSERT_RANGE (2, index
, SCM_INUM (index
) >= 0);
1078 i
= SCM_INUM (index
);
1079 SCM_ASSERT_RANGE (2, index
, i
< SCM_NUMBER_OF_SLOTS (obj
));
1081 SCM_SET_SLOT (obj
, i
, value
);
1083 return SCM_UNSPECIFIED
;
1090 /* In the future, this function will return the effective slot
1091 * definition associated with SLOT_NAME. Now it just returns some of
1092 * the information which will be stored in the effective slot
1097 slot_definition_using_name (SCM
class, SCM slot_name
)
1099 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1100 for (; !SCM_NULLP (slots
); slots
= SCM_CDR (slots
))
1101 if (SCM_CAAR (slots
) == slot_name
)
1102 return SCM_CAR (slots
);
1107 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1109 SCM access
= SCM_CDDR (slotdef
);
1111 * - access is an integer (the offset of this slot in the slots vector)
1112 * - otherwise (car access) is the getter function to apply
1114 if (SCM_INUMP (access
))
1115 return SCM_SLOT (obj
, SCM_INUM (access
));
1118 /* We must evaluate (apply (car access) (list obj))
1119 * where (car access) is known to be a closure of arity 1 */
1120 register SCM code
, env
;
1122 code
= SCM_CAR (access
);
1123 if (!SCM_CLOSUREP (code
))
1124 return SCM_SUBRF (code
) (obj
);
1125 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1128 /* Evaluate the closure body */
1129 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1134 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1136 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1137 if (!SCM_FALSEP (slotdef
))
1138 return get_slot_value (class, obj
, slotdef
);
1140 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1144 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1146 SCM access
= SCM_CDDR (slotdef
);
1148 * - access is an integer (the offset of this slot in the slots vector)
1149 * - otherwise (cadr access) is the setter function to apply
1151 if (SCM_INUMP (access
))
1152 SCM_SET_SLOT (obj
, SCM_INUM (access
), value
);
1155 /* We must evaluate (apply (cadr l) (list obj value))
1156 * where (cadr l) is known to be a closure of arity 2 */
1157 register SCM code
, env
;
1159 code
= SCM_CADR (access
);
1160 if (!SCM_CLOSUREP (code
))
1161 SCM_SUBRF (code
) (obj
, value
);
1164 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1165 scm_list_2 (obj
, value
),
1167 /* Evaluate the closure body */
1168 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1171 return SCM_UNSPECIFIED
;
1175 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1177 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1178 if (!SCM_FALSEP (slotdef
))
1179 return set_slot_value (class, obj
, slotdef
, value
);
1181 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1185 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1189 for (l
= SCM_ACCESSORS_OF (obj
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1190 if (SCM_EQ_P (SCM_CAAR (l
), slot_name
))
1196 /* ======================================== */
1198 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1199 (SCM
class, SCM obj
, SCM slot_name
),
1201 #define FUNC_NAME s_scm_slot_ref_using_class
1205 SCM_VALIDATE_CLASS (1, class);
1206 SCM_VALIDATE_INSTANCE (2, obj
);
1207 SCM_VALIDATE_SYMBOL (3, slot_name
);
1209 res
= get_slot_value_using_name (class, obj
, slot_name
);
1210 if (SCM_GOOPS_UNBOUNDP (res
))
1211 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1217 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1218 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1220 #define FUNC_NAME s_scm_slot_set_using_class_x
1222 SCM_VALIDATE_CLASS (1, class);
1223 SCM_VALIDATE_INSTANCE (2, obj
);
1224 SCM_VALIDATE_SYMBOL (3, slot_name
);
1226 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1231 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1232 (SCM
class, SCM obj
, SCM slot_name
),
1234 #define FUNC_NAME s_scm_slot_bound_using_class_p
1236 SCM_VALIDATE_CLASS (1, class);
1237 SCM_VALIDATE_INSTANCE (2, obj
);
1238 SCM_VALIDATE_SYMBOL (3, slot_name
);
1240 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1246 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1247 (SCM
class, SCM obj
, SCM slot_name
),
1249 #define FUNC_NAME s_scm_slot_exists_using_class_p
1251 SCM_VALIDATE_CLASS (1, class);
1252 SCM_VALIDATE_INSTANCE (2, obj
);
1253 SCM_VALIDATE_SYMBOL (3, slot_name
);
1254 return test_slot_existence (class, obj
, slot_name
);
1259 /* ======================================== */
1261 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1262 (SCM obj
, SCM slot_name
),
1263 "Return the value from @var{obj}'s slot with the name\n"
1265 #define FUNC_NAME s_scm_slot_ref
1269 SCM_VALIDATE_INSTANCE (1, obj
);
1270 TEST_CHANGE_CLASS (obj
, class);
1272 res
= get_slot_value_using_name (class, obj
, slot_name
);
1273 if (SCM_GOOPS_UNBOUNDP (res
))
1274 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1279 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1280 (SCM obj
, SCM slot_name
, SCM value
),
1281 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1282 #define FUNC_NAME s_scm_slot_set_x
1286 SCM_VALIDATE_INSTANCE (1, obj
);
1287 TEST_CHANGE_CLASS(obj
, class);
1289 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1293 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1295 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1296 (SCM obj
, SCM slot_name
),
1297 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1299 #define FUNC_NAME s_scm_slot_bound_p
1303 SCM_VALIDATE_INSTANCE (1, obj
);
1304 TEST_CHANGE_CLASS(obj
, class);
1306 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1314 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1315 (SCM obj
, SCM slot_name
),
1316 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1317 #define FUNC_NAME s_scm_slot_exists_p
1321 SCM_VALIDATE_INSTANCE (1, obj
);
1322 SCM_VALIDATE_SYMBOL (2, slot_name
);
1323 TEST_CHANGE_CLASS (obj
, class);
1325 return test_slot_existence (class, obj
, slot_name
);
1330 /******************************************************************************
1332 * %allocate-instance (the low level instance allocation primitive)
1334 ******************************************************************************/
1336 static void clear_method_cache (SCM
);
1339 wrap_init (SCM
class, SCM
*m
, long n
)
1343 /* Set all slots to unbound */
1344 for (i
= 0; i
< n
; i
++)
1345 m
[i
] = SCM_GOOPS_UNBOUND
;
1347 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1349 (scm_t_bits
) m
, 0, 0);
1352 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1353 (SCM
class, SCM initargs
),
1354 "Create a new instance of class @var{class} and initialize it\n"
1355 "from the arguments @var{initargs}.")
1356 #define FUNC_NAME s_scm_sys_allocate_instance
1361 SCM_VALIDATE_CLASS (1, class);
1363 /* Most instances */
1364 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1366 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1367 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1368 return wrap_init (class, m
, n
);
1371 /* Foreign objects */
1372 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1373 return scm_make_foreign_object (class, initargs
);
1375 n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
1378 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1380 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1382 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1383 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1384 /* Generic functions */
1385 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1387 SCM gf
= wrap_init (class, m
, n
);
1388 clear_method_cache (gf
);
1392 return wrap_init (class, m
, n
);
1396 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1400 /* allocate class object */
1401 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1403 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1404 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1405 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1407 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1408 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1409 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1410 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1415 /* Non-light instances */
1417 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1418 return wrap_init (class, m
, n
);
1423 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1424 (SCM obj
, SCM setter
),
1426 #define FUNC_NAME s_scm_sys_set_object_setter_x
1428 SCM_ASSERT (SCM_STRUCTP (obj
)
1429 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1430 || SCM_I_ENTITYP (obj
)),
1434 if (SCM_I_ENTITYP (obj
))
1435 SCM_SET_ENTITY_SETTER (obj
, setter
);
1437 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1438 return SCM_UNSPECIFIED
;
1442 /******************************************************************************
1444 * %modify-instance (used by change-class to modify in place)
1446 ******************************************************************************/
1448 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1451 #define FUNC_NAME s_scm_sys_modify_instance
1453 SCM_VALIDATE_INSTANCE (1, old
);
1454 SCM_VALIDATE_INSTANCE (2, new);
1456 /* Exchange the data contained in old and new. We exchange rather than
1457 * scratch the old value with new to be correct with GC.
1458 * See "Class redefinition protocol above".
1462 SCM car
= SCM_CAR (old
);
1463 SCM cdr
= SCM_CDR (old
);
1464 SCM_SETCAR (old
, SCM_CAR (new));
1465 SCM_SETCDR (old
, SCM_CDR (new));
1466 SCM_SETCAR (new, car
);
1467 SCM_SETCDR (new, cdr
);
1470 return SCM_UNSPECIFIED
;
1474 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1477 #define FUNC_NAME s_scm_sys_modify_class
1479 SCM_VALIDATE_CLASS (1, old
);
1480 SCM_VALIDATE_CLASS (2, new);
1484 SCM car
= SCM_CAR (old
);
1485 SCM cdr
= SCM_CDR (old
);
1486 SCM_SETCAR (old
, SCM_CAR (new));
1487 SCM_SETCDR (old
, SCM_CDR (new));
1488 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1489 SCM_SETCAR (new, car
);
1490 SCM_SETCDR (new, cdr
);
1491 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1494 return SCM_UNSPECIFIED
;
1498 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1501 #define FUNC_NAME s_scm_sys_invalidate_class
1503 SCM_VALIDATE_CLASS (1, class);
1504 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1505 return SCM_UNSPECIFIED
;
1509 /* When instances change class, they finally get a new body, but
1510 * before that, they go through purgatory in hell. Odd as it may
1511 * seem, this data structure saves us from eternal suffering in
1512 * infinite recursions.
1515 static scm_t_bits
**hell
;
1516 static long n_hell
= 1; /* one place for the evil one himself */
1517 static long hell_size
= 4;
1518 static SCM hell_mutex
;
1524 for (i
= 1; i
< n_hell
; ++i
)
1525 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1531 go_to_hell (void *o
)
1533 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1534 scm_lock_mutex (hell_mutex
);
1535 if (n_hell
== hell_size
)
1537 long new_size
= 2 * hell_size
;
1538 hell
= scm_realloc (hell
, new_size
);
1539 hell_size
= new_size
;
1541 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1542 scm_unlock_mutex (hell_mutex
);
1546 go_to_heaven (void *o
)
1548 scm_lock_mutex (hell_mutex
);
1549 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1550 scm_unlock_mutex (hell_mutex
);
1554 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1557 purgatory (void *args
)
1559 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1560 SCM_PACK ((scm_t_bits
) args
));
1564 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1567 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1568 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1569 (void *) SCM_UNPACK (obj
));
1572 /******************************************************************************
1578 * GGG E N E R I C F U N C T I O N S
1580 * This implementation provides
1581 * - generic functions (with class specializers)
1584 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1586 ******************************************************************************/
1588 SCM_KEYWORD (k_name
, "name");
1590 SCM_SYMBOL (sym_no_method
, "no-method");
1592 static SCM list_of_no_method
;
1594 SCM_SYMBOL (scm_sym_args
, "args");
1597 scm_make_method_cache (SCM gf
)
1599 return scm_list_5 (SCM_IM_DISPATCH
,
1602 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1608 clear_method_cache (SCM gf
)
1610 SCM cache
= scm_make_method_cache (gf
);
1611 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1612 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1615 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1618 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1621 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1622 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1623 if (!SCM_FALSEP (used_by
))
1625 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1626 for (; SCM_CONSP (used_by
); used_by
= SCM_CDR (used_by
))
1627 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1628 clear_method_cache (gf
);
1629 for (; SCM_CONSP (methods
); methods
= SCM_CDR (methods
))
1630 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1633 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1634 /* The sign of n is a flag indicating rest args. */
1635 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1637 return SCM_UNSPECIFIED
;
1641 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1644 #define FUNC_NAME s_scm_generic_capability_p
1646 SCM_ASSERT (!SCM_FALSEP (scm_procedure_p (proc
)),
1647 proc
, SCM_ARG1
, FUNC_NAME
);
1648 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1654 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1657 #define FUNC_NAME s_scm_enable_primitive_generic_x
1659 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1660 while (!SCM_NULLP (subrs
))
1662 SCM subr
= SCM_CAR (subrs
);
1663 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1664 subr
, SCM_ARGn
, FUNC_NAME
);
1665 *SCM_SUBR_GENERIC (subr
)
1666 = scm_make (scm_list_3 (scm_class_generic
,
1669 subrs
= SCM_CDR (subrs
);
1671 return SCM_UNSPECIFIED
;
1675 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1678 #define FUNC_NAME s_scm_primitive_generic_generic
1680 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1682 SCM gf
= *SCM_SUBR_GENERIC (subr
);
1686 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1690 /******************************************************************************
1692 * Protocol for calling a generic fumction
1693 * This protocol is roughly equivalent to (parameter are a little bit different
1694 * for efficiency reasons):
1696 * + apply-generic (gf args)
1697 * + compute-applicable-methods (gf args ...)
1698 * + sort-applicable-methods (methods args)
1699 * + apply-methods (gf methods args)
1701 * apply-methods calls make-next-method to build the "continuation" of a a
1702 * method. Applying a next-method will call apply-next-method which in
1703 * turn will call apply again to call effectively the following method.
1705 ******************************************************************************/
1708 applicablep (SCM actual
, SCM formal
)
1710 /* We already know that the cpl is well formed. */
1711 return !SCM_FALSEP (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1715 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1717 register SCM s1
, s2
;
1721 * m1 and m2 can have != length (i.e. one can be one element longer than the
1722 * other when we have a dotted parameter list). For instance, with the call
1725 * (define-method M (a . l) ....)
1726 * (define-method M (a) ....)
1728 * we consider that the second method is more specific.
1730 * BTW, targs is an array of types. We don't need it's size since
1731 * we already know that m1 and m2 are applicable (no risk to go past
1732 * the end of this array).
1735 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1736 if (SCM_NULLP(s1
)) return 1;
1737 if (SCM_NULLP(s2
)) return 0;
1738 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1739 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1741 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1742 if (cs1
== SCM_CAR(l
))
1744 if (cs2
== SCM_CAR(l
))
1747 return 0;/* should not occur! */
1750 return 0; /* should not occur! */
1753 #define BUFFSIZE 32 /* big enough for most uses */
1756 scm_i_vector2list (SCM l
, long len
)
1759 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1761 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1762 SCM_VECTOR_SET (z
, j
, SCM_CAR (l
));
1768 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1771 SCM
*v
, vector
= SCM_EOL
;
1772 SCM buffer
[BUFFSIZE
];
1773 SCM save
= method_list
;
1775 /* For reasonably sized method_lists we can try to avoid all the
1776 * consing and reorder the list in place...
1777 * This idea is due to David McClain <Dave_McClain@msn.com>
1779 if (size
<= BUFFSIZE
)
1781 for (i
= 0; i
< size
; i
++)
1783 buffer
[i
] = SCM_CAR (method_list
);
1784 method_list
= SCM_CDR (method_list
);
1790 /* Too many elements in method_list to keep everything locally */
1791 vector
= scm_i_vector2list (save
, size
);
1794 This is a new vector. Don't worry about the write barrier.
1795 We're not allocating elements in this routine, so this should
1798 v
= SCM_WRITABLE_VELTS (vector
);
1801 /* Use a simple shell sort since it is generally faster than qsort on
1802 * small vectors (which is probably mostly the case when we have to
1803 * sort a list of applicable methods).
1805 for (incr
= size
/ 2; incr
; incr
/= 2)
1807 for (i
= incr
; i
< size
; i
++)
1809 for (j
= i
- incr
; j
>= 0; j
-= incr
)
1811 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
1815 SCM tmp
= v
[j
+ incr
];
1823 if (size
<= BUFFSIZE
)
1825 /* We did it in locally, so restore the original list (reordered) in-place */
1826 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
1828 SCM_SETCAR (method_list
, *v
);
1829 method_list
= SCM_CDR (method_list
);
1833 /* If we are here, that's that we did it the hard way... */
1834 return scm_vector_to_list (vector
);
1838 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
1842 SCM l
, fl
, applicable
= SCM_EOL
;
1844 SCM buffer
[BUFFSIZE
];
1849 /* Build the list of arguments types */
1850 if (len
>= BUFFSIZE
) {
1851 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1852 /* NOTE: Using pointers to malloced memory won't work if we
1853 1. have preemtive threading, and,
1854 2. have a GC which moves objects. */
1855 types
= p
= SCM_WRITABLE_VELTS(tmp
);
1858 note that we don't have to work to reset the generation
1859 count. TMP is a new vector anyway, and it is found
1866 for ( ; !SCM_NULLP (args
); args
= SCM_CDR (args
))
1867 *p
++ = scm_class_of (SCM_CAR (args
));
1869 /* Build a list of all applicable methods */
1870 for (l
= scm_generic_function_methods (gf
); !SCM_NULLP (l
); l
= SCM_CDR (l
))
1872 fl
= SPEC_OF (SCM_CAR (l
));
1873 /* Only accept accessors which match exactly in first arg. */
1874 if (SCM_ACCESSORP (SCM_CAR (l
))
1875 && (SCM_NULLP (fl
) || types
[0] != SCM_CAR (fl
)))
1877 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
1879 if (SCM_INSTANCEP (fl
)
1880 /* We have a dotted argument list */
1881 || (i
>= len
&& SCM_NULLP (fl
)))
1882 { /* both list exhausted */
1883 applicable
= scm_cons (SCM_CAR (l
), applicable
);
1889 || !applicablep (types
[i
], SCM_CAR (fl
)))
1898 CALL_GF2 ("no-applicable-method", gf
, save
);
1899 /* if we are here, it's because no-applicable-method hasn't signaled an error */
1903 scm_remember_upto_here_1 (tmp
);
1906 : sort_applicable_methods (applicable
, count
, types
));
1910 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
1913 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
1916 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
1917 #define FUNC_NAME s_sys_compute_applicable_methods
1920 SCM_VALIDATE_GENERIC (1, gf
);
1921 n
= scm_ilength (args
);
1922 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
1923 return scm_compute_applicable_methods (gf
, args
, n
, 1);
1927 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
1928 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
));
1930 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1933 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1934 #define FUNC_NAME s_atslot_ref
1936 SCM x
= SCM_CDR (xorig
);
1937 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1938 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1939 return scm_cons (SCM_IM_SLOT_REF
, x
);
1944 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1947 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1948 #define FUNC_NAME s_atslot_set_x
1950 SCM x
= SCM_CDR (xorig
);
1951 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1952 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1953 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1958 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1960 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1963 scm_m_atdispatch (SCM xorig
, SCM env
)
1964 #define FUNC_NAME s_atdispatch
1966 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1967 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
1969 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
1970 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
1972 n
= SCM_XEVALCAR (x
, env
);
1973 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
1974 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1976 v
= SCM_XEVALCAR (x
, env
);
1977 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
1979 gf
= SCM_XEVALCAR (x
, env
);
1980 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
1981 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1987 lock_cache_mutex (void *m
)
1989 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
1990 scm_lock_mutex (mutex
);
1994 unlock_cache_mutex (void *m
)
1996 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
1997 scm_unlock_mutex (mutex
);
2001 call_memoize_method (void *a
)
2003 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2004 SCM gf
= SCM_CAR (args
);
2005 SCM x
= SCM_CADR (args
);
2006 /* First check if another thread has inserted a method between
2007 * the cache miss and locking the mutex.
2009 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2010 if (!SCM_FALSEP (cmethod
))
2012 /*fixme* Use scm_apply */
2013 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2017 scm_memoize_method (SCM x
, SCM args
)
2019 SCM gf
= SCM_CAR (scm_last_pair (x
));
2020 return scm_internal_dynamic_wind (
2022 call_memoize_method
,
2024 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2025 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2028 /******************************************************************************
2030 * A simple make (which will be redefined later in Scheme)
2031 * This version handles only creation of gf, methods and classes (no instances)
2033 * Since this code will disappear when Goops will be fully booted,
2034 * no precaution is taken to be efficient.
2036 ******************************************************************************/
2038 SCM_KEYWORD (k_setter
, "setter");
2039 SCM_KEYWORD (k_specializers
, "specializers");
2040 SCM_KEYWORD (k_procedure
, "procedure");
2041 SCM_KEYWORD (k_dsupers
, "dsupers");
2042 SCM_KEYWORD (k_slots
, "slots");
2043 SCM_KEYWORD (k_gf
, "generic-function");
2045 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2047 "Make a new object. @var{args} must contain the class and\n"
2048 "all necessary initialization information.")
2049 #define FUNC_NAME s_scm_make
2052 long len
= scm_ilength (args
);
2054 if (len
<= 0 || (len
& 1) == 0)
2055 SCM_WRONG_NUM_ARGS ();
2057 class = SCM_CAR(args
);
2058 args
= SCM_CDR(args
);
2060 if (class == scm_class_generic
|| class == scm_class_generic_with_setter
)
2062 z
= scm_make_struct (class, SCM_INUM0
,
2063 scm_list_5 (SCM_EOL
,
2068 scm_set_procedure_property_x (z
, scm_sym_name
,
2069 scm_get_keyword (k_name
,
2072 clear_method_cache (z
);
2073 if (class == scm_class_generic_with_setter
)
2075 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2076 if (!SCM_FALSEP (setter
))
2077 scm_sys_set_object_setter_x (z
, setter
);
2082 z
= scm_sys_allocate_instance (class, args
);
2084 if (class == scm_class_method
2085 || class == scm_class_simple_method
2086 || class == scm_class_accessor
)
2088 SCM_SET_SLOT (z
, scm_si_generic_function
,
2089 scm_i_get_keyword (k_gf
,
2094 SCM_SET_SLOT (z
, scm_si_specializers
,
2095 scm_i_get_keyword (k_specializers
,
2100 SCM_SET_SLOT (z
, scm_si_procedure
,
2101 scm_i_get_keyword (k_procedure
,
2106 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2110 /* In all the others case, make a new class .... No instance here */
2111 SCM_SET_SLOT (z
, scm_si_name
,
2112 scm_i_get_keyword (k_name
,
2115 scm_str2symbol ("???"),
2117 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2118 scm_i_get_keyword (k_dsupers
,
2123 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2124 scm_i_get_keyword (k_slots
,
2135 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2138 #define FUNC_NAME s_scm_find_method
2141 long len
= scm_ilength (l
);
2144 SCM_WRONG_NUM_ARGS ();
2146 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2147 SCM_VALIDATE_GENERIC (1, gf
);
2148 if (SCM_NULLP (SCM_SLOT (gf
, scm_si_methods
)))
2149 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2151 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2155 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2156 (SCM m1
, SCM m2
, SCM targs
),
2158 #define FUNC_NAME s_scm_sys_method_more_specific_p
2163 SCM_VALIDATE_METHOD (1, m1
);
2164 SCM_VALIDATE_METHOD (2, m2
);
2165 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2167 /* Verify that all the arguments of targs are classes and place them in a vector*/
2168 v
= scm_c_make_vector (len
, SCM_EOL
);
2170 for (i
= 0, l
= targs
; !SCM_NULLP (l
); i
++, l
= SCM_CDR (l
)) {
2171 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2172 SCM_VECTOR_SET (v
, i
, SCM_CAR(l
));
2174 return more_specificp (m1
, m2
, SCM_VELTS(v
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
2180 /******************************************************************************
2184 ******************************************************************************/
2188 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2190 SCM tmp
= scm_str2symbol (name
);
2192 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2196 : scm_list_1 (super
),
2202 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2205 create_standard_classes (void)
2208 SCM method_slots
= scm_list_4 (scm_str2symbol ("generic-function"),
2209 scm_str2symbol ("specializers"),
2211 scm_str2symbol ("code-table"));
2212 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"),
2214 k_slot_definition
));
2215 SCM mutex_slot
= scm_list_1 (scm_str2symbol ("make-mutex"));
2216 SCM gf_slots
= scm_list_5 (scm_str2symbol ("methods"),
2217 scm_list_3 (scm_str2symbol ("n-specialized"),
2220 scm_list_3 (scm_str2symbol ("used-by"),
2223 scm_list_3 (scm_str2symbol ("cache-mutex"),
2225 scm_closure (scm_list_2 (SCM_EOL
,
2228 scm_list_3 (scm_str2symbol ("extended-by"),
2231 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2234 /* Foreign class slot classes */
2235 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2236 scm_class_class
, scm_class_top
, SCM_EOL
);
2237 make_stdcls (&scm_class_protected
, "<protected-slot>",
2238 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2239 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2240 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2241 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2242 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2243 make_stdcls (&scm_class_self
, "<self-slot>",
2245 scm_list_2 (scm_class_foreign_slot
, scm_class_read_only
),
2247 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2249 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2251 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2253 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2255 make_stdcls (&scm_class_scm
, "<scm-slot>",
2256 scm_class_class
, scm_class_protected
, SCM_EOL
);
2257 make_stdcls (&scm_class_int
, "<int-slot>",
2258 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2259 make_stdcls (&scm_class_float
, "<float-slot>",
2260 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2261 make_stdcls (&scm_class_double
, "<double-slot>",
2262 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2264 /* Continue initialization of class <class> */
2266 slots
= build_class_class_slots ();
2267 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2268 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2269 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2270 compute_getters_n_setters (slots
));
2272 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2273 scm_class_class
, scm_class_class
,
2274 scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"),
2277 scm_list_3 (scm_str2symbol ("destructor"),
2279 scm_class_opaque
)));
2280 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2281 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2282 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2284 /* scm_class_generic functions classes */
2285 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2286 scm_class_class
, scm_class_class
, SCM_EOL
);
2287 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2288 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2289 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2290 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2291 make_stdcls (&scm_class_operator_with_setter_class
,
2292 "<operator-with-setter-class>",
2293 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2294 make_stdcls (&scm_class_method
, "<method>",
2295 scm_class_class
, scm_class_object
, method_slots
);
2296 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2297 scm_class_class
, scm_class_method
, SCM_EOL
);
2298 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2299 make_stdcls (&scm_class_accessor
, "<accessor-method>",
2300 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2301 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_ACCESSOR_METHOD
);
2302 make_stdcls (&scm_class_entity
, "<entity>",
2303 scm_class_entity_class
, scm_class_object
, SCM_EOL
);
2304 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2305 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2306 make_stdcls (&scm_class_generic
, "<generic>",
2307 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2308 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2309 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2310 scm_class_entity_class
,
2311 scm_list_1 (scm_class_generic
),
2313 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2314 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2315 scm_class_entity_class
,
2316 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2318 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2319 make_stdcls (&scm_class_extended_generic_with_setter
,
2320 "<extended-generic-with-setter>",
2321 scm_class_entity_class
,
2322 scm_list_2 (scm_class_extended_generic
,
2323 scm_class_entity_with_setter
),
2325 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2326 SCM_CLASSF_PURE_GENERIC
);
2328 /* Primitive types classes */
2329 make_stdcls (&scm_class_boolean
, "<boolean>",
2330 scm_class_class
, scm_class_top
, SCM_EOL
);
2331 make_stdcls (&scm_class_char
, "<char>",
2332 scm_class_class
, scm_class_top
, SCM_EOL
);
2333 make_stdcls (&scm_class_list
, "<list>",
2334 scm_class_class
, scm_class_top
, SCM_EOL
);
2335 make_stdcls (&scm_class_pair
, "<pair>",
2336 scm_class_class
, scm_class_list
, SCM_EOL
);
2337 make_stdcls (&scm_class_null
, "<null>",
2338 scm_class_class
, scm_class_list
, SCM_EOL
);
2339 make_stdcls (&scm_class_string
, "<string>",
2340 scm_class_class
, scm_class_top
, SCM_EOL
);
2341 make_stdcls (&scm_class_symbol
, "<symbol>",
2342 scm_class_class
, scm_class_top
, SCM_EOL
);
2343 make_stdcls (&scm_class_vector
, "<vector>",
2344 scm_class_class
, scm_class_top
, SCM_EOL
);
2345 make_stdcls (&scm_class_number
, "<number>",
2346 scm_class_class
, scm_class_top
, SCM_EOL
);
2347 make_stdcls (&scm_class_complex
, "<complex>",
2348 scm_class_class
, scm_class_number
, SCM_EOL
);
2349 make_stdcls (&scm_class_real
, "<real>",
2350 scm_class_class
, scm_class_complex
, SCM_EOL
);
2351 make_stdcls (&scm_class_integer
, "<integer>",
2352 scm_class_class
, scm_class_real
, SCM_EOL
);
2353 make_stdcls (&scm_class_keyword
, "<keyword>",
2354 scm_class_class
, scm_class_top
, SCM_EOL
);
2355 make_stdcls (&scm_class_unknown
, "<unknown>",
2356 scm_class_class
, scm_class_top
, SCM_EOL
);
2357 make_stdcls (&scm_class_procedure
, "<procedure>",
2358 scm_class_procedure_class
, scm_class_top
, SCM_EOL
);
2359 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2360 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2361 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2362 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2363 make_stdcls (&scm_class_port
, "<port>",
2364 scm_class_class
, scm_class_top
, SCM_EOL
);
2365 make_stdcls (&scm_class_input_port
, "<input-port>",
2366 scm_class_class
, scm_class_port
, SCM_EOL
);
2367 make_stdcls (&scm_class_output_port
, "<output-port>",
2368 scm_class_class
, scm_class_port
, SCM_EOL
);
2369 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2371 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2375 /**********************************************************************
2379 **********************************************************************/
2382 make_class_from_template (char *template, char *type_name
, SCM supers
)
2388 sprintf (buffer
, template, type_name
);
2389 name
= scm_str2symbol (buffer
);
2392 name
= SCM_GOOPS_UNBOUND
;
2394 class = scm_permanent_object (scm_basic_make_class (scm_class_class
,
2399 /* Only define name if doesn't already exist. */
2400 if (!SCM_GOOPS_UNBOUNDP (name
)
2401 && SCM_FALSEP (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2402 DEFVAR (name
, class);
2407 scm_make_extended_class (char *type_name
)
2409 return make_class_from_template ("<%s>",
2411 scm_list_1 (scm_class_top
));
2415 create_smob_classes (void)
2419 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2420 for (i
= 0; i
< 255; ++i
)
2421 scm_smob_class
[i
] = 0;
2423 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_big
)] = scm_class_integer
;
2424 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_real
)] = scm_class_real
;
2425 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_complex
)] = scm_class_complex
;
2426 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2428 for (i
= 0; i
< scm_numsmob
; ++i
)
2429 if (!scm_smob_class
[i
])
2430 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
));
2434 scm_make_port_classes (long ptobnum
, char *type_name
)
2436 SCM c
, class = make_class_from_template ("<%s-port>",
2438 scm_list_1 (scm_class_port
));
2439 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2440 = make_class_from_template ("<%s-input-port>",
2442 scm_list_2 (class, scm_class_input_port
));
2443 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2444 = make_class_from_template ("<%s-output-port>",
2446 scm_list_2 (class, scm_class_output_port
));
2447 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2449 = make_class_from_template ("<%s-input-output-port>",
2451 scm_list_2 (class, scm_class_input_output_port
));
2452 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2453 SCM_SET_SLOT (c
, scm_si_cpl
,
2454 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2458 create_port_classes (void)
2462 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2463 for (i
= 0; i
< 3 * 256; ++i
)
2464 scm_port_class
[i
] = 0;
2466 for (i
= 0; i
< scm_numptob
; ++i
)
2467 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2471 make_struct_class (void *closure SCM_UNUSED
, SCM key SCM_UNUSED
,
2472 SCM data
, SCM prev SCM_UNUSED
)
2474 if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data
)))
2475 SCM_SET_STRUCT_TABLE_CLASS (data
,
2476 scm_make_extended_class
2477 (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data
))));
2478 return SCM_UNSPECIFIED
;
2482 create_struct_classes (void)
2484 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2487 /**********************************************************************
2491 **********************************************************************/
2496 if (!goops_loaded_p
)
2497 scm_c_resolve_module ("oop goops");
2502 scm_make_foreign_object (SCM
class, SCM initargs
)
2503 #define FUNC_NAME s_scm_make
2505 void * (*constructor
) (SCM
)
2506 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2507 if (constructor
== 0)
2508 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2509 return scm_wrap_object (class, constructor (initargs
));
2515 scm_free_foreign_object (SCM
*class, SCM
*data
)
2517 size_t (*destructor
) (void *)
2518 = (size_t (*) (void *)) class[scm_si_destructor
];
2519 return destructor (data
);
2523 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2524 void * (*constructor
) (SCM initargs
),
2525 size_t (*destructor
) (void *))
2528 name
= scm_str2symbol (s_name
);
2529 if (SCM_NULLP (supers
))
2530 supers
= scm_list_1 (scm_class_foreign_object
);
2531 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2532 scm_sys_inherit_magic_x (class, supers
);
2534 if (destructor
!= 0)
2536 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2537 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2541 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2542 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2545 SCM_SET_SLOT (class, scm_si_layout
, scm_str2symbol (""));
2546 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2551 SCM_SYMBOL (sym_o
, "o");
2552 SCM_SYMBOL (sym_x
, "x");
2554 SCM_KEYWORD (k_accessor
, "accessor");
2555 SCM_KEYWORD (k_getter
, "getter");
2558 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2560 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2565 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2566 SCM (*getter
) (SCM obj
),
2567 SCM (*setter
) (SCM obj
, SCM x
),
2568 char *accessor_name
)
2571 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2572 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2573 setter
? setter
: default_setter
);
2574 SCM getm
= scm_closure (scm_list_2 (scm_list_1 (sym_o
),
2575 scm_list_2 (get
, sym_o
)),
2577 SCM setm
= scm_closure (scm_list_2 (scm_list_2 (sym_o
, sym_x
),
2578 scm_list_3 (set
, sym_o
, sym_x
)),
2581 SCM name
= scm_str2symbol (slot_name
);
2582 SCM aname
= scm_str2symbol (accessor_name
);
2583 SCM gf
= scm_ensure_accessor (aname
);
2584 SCM slot
= scm_list_5 (name
,
2587 setter
? k_accessor
: k_getter
,
2589 SCM gns
= scm_list_4 (name
, SCM_BOOL_F
, get
, set
);
2591 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor
,
2596 scm_add_method (scm_setter (gf
),
2597 scm_make (scm_list_5 (scm_class_accessor
,
2599 scm_list_2 (class, scm_class_top
),
2604 SCM_SET_SLOT (class, scm_si_slots
,
2605 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2606 scm_list_1 (slot
))));
2607 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2608 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2609 scm_list_1 (gns
))));
2613 long n
= SCM_INUM (SCM_SLOT (class, scm_si_nfields
));
2615 SCM_SET_SLOT (class, scm_si_nfields
, SCM_MAKINUM (n
+ 1));
2620 scm_wrap_object (SCM
class, void *data
)
2622 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2630 scm_wrap_component (SCM
class, SCM container
, void *data
)
2632 SCM obj
= scm_wrap_object (class, data
);
2633 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2639 SCM_SETCDR (handle
, container
);
2644 scm_ensure_accessor (SCM name
)
2646 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2647 if (!SCM_IS_A_P (gf
, scm_class_generic_with_setter
))
2649 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2650 gf
= scm_make (scm_list_5 (scm_class_generic_with_setter
,
2651 k_name
, name
, k_setter
, gf
));
2656 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2659 scm_add_method (SCM gf
, SCM m
)
2661 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2666 * Debugging utilities
2669 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2671 "Return @code{#t} if @var{obj} is a pure generic.")
2672 #define FUNC_NAME s_scm_pure_generic_p
2674 return SCM_BOOL (SCM_PUREGENERICP (obj
));
2678 #endif /* GUILE_DEBUG */
2684 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2686 "Announce that GOOPS is loaded and perform initialization\n"
2687 "on the C level which depends on the loaded GOOPS modules.")
2688 #define FUNC_NAME s_scm_sys_goops_loaded
2691 var_compute_applicable_methods
=
2692 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2694 return SCM_UNSPECIFIED
;
2698 SCM scm_module_goops
;
2701 scm_init_goops_builtins (void)
2703 scm_module_goops
= scm_current_module ();
2704 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2706 /* Not really necessary right now, but who knows...
2708 scm_permanent_object (scm_module_goops
);
2709 scm_permanent_object (scm_goops_lookup_closure
);
2711 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2712 (SCM_MAKINUM (37)));
2714 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2716 #include "libguile/goops.x"
2718 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2720 hell
= scm_malloc (hell_size
);
2721 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2723 create_basic_classes ();
2724 create_standard_classes ();
2725 create_smob_classes ();
2726 create_struct_classes ();
2727 create_port_classes ();
2730 SCM name
= scm_str2symbol ("no-applicable-method");
2731 scm_no_applicable_method
2732 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2735 DEFVAR (name
, scm_no_applicable_method
);
2738 return SCM_UNSPECIFIED
;
2744 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
2745 scm_init_goops_builtins
);