1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This software is a derivative work of other copyrighted softwares; the
21 * copyright notices of these softwares are placed in the file COPYRIGHTS
23 * This file is based upon stklos.c from the STk distribution by
24 * Erick Gallesio <eg@unice.fr>.
29 #include "libguile/_scm.h"
30 #include "libguile/alist.h"
31 #include "libguile/chars.h"
32 #include "libguile/debug.h"
33 #include "libguile/dynl.h"
34 #include "libguile/dynwind.h"
35 #include "libguile/eval.h"
36 #include "libguile/hashtab.h"
37 #include "libguile/keywords.h"
38 #include "libguile/macros.h"
39 #include "libguile/modules.h"
40 #include "libguile/objects.h"
41 #include "libguile/ports.h"
42 #include "libguile/procprop.h"
43 #include "libguile/random.h"
44 #include "libguile/root.h"
45 #include "libguile/smob.h"
46 #include "libguile/strings.h"
47 #include "libguile/strports.h"
48 #include "libguile/vectors.h"
49 #include "libguile/weaks.h"
51 #include "libguile/validate.h"
52 #include "libguile/goops.h"
54 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
56 #define DEFVAR(v, val) \
57 { scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
59 /* Temporary hack until we get the new module system */
60 /*fixme* Should optimize by keeping track of the variable object itself */
61 #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
64 /* Fixme: Should use already interned symbols */
66 #define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
68 #define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
70 #define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
72 #define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
75 /* Class redefinition protocol:
77 A class is represented by a heap header h1 which points to a
78 malloc:ed memory block m1.
80 When a new version of a class is created, a new header h2 and
81 memory block m2 are allocated. The headers h1 and h2 then switch
82 pointers so that h1 refers to m2 and h2 to m1. In this way, names
83 bound to h1 will point to the new class at the same time as h2 will
84 be a handle which the GC will us to free m1.
86 The `redefined' slot of m1 will be set to point to h1. An old
87 instance will have it's class pointer (the CAR of the heap header)
88 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
89 the class modification and the new class pointer can be found via
93 /* The following definition is located in libguile/objects.h:
94 #define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
97 #define TEST_CHANGE_CLASS(obj, class) \
99 class = SCM_CLASS_OF (obj); \
100 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
102 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
103 class = SCM_CLASS_OF (obj); \
107 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
108 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
110 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
111 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
113 static int goops_loaded_p
= 0;
114 static scm_t_rstate
*goops_rstate
;
116 static SCM scm_goops_lookup_closure
;
118 /* These variables are filled in by the object system when loaded. */
119 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
120 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
121 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
122 SCM scm_class_vector
, scm_class_null
;
123 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
124 SCM scm_class_unknown
;
125 SCM scm_class_top
, scm_class_object
, scm_class_class
;
126 SCM scm_class_applicable
;
127 SCM scm_class_entity
, scm_class_entity_with_setter
;
128 SCM scm_class_generic
, scm_class_generic_with_setter
;
129 SCM scm_class_accessor
;
130 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
131 SCM scm_class_extended_accessor
;
132 SCM scm_class_method
;
133 SCM scm_class_simple_method
, scm_class_accessor_method
;
134 SCM scm_class_procedure_class
;
135 SCM scm_class_operator_class
, scm_class_operator_with_setter_class
;
136 SCM scm_class_entity_class
;
137 SCM scm_class_number
, scm_class_list
;
138 SCM scm_class_keyword
;
139 SCM scm_class_port
, scm_class_input_output_port
;
140 SCM scm_class_input_port
, scm_class_output_port
;
141 SCM scm_class_foreign_class
, scm_class_foreign_object
;
142 SCM scm_class_foreign_slot
;
143 SCM scm_class_self
, scm_class_protected
;
144 SCM scm_class_opaque
, scm_class_read_only
;
145 SCM scm_class_protected_opaque
, scm_class_protected_read_only
;
147 SCM scm_class_int
, scm_class_float
, scm_class_double
;
149 SCM
*scm_port_class
= 0;
150 SCM
*scm_smob_class
= 0;
152 SCM scm_no_applicable_method
;
154 SCM_SYMBOL (scm_sym_define_public
, "define-public");
156 static SCM
scm_make_unbound (void);
157 static SCM
scm_unbound_p (SCM obj
);
158 static SCM
scm_assert_bound (SCM value
, SCM obj
);
159 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
160 static SCM
scm_sys_goops_loaded (void);
162 /* This function is used for efficient type dispatch. */
163 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
165 "Return the class of @var{x}.")
166 #define FUNC_NAME s_scm_class_of
168 switch (SCM_ITAG3 (x
))
172 return scm_class_integer
;
176 return scm_class_char
;
177 else if (scm_is_bool (x
))
178 return scm_class_boolean
;
179 else if (scm_is_null (x
))
180 return scm_class_null
;
182 return scm_class_unknown
;
185 switch (SCM_TYP7 (x
))
187 case scm_tcs_cons_nimcar
:
188 return scm_class_pair
;
189 case scm_tcs_closures
:
190 return scm_class_procedure
;
192 return scm_class_symbol
;
195 return scm_class_vector
;
197 return scm_class_string
;
199 switch SCM_TYP16 (x
) {
201 return scm_class_integer
;
203 return scm_class_real
;
204 case scm_tc16_complex
:
205 return scm_class_complex
;
206 case scm_tc16_fraction
:
207 return scm_class_fraction
;
217 case scm_tc7_subr_1o
:
218 case scm_tc7_subr_2o
:
219 case scm_tc7_lsubr_2
:
221 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
222 return scm_class_primitive_generic
;
224 return scm_class_procedure
;
226 return scm_class_procedure
;
228 return scm_class_procedure_with_setter
;
232 scm_t_bits type
= SCM_TYP16 (x
);
233 if (type
!= scm_tc16_port_with_ps
)
234 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
235 x
= SCM_PORT_WITH_PS_PORT (x
);
236 /* fall through to ports */
239 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
240 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
241 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
242 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
243 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
245 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
246 return SCM_CLASS_OF (x
);
247 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
250 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
251 scm_change_object_class (x
,
252 SCM_CLASS_OF (x
), /* old */
253 SCM_OBJ_CLASS_REDEF (x
)); /* new */
254 return SCM_CLASS_OF (x
);
258 /* ordinary struct */
259 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
260 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
261 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
264 SCM name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
265 SCM
class = scm_make_extended_class (scm_is_true (name
)
266 ? scm_i_symbol_chars (name
)
268 SCM_I_OPERATORP (x
));
269 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
275 return scm_class_pair
;
277 return scm_class_unknown
;
283 case scm_tc3_closure
:
287 return scm_class_unknown
;
291 /******************************************************************************
295 * This version doesn't fully handle multiple-inheritance. It serves
296 * only for booting classes and will be overloaded in Scheme
298 ******************************************************************************/
301 map (SCM (*proc
) (SCM
), SCM ls
)
303 if (scm_is_null (ls
))
307 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
310 while (!scm_is_null (ls
))
312 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
324 while (!scm_is_null (ls
))
326 SCM el
= SCM_CAR (ls
);
327 if (scm_is_false (scm_c_memq (el
, res
)))
328 res
= scm_cons (el
, res
);
335 compute_cpl (SCM
class)
338 return CALL_GF1 ("compute-cpl", class);
341 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
342 SCM ls
= scm_append (scm_acons (class, supers
,
343 map (compute_cpl
, supers
)));
344 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
348 /******************************************************************************
352 ******************************************************************************/
355 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
363 if (!scm_is_symbol (tmp
))
364 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
366 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
367 res
= scm_cons (SCM_CAR (l
), res
);
368 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
371 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
375 build_slots_list (SCM dslots
, SCM cpl
)
377 register SCM res
= dslots
;
379 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
380 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
381 scm_si_direct_slots
),
384 /* res contains a list of slots. Remove slots which appears more than once */
385 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
392 while (!scm_is_null (ls
))
394 if (!scm_is_pair (SCM_CAR (ls
)))
395 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
402 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
404 "Return a list consisting of the names of all slots belonging to\n"
405 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
407 #define FUNC_NAME s_scm_sys_compute_slots
409 SCM_VALIDATE_CLASS (1, class);
410 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
411 SCM_SLOT (class, scm_si_cpl
));
416 /******************************************************************************
418 * compute-getters-n-setters
420 * This version doesn't handle slot options. It serves only for booting
421 * classes and will be overloaded in Scheme.
423 ******************************************************************************/
425 SCM_KEYWORD (k_init_value
, "init-value");
426 SCM_KEYWORD (k_init_thunk
, "init-thunk");
429 compute_getters_n_setters (SCM slots
)
435 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
437 SCM init
= SCM_BOOL_F
;
438 SCM options
= SCM_CDAR (slots
);
439 if (!scm_is_null (options
))
441 init
= scm_get_keyword (k_init_value
, options
, 0);
444 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
446 scm_list_2 (scm_sym_quote
,
451 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
453 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
455 scm_from_int (i
++))),
457 cdrloc
= SCM_CDRLOC (*cdrloc
);
462 /******************************************************************************
466 ******************************************************************************/
468 /*fixme* Manufacture keywords in advance */
470 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
474 for (i
= 0; i
!= len
; i
+= 2)
476 SCM obj
= SCM_CAR (l
);
478 if (!scm_is_keyword (obj
))
479 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
480 else if (scm_is_eq (obj
, key
))
486 return default_value
;
490 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
491 (SCM key
, SCM l
, SCM default_value
),
492 "Determine an associated value for the keyword @var{key} from\n"
493 "the list @var{l}. The list @var{l} has to consist of an even\n"
494 "number of elements, where, starting with the first, every\n"
495 "second element is a keyword, followed by its associated value.\n"
496 "If @var{l} does not hold a value for @var{key}, the value\n"
497 "@var{default_value} is returned.")
498 #define FUNC_NAME s_scm_get_keyword
502 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
503 len
= scm_ilength (l
);
504 if (len
< 0 || len
% 2 == 1)
505 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
507 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
512 SCM_KEYWORD (k_init_keyword
, "init-keyword");
514 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
515 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
517 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
518 (SCM obj
, SCM initargs
),
519 "Initialize the object @var{obj} with the given arguments\n"
521 #define FUNC_NAME s_scm_sys_initialize_object
523 SCM tmp
, get_n_set
, slots
;
524 SCM
class = SCM_CLASS_OF (obj
);
527 SCM_VALIDATE_INSTANCE (1, obj
);
528 n_initargs
= scm_ilength (initargs
);
529 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
531 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
532 slots
= SCM_SLOT (class, scm_si_slots
);
534 /* See for each slot how it must be initialized */
536 !scm_is_null (slots
);
537 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
539 SCM slot_name
= SCM_CAR (slots
);
542 if (!scm_is_null (SCM_CDR (slot_name
)))
544 /* This slot admits (perhaps) to be initialized at creation time */
545 long n
= scm_ilength (SCM_CDR (slot_name
));
546 if (n
& 1) /* odd or -1 */
547 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
548 scm_list_1 (slot_name
));
549 tmp
= scm_i_get_keyword (k_init_keyword
,
554 slot_name
= SCM_CAR (slot_name
);
557 /* an initarg was provided for this slot */
558 if (!scm_is_keyword (tmp
))
559 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
561 slot_value
= scm_i_get_keyword (tmp
,
570 /* set slot to provided value */
571 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
574 /* set slot to its :init-form if it exists */
575 tmp
= SCM_CADAR (get_n_set
);
576 if (scm_is_true (tmp
))
578 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
579 if (SCM_GOOPS_UNBOUNDP (slot_value
))
581 SCM env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, SCM_ENV (tmp
));
582 set_slot_value (class,
585 scm_eval_body (SCM_CLOSURE_BODY (tmp
), env
));
595 /* NOTE: The following macros are interdependent with code
596 * in goops.scm:compute-getters-n-setters
598 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
599 (SCM_I_INUMP (SCM_CDDR (gns)) \
600 || (scm_is_pair (SCM_CDDR (gns)) \
601 && scm_is_pair (SCM_CDDDR (gns)) \
602 && scm_is_pair (SCM_CDDDDR (gns))))
603 #define SCM_GNS_INDEX(gns) \
604 (SCM_I_INUMP (SCM_CDDR (gns)) \
605 ? SCM_I_INUM (SCM_CDDR (gns)) \
606 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
607 #define SCM_GNS_SIZE(gns) \
608 (SCM_I_INUMP (SCM_CDDR (gns)) \
610 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
612 SCM_KEYWORD (k_class
, "class");
613 SCM_KEYWORD (k_allocation
, "allocation");
614 SCM_KEYWORD (k_instance
, "instance");
616 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
619 #define FUNC_NAME s_scm_sys_prep_layout_x
621 SCM slots
, getters_n_setters
, nfields
;
622 unsigned long int n
, i
;
626 SCM_VALIDATE_INSTANCE (1, class);
627 slots
= SCM_SLOT (class, scm_si_slots
);
628 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
629 nfields
= SCM_SLOT (class, scm_si_nfields
);
630 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
631 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
632 scm_list_1 (nfields
));
633 n
= 2 * SCM_I_INUM (nfields
);
634 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
635 && SCM_SUBCLASSP (class, scm_class_class
))
636 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
637 scm_list_1 (nfields
));
639 layout
= scm_i_make_string (n
, &s
);
641 while (scm_is_pair (getters_n_setters
))
643 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
646 int len
, index
, size
;
649 if (i
>= n
|| !scm_is_pair (slots
))
652 /* extract slot type */
653 len
= scm_ilength (SCM_CDAR (slots
));
654 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
655 len
, SCM_BOOL_F
, FUNC_NAME
);
656 /* determine slot GC protection and access mode */
657 if (scm_is_false (type
))
664 if (!SCM_CLASSP (type
))
665 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
666 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
668 if (SCM_SUBCLASSP (type
, scm_class_self
))
670 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
675 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
677 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
689 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
690 if (index
!= (i
>> 1))
692 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
700 slots
= SCM_CDR (slots
);
701 getters_n_setters
= SCM_CDR (getters_n_setters
);
703 if (!scm_is_null (slots
))
706 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
708 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
709 return SCM_UNSPECIFIED
;
713 static void prep_hashsets (SCM
);
715 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
716 (SCM
class, SCM dsupers
),
718 #define FUNC_NAME s_scm_sys_inherit_magic_x
722 SCM_VALIDATE_INSTANCE (1, class);
723 while (!scm_is_null (ls
))
725 SCM_ASSERT (scm_is_pair (ls
)
726 && SCM_INSTANCEP (SCM_CAR (ls
)),
730 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
733 flags
&= SCM_CLASSF_INHERIT
;
734 if (flags
& SCM_CLASSF_ENTITY
)
735 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity
);
738 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
741 * We could avoid calling scm_gc_malloc in the allocation code
742 * (in which case the following two lines are needed). Instead
743 * we make 0-slot instances non-light, so that the light case
744 * can be handled without special cases.
747 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
749 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
751 /* NOTE: The following depends on scm_struct_i_size. */
752 flags
|= SCM_STRUCTF_LIGHT
+ n
* sizeof (SCM
); /* use light representation */
753 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
756 SCM_SET_CLASS_FLAGS (class, flags
);
758 prep_hashsets (class);
760 return SCM_UNSPECIFIED
;
765 prep_hashsets (SCM
class)
769 for (i
= 0; i
< 7; ++i
)
770 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
773 /******************************************************************************/
776 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
778 SCM z
, cpl
, slots
, nfields
, g_n_s
;
780 /* Allocate one instance */
781 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
783 /* Initialize its slots */
784 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
785 cpl
= compute_cpl (z
);
786 slots
= build_slots_list (maplist (dslots
), cpl
);
787 nfields
= scm_from_int (scm_ilength (slots
));
788 g_n_s
= compute_getters_n_setters (slots
);
790 SCM_SET_SLOT (z
, scm_si_name
, name
);
791 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
792 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
793 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
794 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
795 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
796 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
797 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
798 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
799 SCM_SET_SLOT (z
, scm_si_environment
,
800 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
802 /* Add this class in the direct-subclasses slot of dsupers */
805 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
806 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
807 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
808 scm_si_direct_subclasses
)));
811 /* Support for the underlying structs: */
812 SCM_SET_CLASS_FLAGS (z
, (class == scm_class_entity_class
813 ? (SCM_CLASSF_GOOPS_OR_VALID
814 | SCM_CLASSF_OPERATOR
816 : class == scm_class_operator_class
817 ? SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_OPERATOR
818 : SCM_CLASSF_GOOPS_OR_VALID
));
823 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
825 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
826 scm_sys_inherit_magic_x (z
, dsupers
);
827 scm_sys_prep_layout_x (z
);
831 /******************************************************************************/
833 SCM_SYMBOL (sym_layout
, "layout");
834 SCM_SYMBOL (sym_vcell
, "vcell");
835 SCM_SYMBOL (sym_vtable
, "vtable");
836 SCM_SYMBOL (sym_print
, "print");
837 SCM_SYMBOL (sym_procedure
, "procedure");
838 SCM_SYMBOL (sym_setter
, "setter");
839 SCM_SYMBOL (sym_redefined
, "redefined");
840 SCM_SYMBOL (sym_h0
, "h0");
841 SCM_SYMBOL (sym_h1
, "h1");
842 SCM_SYMBOL (sym_h2
, "h2");
843 SCM_SYMBOL (sym_h3
, "h3");
844 SCM_SYMBOL (sym_h4
, "h4");
845 SCM_SYMBOL (sym_h5
, "h5");
846 SCM_SYMBOL (sym_h6
, "h6");
847 SCM_SYMBOL (sym_h7
, "h7");
848 SCM_SYMBOL (sym_name
, "name");
849 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
850 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
851 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
852 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
853 SCM_SYMBOL (sym_cpl
, "cpl");
854 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
855 SCM_SYMBOL (sym_slots
, "slots");
856 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
857 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
858 SCM_SYMBOL (sym_nfields
, "nfields");
859 SCM_SYMBOL (sym_environment
, "environment");
863 build_class_class_slots ()
866 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
867 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
868 scm_list_1 (sym_print
),
869 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
870 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
871 scm_list_1 (sym_redefined
),
872 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
873 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
874 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
875 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
876 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
877 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
878 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
879 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
880 scm_list_1 (sym_name
),
881 scm_list_1 (sym_direct_supers
),
882 scm_list_1 (sym_direct_slots
),
883 scm_list_1 (sym_direct_subclasses
),
884 scm_list_1 (sym_direct_methods
),
885 scm_list_1 (sym_cpl
),
886 scm_list_1 (sym_default_slot_definition_class
),
887 scm_list_1 (sym_slots
),
888 scm_list_1 (sym_getters_n_setters
),
889 scm_list_1 (sym_keyword_access
),
890 scm_list_1 (sym_nfields
),
891 scm_list_1 (sym_environment
),
896 create_basic_classes (void)
898 /* SCM slots_of_class = build_class_class_slots (); */
900 /**** <scm_class_class> ****/
901 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
902 + 2 * scm_vtable_offset_user
);
903 SCM name
= scm_from_locale_symbol ("<class>");
904 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
907 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
908 | SCM_CLASSF_METACLASS
));
910 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
911 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
912 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
913 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
914 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
915 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
916 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
917 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
918 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
919 compute_getters_n_setters (slots_of_class)); */
920 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
921 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
922 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
924 prep_hashsets (scm_class_class
);
926 DEFVAR(name
, scm_class_class
);
928 /**** <scm_class_top> ****/
929 name
= scm_from_locale_symbol ("<top>");
930 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
935 DEFVAR(name
, scm_class_top
);
937 /**** <scm_class_object> ****/
938 name
= scm_from_locale_symbol ("<object>");
939 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
941 scm_list_1 (scm_class_top
),
944 DEFVAR (name
, scm_class_object
);
946 /* <top> <object> and <class> were partially initialized. Correct them here */
947 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
949 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
950 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
953 /******************************************************************************/
955 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
957 "Return @code{#t} if @var{obj} is an instance.")
958 #define FUNC_NAME s_scm_instance_p
960 return scm_from_bool (SCM_INSTANCEP (obj
));
965 /******************************************************************************
967 * Meta object accessors
969 ******************************************************************************/
970 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
972 "Return the class name of @var{obj}.")
973 #define FUNC_NAME s_scm_class_name
975 SCM_VALIDATE_CLASS (1, obj
);
976 return scm_slot_ref (obj
, sym_name
);
980 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
982 "Return the direct superclasses of the class @var{obj}.")
983 #define FUNC_NAME s_scm_class_direct_supers
985 SCM_VALIDATE_CLASS (1, obj
);
986 return scm_slot_ref (obj
, sym_direct_supers
);
990 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
992 "Return the direct slots of the class @var{obj}.")
993 #define FUNC_NAME s_scm_class_direct_slots
995 SCM_VALIDATE_CLASS (1, obj
);
996 return scm_slot_ref (obj
, sym_direct_slots
);
1000 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1002 "Return the direct subclasses of the class @var{obj}.")
1003 #define FUNC_NAME s_scm_class_direct_subclasses
1005 SCM_VALIDATE_CLASS (1, obj
);
1006 return scm_slot_ref(obj
, sym_direct_subclasses
);
1010 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1012 "Return the direct methods of the class @var{obj}")
1013 #define FUNC_NAME s_scm_class_direct_methods
1015 SCM_VALIDATE_CLASS (1, obj
);
1016 return scm_slot_ref (obj
, sym_direct_methods
);
1020 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1022 "Return the class precedence list of the class @var{obj}.")
1023 #define FUNC_NAME s_scm_class_precedence_list
1025 SCM_VALIDATE_CLASS (1, obj
);
1026 return scm_slot_ref (obj
, sym_cpl
);
1030 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1032 "Return the slot list of the class @var{obj}.")
1033 #define FUNC_NAME s_scm_class_slots
1035 SCM_VALIDATE_CLASS (1, obj
);
1036 return scm_slot_ref (obj
, sym_slots
);
1040 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1042 "Return the environment of the class @var{obj}.")
1043 #define FUNC_NAME s_scm_class_environment
1045 SCM_VALIDATE_CLASS (1, obj
);
1046 return scm_slot_ref(obj
, sym_environment
);
1051 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1053 "Return the name of the generic function @var{obj}.")
1054 #define FUNC_NAME s_scm_generic_function_name
1056 SCM_VALIDATE_GENERIC (1, obj
);
1057 return scm_procedure_property (obj
, scm_sym_name
);
1061 SCM_SYMBOL (sym_methods
, "methods");
1062 SCM_SYMBOL (sym_extended_by
, "extended-by");
1063 SCM_SYMBOL (sym_extends
, "extends");
1066 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1068 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1069 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1070 while (!scm_is_null (gfs
))
1072 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1073 gfs
= SCM_CDR (gfs
);
1075 return method_lists
;
1079 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1081 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1083 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1084 while (!scm_is_null (gfs
))
1086 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1087 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1090 gfs
= SCM_CDR (gfs
);
1093 return method_lists
;
1096 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1098 "Return the methods of the generic function @var{obj}.")
1099 #define FUNC_NAME s_scm_generic_function_methods
1102 SCM_VALIDATE_GENERIC (1, obj
);
1103 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1104 methods
= fold_downward_gf_methods (methods
, obj
);
1105 return scm_append (methods
);
1109 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1111 "Return the generic function for the method @var{obj}.")
1112 #define FUNC_NAME s_scm_method_generic_function
1114 SCM_VALIDATE_METHOD (1, obj
);
1115 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1119 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1121 "Return specializers of the method @var{obj}.")
1122 #define FUNC_NAME s_scm_method_specializers
1124 SCM_VALIDATE_METHOD (1, obj
);
1125 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1129 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1131 "Return the procedure of the method @var{obj}.")
1132 #define FUNC_NAME s_scm_method_procedure
1134 SCM_VALIDATE_METHOD (1, obj
);
1135 return scm_slot_ref (obj
, sym_procedure
);
1139 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1141 "Return the slot definition of the accessor @var{obj}.")
1142 #define FUNC_NAME s_scm_accessor_method_slot_definition
1144 SCM_VALIDATE_ACCESSOR (1, obj
);
1145 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1149 SCM_DEFINE (scm_sys_tag_body
, "%tag-body", 1, 0, 0,
1151 "Internal GOOPS magic---don't use this function!")
1152 #define FUNC_NAME s_scm_sys_tag_body
1154 return scm_cons (SCM_IM_LAMBDA
, body
);
1158 /******************************************************************************
1160 * S l o t a c c e s s
1162 ******************************************************************************/
1164 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1166 "Return the unbound value.")
1167 #define FUNC_NAME s_scm_make_unbound
1169 return SCM_GOOPS_UNBOUND
;
1173 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1175 "Return @code{#t} if @var{obj} is unbound.")
1176 #define FUNC_NAME s_scm_unbound_p
1178 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1182 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1183 (SCM value
, SCM obj
),
1184 "Return @var{value} if it is bound, and invoke the\n"
1185 "@var{slot-unbound} method of @var{obj} if it is not.")
1186 #define FUNC_NAME s_scm_assert_bound
1188 if (SCM_GOOPS_UNBOUNDP (value
))
1189 return CALL_GF1 ("slot-unbound", obj
);
1194 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1195 (SCM obj
, SCM index
),
1196 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1197 "the value from @var{obj}.")
1198 #define FUNC_NAME s_scm_at_assert_bound_ref
1200 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1201 if (SCM_GOOPS_UNBOUNDP (value
))
1202 return CALL_GF1 ("slot-unbound", obj
);
1207 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1208 (SCM obj
, SCM index
),
1209 "Return the slot value with index @var{index} from @var{obj}.")
1210 #define FUNC_NAME s_scm_sys_fast_slot_ref
1212 unsigned long int i
;
1214 SCM_VALIDATE_INSTANCE (1, obj
);
1215 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1216 return SCM_SLOT (obj
, i
);
1220 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1221 (SCM obj
, SCM index
, SCM value
),
1222 "Set the slot with index @var{index} in @var{obj} to\n"
1224 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1226 unsigned long int i
;
1228 SCM_VALIDATE_INSTANCE (1, obj
);
1229 i
= scm_to_unsigned_integer (index
, 0, SCM_NUMBER_OF_SLOTS(obj
)-1);
1231 SCM_SET_SLOT (obj
, i
, value
);
1233 return SCM_UNSPECIFIED
;
1238 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
1239 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
1244 /* In the future, this function will return the effective slot
1245 * definition associated with SLOT_NAME. Now it just returns some of
1246 * the information which will be stored in the effective slot
1251 slot_definition_using_name (SCM
class, SCM slot_name
)
1253 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1254 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1255 if (SCM_CAAR (slots
) == slot_name
)
1256 return SCM_CAR (slots
);
1261 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1263 SCM access
= SCM_CDDR (slotdef
);
1265 * - access is an integer (the offset of this slot in the slots vector)
1266 * - otherwise (car access) is the getter function to apply
1268 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1269 * we can just assume fixnums here.
1271 if (SCM_I_INUMP (access
))
1272 return SCM_SLOT (obj
, SCM_I_INUM (access
));
1275 /* We must evaluate (apply (car access) (list obj))
1276 * where (car access) is known to be a closure of arity 1 */
1277 register SCM code
, env
;
1279 code
= SCM_CAR (access
);
1280 if (!SCM_CLOSUREP (code
))
1281 return SCM_SUBRF (code
) (obj
);
1282 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1285 /* Evaluate the closure body */
1286 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1291 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1293 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1294 if (scm_is_true (slotdef
))
1295 return get_slot_value (class, obj
, slotdef
);
1297 return CALL_GF3 ("slot-missing", class, obj
, slot_name
);
1301 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1303 SCM access
= SCM_CDDR (slotdef
);
1305 * - access is an integer (the offset of this slot in the slots vector)
1306 * - otherwise (cadr access) is the setter function to apply
1308 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1309 * we can just assume fixnums here.
1311 if (SCM_I_INUMP (access
))
1312 SCM_SET_SLOT (obj
, SCM_I_INUM (access
), value
);
1315 /* We must evaluate (apply (cadr l) (list obj value))
1316 * where (cadr l) is known to be a closure of arity 2 */
1317 register SCM code
, env
;
1319 code
= SCM_CADR (access
);
1320 if (!SCM_CLOSUREP (code
))
1321 SCM_SUBRF (code
) (obj
, value
);
1324 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1325 scm_list_2 (obj
, value
),
1327 /* Evaluate the closure body */
1328 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1331 return SCM_UNSPECIFIED
;
1335 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1337 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1338 if (scm_is_true (slotdef
))
1339 return set_slot_value (class, obj
, slotdef
, value
);
1341 return CALL_GF4 ("slot-missing", class, obj
, slot_name
, value
);
1345 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1349 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1350 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1356 /* ======================================== */
1358 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1359 (SCM
class, SCM obj
, SCM slot_name
),
1361 #define FUNC_NAME s_scm_slot_ref_using_class
1365 SCM_VALIDATE_CLASS (1, class);
1366 SCM_VALIDATE_INSTANCE (2, obj
);
1367 SCM_VALIDATE_SYMBOL (3, slot_name
);
1369 res
= get_slot_value_using_name (class, obj
, slot_name
);
1370 if (SCM_GOOPS_UNBOUNDP (res
))
1371 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1377 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1378 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1380 #define FUNC_NAME s_scm_slot_set_using_class_x
1382 SCM_VALIDATE_CLASS (1, class);
1383 SCM_VALIDATE_INSTANCE (2, obj
);
1384 SCM_VALIDATE_SYMBOL (3, slot_name
);
1386 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1391 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1392 (SCM
class, SCM obj
, SCM slot_name
),
1394 #define FUNC_NAME s_scm_slot_bound_using_class_p
1396 SCM_VALIDATE_CLASS (1, class);
1397 SCM_VALIDATE_INSTANCE (2, obj
);
1398 SCM_VALIDATE_SYMBOL (3, slot_name
);
1400 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1406 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1407 (SCM
class, SCM obj
, SCM slot_name
),
1409 #define FUNC_NAME s_scm_slot_exists_using_class_p
1411 SCM_VALIDATE_CLASS (1, class);
1412 SCM_VALIDATE_INSTANCE (2, obj
);
1413 SCM_VALIDATE_SYMBOL (3, slot_name
);
1414 return test_slot_existence (class, obj
, slot_name
);
1419 /* ======================================== */
1421 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1422 (SCM obj
, SCM slot_name
),
1423 "Return the value from @var{obj}'s slot with the name\n"
1425 #define FUNC_NAME s_scm_slot_ref
1429 SCM_VALIDATE_INSTANCE (1, obj
);
1430 TEST_CHANGE_CLASS (obj
, class);
1432 res
= get_slot_value_using_name (class, obj
, slot_name
);
1433 if (SCM_GOOPS_UNBOUNDP (res
))
1434 return CALL_GF3 ("slot-unbound", class, obj
, slot_name
);
1439 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1440 (SCM obj
, SCM slot_name
, SCM value
),
1441 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1442 #define FUNC_NAME s_scm_slot_set_x
1446 SCM_VALIDATE_INSTANCE (1, obj
);
1447 TEST_CHANGE_CLASS(obj
, class);
1449 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1453 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1455 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1456 (SCM obj
, SCM slot_name
),
1457 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1459 #define FUNC_NAME s_scm_slot_bound_p
1463 SCM_VALIDATE_INSTANCE (1, obj
);
1464 TEST_CHANGE_CLASS(obj
, class);
1466 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1474 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1475 (SCM obj
, SCM slot_name
),
1476 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1477 #define FUNC_NAME s_scm_slot_exists_p
1481 SCM_VALIDATE_INSTANCE (1, obj
);
1482 SCM_VALIDATE_SYMBOL (2, slot_name
);
1483 TEST_CHANGE_CLASS (obj
, class);
1485 return test_slot_existence (class, obj
, slot_name
);
1490 /******************************************************************************
1492 * %allocate-instance (the low level instance allocation primitive)
1494 ******************************************************************************/
1496 static void clear_method_cache (SCM
);
1499 wrap_init (SCM
class, SCM
*m
, long n
)
1503 /* Set all slots to unbound */
1504 for (i
= 0; i
< n
; i
++)
1505 m
[i
] = SCM_GOOPS_UNBOUND
;
1507 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1509 (scm_t_bits
) m
, 0, 0);
1512 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1513 (SCM
class, SCM initargs
),
1514 "Create a new instance of class @var{class} and initialize it\n"
1515 "from the arguments @var{initargs}.")
1516 #define FUNC_NAME s_scm_sys_allocate_instance
1521 SCM_VALIDATE_CLASS (1, class);
1523 /* Most instances */
1524 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1526 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1527 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1528 return wrap_init (class, m
, n
);
1531 /* Foreign objects */
1532 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1533 return scm_make_foreign_object (class, initargs
);
1535 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1538 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY
)
1540 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1542 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1543 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1544 /* Generic functions */
1545 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1547 SCM gf
= wrap_init (class, m
, n
);
1548 clear_method_cache (gf
);
1552 return wrap_init (class, m
, n
);
1556 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1560 /* allocate class object */
1561 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1563 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1564 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1565 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1567 if (SCM_SUBCLASSP (class, scm_class_entity_class
))
1568 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
| SCM_CLASSF_ENTITY
);
1569 else if (SCM_SUBCLASSP (class, scm_class_operator_class
))
1570 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_OPERATOR
);
1575 /* Non-light instances */
1577 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1578 return wrap_init (class, m
, n
);
1583 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1584 (SCM obj
, SCM setter
),
1586 #define FUNC_NAME s_scm_sys_set_object_setter_x
1588 SCM_ASSERT (SCM_STRUCTP (obj
)
1589 && ((SCM_CLASS_FLAGS (obj
) & SCM_CLASSF_OPERATOR
)
1590 || SCM_I_ENTITYP (obj
)),
1594 if (SCM_I_ENTITYP (obj
))
1595 SCM_SET_ENTITY_SETTER (obj
, setter
);
1597 SCM_OPERATOR_CLASS (obj
)->setter
= setter
;
1598 return SCM_UNSPECIFIED
;
1602 /******************************************************************************
1604 * %modify-instance (used by change-class to modify in place)
1606 ******************************************************************************/
1608 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1611 #define FUNC_NAME s_scm_sys_modify_instance
1613 SCM_VALIDATE_INSTANCE (1, old
);
1614 SCM_VALIDATE_INSTANCE (2, new);
1616 /* Exchange the data contained in old and new. We exchange rather than
1617 * scratch the old value with new to be correct with GC.
1618 * See "Class redefinition protocol above".
1620 SCM_CRITICAL_SECTION_START
;
1622 SCM car
= SCM_CAR (old
);
1623 SCM cdr
= SCM_CDR (old
);
1624 SCM_SETCAR (old
, SCM_CAR (new));
1625 SCM_SETCDR (old
, SCM_CDR (new));
1626 SCM_SETCAR (new, car
);
1627 SCM_SETCDR (new, cdr
);
1629 SCM_CRITICAL_SECTION_END
;
1630 return SCM_UNSPECIFIED
;
1634 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1637 #define FUNC_NAME s_scm_sys_modify_class
1639 SCM_VALIDATE_CLASS (1, old
);
1640 SCM_VALIDATE_CLASS (2, new);
1642 SCM_CRITICAL_SECTION_START
;
1644 SCM car
= SCM_CAR (old
);
1645 SCM cdr
= SCM_CDR (old
);
1646 SCM_SETCAR (old
, SCM_CAR (new));
1647 SCM_SETCDR (old
, SCM_CDR (new));
1648 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1649 SCM_SETCAR (new, car
);
1650 SCM_SETCDR (new, cdr
);
1651 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1653 SCM_CRITICAL_SECTION_END
;
1654 return SCM_UNSPECIFIED
;
1658 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1661 #define FUNC_NAME s_scm_sys_invalidate_class
1663 SCM_VALIDATE_CLASS (1, class);
1664 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1665 return SCM_UNSPECIFIED
;
1669 /* When instances change class, they finally get a new body, but
1670 * before that, they go through purgatory in hell. Odd as it may
1671 * seem, this data structure saves us from eternal suffering in
1672 * infinite recursions.
1675 static scm_t_bits
**hell
;
1676 static long n_hell
= 1; /* one place for the evil one himself */
1677 static long hell_size
= 4;
1678 static SCM hell_mutex
;
1684 for (i
= 1; i
< n_hell
; ++i
)
1685 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1691 go_to_hell (void *o
)
1693 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1694 scm_lock_mutex (hell_mutex
);
1695 if (n_hell
== hell_size
)
1697 long new_size
= 2 * hell_size
;
1698 hell
= scm_realloc (hell
, new_size
);
1699 hell_size
= new_size
;
1701 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1702 scm_unlock_mutex (hell_mutex
);
1706 go_to_heaven (void *o
)
1708 scm_lock_mutex (hell_mutex
);
1709 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1710 scm_unlock_mutex (hell_mutex
);
1714 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1717 purgatory (void *args
)
1719 return scm_apply_0 (GETVAR (scm_sym_change_class
),
1720 SCM_PACK ((scm_t_bits
) args
));
1723 /* This function calls the generic function change-class for all
1724 * instances which aren't currently undergoing class change.
1728 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1731 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1732 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1733 (void *) SCM_UNPACK (obj
));
1736 /******************************************************************************
1742 * GGG E N E R I C F U N C T I O N S
1744 * This implementation provides
1745 * - generic functions (with class specializers)
1748 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1750 ******************************************************************************/
1752 SCM_KEYWORD (k_name
, "name");
1754 SCM_SYMBOL (sym_no_method
, "no-method");
1756 static SCM list_of_no_method
;
1758 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1762 scm_make_method_cache (SCM gf
)
1764 return scm_list_5 (SCM_IM_DISPATCH
,
1767 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1773 clear_method_cache (SCM gf
)
1775 SCM cache
= scm_make_method_cache (gf
);
1776 SCM_SET_ENTITY_PROCEDURE (gf
, cache
);
1777 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1780 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1783 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1786 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1787 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1788 if (scm_is_true (used_by
))
1790 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1791 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1792 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1793 clear_method_cache (gf
);
1794 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1795 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1798 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1799 /* The sign of n is a flag indicating rest args. */
1800 SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf
), n
);
1802 return SCM_UNSPECIFIED
;
1806 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1809 #define FUNC_NAME s_scm_generic_capability_p
1811 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1812 proc
, SCM_ARG1
, FUNC_NAME
);
1813 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1819 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1822 #define FUNC_NAME s_scm_enable_primitive_generic_x
1824 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1825 while (!scm_is_null (subrs
))
1827 SCM subr
= SCM_CAR (subrs
);
1828 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1829 subr
, SCM_ARGn
, FUNC_NAME
);
1830 *SCM_SUBR_GENERIC (subr
)
1831 = scm_make (scm_list_3 (scm_class_generic
,
1834 subrs
= SCM_CDR (subrs
);
1836 return SCM_UNSPECIFIED
;
1840 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1843 #define FUNC_NAME s_scm_primitive_generic_generic
1845 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1847 if (!*SCM_SUBR_GENERIC (subr
))
1848 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1849 return *SCM_SUBR_GENERIC (subr
);
1851 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1855 typedef struct t_extension
{
1856 struct t_extension
*next
;
1861 static t_extension
*extensions
= 0;
1863 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1866 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1871 if (!*SCM_SUBR_GENERIC (extended
))
1872 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1873 gf
= *SCM_SUBR_GENERIC (extended
);
1874 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1876 SCM_SNAME (extension
));
1877 *SCM_SUBR_GENERIC (extension
) = gext
;
1881 t_extension
*e
= scm_malloc (sizeof (t_extension
));
1882 t_extension
**loc
= &extensions
;
1883 /* Make sure that extensions are placed before their own
1884 * extensions in the extensions list. O(N^2) algorithm, but
1885 * extensions of primitive generics are rare.
1887 while (*loc
&& extension
!= (*loc
)->extended
)
1888 loc
= &(*loc
)->next
;
1890 e
->extended
= extended
;
1891 e
->extension
= extension
;
1897 setup_extended_primitive_generics ()
1901 t_extension
*e
= extensions
;
1902 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1903 extensions
= e
->next
;
1908 /******************************************************************************
1910 * Protocol for calling a generic fumction
1911 * This protocol is roughly equivalent to (parameter are a little bit different
1912 * for efficiency reasons):
1914 * + apply-generic (gf args)
1915 * + compute-applicable-methods (gf args ...)
1916 * + sort-applicable-methods (methods args)
1917 * + apply-methods (gf methods args)
1919 * apply-methods calls make-next-method to build the "continuation" of a a
1920 * method. Applying a next-method will call apply-next-method which in
1921 * turn will call apply again to call effectively the following method.
1923 ******************************************************************************/
1926 applicablep (SCM actual
, SCM formal
)
1928 /* We already know that the cpl is well formed. */
1929 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
1933 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
1935 register SCM s1
, s2
;
1939 * m1 and m2 can have != length (i.e. one can be one element longer than the
1940 * other when we have a dotted parameter list). For instance, with the call
1943 * (define-method M (a . l) ....)
1944 * (define-method M (a) ....)
1946 * we consider that the second method is more specific.
1948 * BTW, targs is an array of types. We don't need it's size since
1949 * we already know that m1 and m2 are applicable (no risk to go past
1950 * the end of this array).
1953 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
1954 if (scm_is_null(s1
)) return 1;
1955 if (scm_is_null(s2
)) return 0;
1956 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
1957 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
1959 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
1960 if (cs1
== SCM_CAR(l
))
1962 if (cs2
== SCM_CAR(l
))
1965 return 0;/* should not occur! */
1968 return 0; /* should not occur! */
1971 #define BUFFSIZE 32 /* big enough for most uses */
1974 scm_i_vector2list (SCM l
, long len
)
1977 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
1979 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
1980 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
1986 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
1989 SCM
*v
, vector
= SCM_EOL
;
1990 SCM buffer
[BUFFSIZE
];
1991 SCM save
= method_list
;
1992 scm_t_array_handle handle
;
1994 /* For reasonably sized method_lists we can try to avoid all the
1995 * consing and reorder the list in place...
1996 * This idea is due to David McClain <Dave_McClain@msn.com>
1998 if (size
<= BUFFSIZE
)
2000 for (i
= 0; i
< size
; i
++)
2002 buffer
[i
] = SCM_CAR (method_list
);
2003 method_list
= SCM_CDR (method_list
);
2009 /* Too many elements in method_list to keep everything locally */
2010 vector
= scm_i_vector2list (save
, size
);
2011 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2014 /* Use a simple shell sort since it is generally faster than qsort on
2015 * small vectors (which is probably mostly the case when we have to
2016 * sort a list of applicable methods).
2018 for (incr
= size
/ 2; incr
; incr
/= 2)
2020 for (i
= incr
; i
< size
; i
++)
2022 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2024 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2028 SCM tmp
= v
[j
+ incr
];
2036 if (size
<= BUFFSIZE
)
2038 /* We did it in locally, so restore the original list (reordered) in-place */
2039 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2041 SCM_SETCAR (method_list
, *v
);
2042 method_list
= SCM_CDR (method_list
);
2047 /* If we are here, that's that we did it the hard way... */
2048 scm_array_handle_release (&handle
);
2049 return scm_vector_to_list (vector
);
2053 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2057 SCM l
, fl
, applicable
= SCM_EOL
;
2059 SCM buffer
[BUFFSIZE
];
2063 scm_t_array_handle handle
;
2065 /* Build the list of arguments types */
2066 if (len
>= BUFFSIZE
)
2068 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2069 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2072 note that we don't have to work to reset the generation
2073 count. TMP is a new vector anyway, and it is found
2080 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2081 *p
++ = scm_class_of (SCM_CAR (args
));
2083 /* Build a list of all applicable methods */
2084 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2086 fl
= SPEC_OF (SCM_CAR (l
));
2087 /* Only accept accessors which match exactly in first arg. */
2088 if (SCM_ACCESSORP (SCM_CAR (l
))
2089 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2091 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2093 if (SCM_INSTANCEP (fl
)
2094 /* We have a dotted argument list */
2095 || (i
>= len
&& scm_is_null (fl
)))
2096 { /* both list exhausted */
2097 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2103 || !applicablep (types
[i
], SCM_CAR (fl
)))
2108 if (len
>= BUFFSIZE
)
2109 scm_array_handle_release (&handle
);
2115 CALL_GF2 ("no-applicable-method", gf
, save
);
2116 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2122 : sort_applicable_methods (applicable
, count
, types
));
2126 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2129 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2132 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2133 #define FUNC_NAME s_sys_compute_applicable_methods
2136 SCM_VALIDATE_GENERIC (1, gf
);
2137 n
= scm_ilength (args
);
2138 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2139 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2143 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2144 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
));
2147 lock_cache_mutex (void *m
)
2149 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2150 scm_lock_mutex (mutex
);
2154 unlock_cache_mutex (void *m
)
2156 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2157 scm_unlock_mutex (mutex
);
2161 call_memoize_method (void *a
)
2163 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2164 SCM gf
= SCM_CAR (args
);
2165 SCM x
= SCM_CADR (args
);
2166 /* First check if another thread has inserted a method between
2167 * the cache miss and locking the mutex.
2169 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2170 if (scm_is_true (cmethod
))
2172 /*fixme* Use scm_apply */
2173 return CALL_GF3 ("memoize-method!", gf
, SCM_CDDR (args
), x
);
2177 scm_memoize_method (SCM x
, SCM args
)
2179 SCM gf
= SCM_CAR (scm_last_pair (x
));
2180 return scm_internal_dynamic_wind (
2182 call_memoize_method
,
2184 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2185 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2188 /******************************************************************************
2190 * A simple make (which will be redefined later in Scheme)
2191 * This version handles only creation of gf, methods and classes (no instances)
2193 * Since this code will disappear when Goops will be fully booted,
2194 * no precaution is taken to be efficient.
2196 ******************************************************************************/
2198 SCM_KEYWORD (k_setter
, "setter");
2199 SCM_KEYWORD (k_specializers
, "specializers");
2200 SCM_KEYWORD (k_procedure
, "procedure");
2201 SCM_KEYWORD (k_dsupers
, "dsupers");
2202 SCM_KEYWORD (k_slots
, "slots");
2203 SCM_KEYWORD (k_gf
, "generic-function");
2205 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2207 "Make a new object. @var{args} must contain the class and\n"
2208 "all necessary initialization information.")
2209 #define FUNC_NAME s_scm_make
2212 long len
= scm_ilength (args
);
2214 if (len
<= 0 || (len
& 1) == 0)
2215 SCM_WRONG_NUM_ARGS ();
2217 class = SCM_CAR(args
);
2218 args
= SCM_CDR(args
);
2220 if (class == scm_class_generic
|| class == scm_class_accessor
)
2222 z
= scm_make_struct (class, SCM_INUM0
,
2223 scm_list_5 (SCM_EOL
,
2228 scm_set_procedure_property_x (z
, scm_sym_name
,
2229 scm_get_keyword (k_name
,
2232 clear_method_cache (z
);
2233 if (class == scm_class_accessor
)
2235 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2236 if (scm_is_true (setter
))
2237 scm_sys_set_object_setter_x (z
, setter
);
2242 z
= scm_sys_allocate_instance (class, args
);
2244 if (class == scm_class_method
2245 || class == scm_class_simple_method
2246 || class == scm_class_accessor_method
)
2248 SCM_SET_SLOT (z
, scm_si_generic_function
,
2249 scm_i_get_keyword (k_gf
,
2254 SCM_SET_SLOT (z
, scm_si_specializers
,
2255 scm_i_get_keyword (k_specializers
,
2260 SCM_SET_SLOT (z
, scm_si_procedure
,
2261 scm_i_get_keyword (k_procedure
,
2266 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2270 /* In all the others case, make a new class .... No instance here */
2271 SCM_SET_SLOT (z
, scm_si_name
,
2272 scm_i_get_keyword (k_name
,
2275 scm_from_locale_symbol ("???"),
2277 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2278 scm_i_get_keyword (k_dsupers
,
2283 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2284 scm_i_get_keyword (k_slots
,
2295 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2298 #define FUNC_NAME s_scm_find_method
2301 long len
= scm_ilength (l
);
2304 SCM_WRONG_NUM_ARGS ();
2306 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2307 SCM_VALIDATE_GENERIC (1, gf
);
2308 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2309 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2311 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2315 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2316 (SCM m1
, SCM m2
, SCM targs
),
2318 #define FUNC_NAME s_scm_sys_method_more_specific_p
2323 scm_t_array_handle handle
;
2325 SCM_VALIDATE_METHOD (1, m1
);
2326 SCM_VALIDATE_METHOD (2, m2
);
2327 SCM_ASSERT ((len
= scm_ilength (targs
)) != -1, targs
, SCM_ARG3
, FUNC_NAME
);
2329 /* Verify that all the arguments of targs are classes and place them
2333 v
= scm_c_make_vector (len
, SCM_EOL
);
2334 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2336 for (i
= 0, l
= targs
; i
< len
&& scm_is_pair (l
); i
++, l
= SCM_CDR (l
))
2338 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2339 v_elts
[i
] = SCM_CAR(l
);
2341 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2343 scm_array_handle_release (&handle
);
2351 /******************************************************************************
2355 ******************************************************************************/
2358 fix_cpl (SCM c
, SCM before
, SCM after
)
2360 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2361 SCM ls
= scm_c_memq (after
, cpl
);
2362 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2363 if (scm_is_false (ls
))
2364 /* if this condition occurs, fix_cpl should not be applied this way */
2366 SCM_SETCAR (ls
, before
);
2367 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2369 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2370 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2371 SCM g_n_s
= compute_getters_n_setters (slots
);
2372 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2373 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2379 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2381 SCM tmp
= scm_from_locale_symbol (name
);
2383 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2387 : scm_list_1 (super
),
2393 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2396 create_standard_classes (void)
2399 SCM method_slots
= scm_list_4 (scm_from_locale_symbol ("generic-function"),
2400 scm_from_locale_symbol ("specializers"),
2402 scm_from_locale_symbol ("code-table"));
2403 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2405 k_slot_definition
));
2406 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2407 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2411 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2412 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2415 scm_list_3 (scm_from_locale_symbol ("used-by"),
2418 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2421 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2424 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2427 /* Foreign class slot classes */
2428 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2429 scm_class_class
, scm_class_top
, SCM_EOL
);
2430 make_stdcls (&scm_class_protected
, "<protected-slot>",
2431 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2432 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2433 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2434 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2435 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2436 make_stdcls (&scm_class_self
, "<self-slot>",
2438 scm_class_read_only
,
2440 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2442 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2444 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2446 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2448 make_stdcls (&scm_class_scm
, "<scm-slot>",
2449 scm_class_class
, scm_class_protected
, SCM_EOL
);
2450 make_stdcls (&scm_class_int
, "<int-slot>",
2451 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2452 make_stdcls (&scm_class_float
, "<float-slot>",
2453 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2454 make_stdcls (&scm_class_double
, "<double-slot>",
2455 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2457 /* Continue initialization of class <class> */
2459 slots
= build_class_class_slots ();
2460 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2461 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2462 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2463 compute_getters_n_setters (slots
));
2465 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2466 scm_class_class
, scm_class_class
,
2467 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2470 scm_list_3 (scm_from_locale_symbol ("destructor"),
2472 scm_class_opaque
)));
2473 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2474 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2475 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2477 /* scm_class_generic functions classes */
2478 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2479 scm_class_class
, scm_class_class
, SCM_EOL
);
2480 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2481 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2482 make_stdcls (&scm_class_operator_class
, "<operator-class>",
2483 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2484 make_stdcls (&scm_class_operator_with_setter_class
,
2485 "<operator-with-setter-class>",
2486 scm_class_class
, scm_class_operator_class
, SCM_EOL
);
2487 make_stdcls (&scm_class_method
, "<method>",
2488 scm_class_class
, scm_class_object
, method_slots
);
2489 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2490 scm_class_class
, scm_class_method
, SCM_EOL
);
2491 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2492 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2493 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2494 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2495 make_stdcls (&scm_class_applicable
, "<applicable>",
2496 scm_class_class
, scm_class_top
, SCM_EOL
);
2497 make_stdcls (&scm_class_entity
, "<entity>",
2498 scm_class_entity_class
,
2499 scm_list_2 (scm_class_object
, scm_class_applicable
),
2501 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2502 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2503 make_stdcls (&scm_class_generic
, "<generic>",
2504 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2505 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2506 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2507 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2508 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2509 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2510 scm_class_entity_class
,
2511 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2513 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2514 make_stdcls (&scm_class_accessor
, "<accessor>",
2515 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2516 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2517 make_stdcls (&scm_class_extended_generic_with_setter
,
2518 "<extended-generic-with-setter>",
2519 scm_class_entity_class
,
2520 scm_list_2 (scm_class_generic_with_setter
,
2521 scm_class_extended_generic
),
2523 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2524 SCM_CLASSF_PURE_GENERIC
);
2525 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2526 scm_class_entity_class
,
2527 scm_list_2 (scm_class_accessor
,
2528 scm_class_extended_generic_with_setter
),
2530 fix_cpl (scm_class_extended_accessor
,
2531 scm_class_extended_generic
, scm_class_generic
);
2532 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2534 /* Primitive types classes */
2535 make_stdcls (&scm_class_boolean
, "<boolean>",
2536 scm_class_class
, scm_class_top
, SCM_EOL
);
2537 make_stdcls (&scm_class_char
, "<char>",
2538 scm_class_class
, scm_class_top
, SCM_EOL
);
2539 make_stdcls (&scm_class_list
, "<list>",
2540 scm_class_class
, scm_class_top
, SCM_EOL
);
2541 make_stdcls (&scm_class_pair
, "<pair>",
2542 scm_class_class
, scm_class_list
, SCM_EOL
);
2543 make_stdcls (&scm_class_null
, "<null>",
2544 scm_class_class
, scm_class_list
, SCM_EOL
);
2545 make_stdcls (&scm_class_string
, "<string>",
2546 scm_class_class
, scm_class_top
, SCM_EOL
);
2547 make_stdcls (&scm_class_symbol
, "<symbol>",
2548 scm_class_class
, scm_class_top
, SCM_EOL
);
2549 make_stdcls (&scm_class_vector
, "<vector>",
2550 scm_class_class
, scm_class_top
, SCM_EOL
);
2551 make_stdcls (&scm_class_number
, "<number>",
2552 scm_class_class
, scm_class_top
, SCM_EOL
);
2553 make_stdcls (&scm_class_complex
, "<complex>",
2554 scm_class_class
, scm_class_number
, SCM_EOL
);
2555 make_stdcls (&scm_class_real
, "<real>",
2556 scm_class_class
, scm_class_complex
, SCM_EOL
);
2557 make_stdcls (&scm_class_integer
, "<integer>",
2558 scm_class_class
, scm_class_real
, SCM_EOL
);
2559 make_stdcls (&scm_class_fraction
, "<fraction>",
2560 scm_class_class
, scm_class_real
, SCM_EOL
);
2561 make_stdcls (&scm_class_keyword
, "<keyword>",
2562 scm_class_class
, scm_class_top
, SCM_EOL
);
2563 make_stdcls (&scm_class_unknown
, "<unknown>",
2564 scm_class_class
, scm_class_top
, SCM_EOL
);
2565 make_stdcls (&scm_class_procedure
, "<procedure>",
2566 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2567 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2568 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2569 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2570 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2571 make_stdcls (&scm_class_port
, "<port>",
2572 scm_class_class
, scm_class_top
, SCM_EOL
);
2573 make_stdcls (&scm_class_input_port
, "<input-port>",
2574 scm_class_class
, scm_class_port
, SCM_EOL
);
2575 make_stdcls (&scm_class_output_port
, "<output-port>",
2576 scm_class_class
, scm_class_port
, SCM_EOL
);
2577 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2579 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2583 /**********************************************************************
2587 **********************************************************************/
2590 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2596 sprintf (buffer
, template, type_name
);
2597 name
= scm_from_locale_symbol (buffer
);
2600 name
= SCM_GOOPS_UNBOUND
;
2602 class = scm_permanent_object (scm_basic_make_class (applicablep
2603 ? scm_class_procedure_class
2609 /* Only define name if doesn't already exist. */
2610 if (!SCM_GOOPS_UNBOUNDP (name
)
2611 && scm_is_false (scm_call_2 (scm_goops_lookup_closure
, name
, SCM_BOOL_F
)))
2612 DEFVAR (name
, class);
2617 scm_make_extended_class (char const *type_name
, int applicablep
)
2619 return make_class_from_template ("<%s>",
2621 scm_list_1 (applicablep
2622 ? scm_class_applicable
2628 scm_i_inherit_applicable (SCM c
)
2630 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2632 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2633 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2634 /* patch scm_class_applicable into direct-supers */
2635 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2636 if (scm_is_false (top
))
2637 dsupers
= scm_append (scm_list_2 (dsupers
,
2638 scm_list_1 (scm_class_applicable
)));
2641 SCM_SETCAR (top
, scm_class_applicable
);
2642 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2644 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2645 /* patch scm_class_applicable into cpl */
2646 top
= scm_c_memq (scm_class_top
, cpl
);
2647 if (scm_is_false (top
))
2651 SCM_SETCAR (top
, scm_class_applicable
);
2652 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2654 /* add class to direct-subclasses of scm_class_applicable */
2655 SCM_SET_SLOT (scm_class_applicable
,
2656 scm_si_direct_subclasses
,
2657 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2658 scm_si_direct_subclasses
)));
2663 create_smob_classes (void)
2667 scm_smob_class
= (SCM
*) scm_malloc (255 * sizeof (SCM
));
2668 for (i
= 0; i
< 255; ++i
)
2669 scm_smob_class
[i
] = 0;
2671 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2673 for (i
= 0; i
< scm_numsmob
; ++i
)
2674 if (!scm_smob_class
[i
])
2675 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2676 scm_smobs
[i
].apply
!= 0);
2680 scm_make_port_classes (long ptobnum
, char *type_name
)
2682 SCM c
, class = make_class_from_template ("<%s-port>",
2684 scm_list_1 (scm_class_port
),
2686 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2687 = make_class_from_template ("<%s-input-port>",
2689 scm_list_2 (class, scm_class_input_port
),
2691 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2692 = make_class_from_template ("<%s-output-port>",
2694 scm_list_2 (class, scm_class_output_port
),
2696 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2698 = make_class_from_template ("<%s-input-output-port>",
2700 scm_list_2 (class, scm_class_input_output_port
),
2702 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2703 SCM_SET_SLOT (c
, scm_si_cpl
,
2704 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2708 create_port_classes (void)
2712 scm_port_class
= (SCM
*) scm_malloc (3 * 256 * sizeof (SCM
));
2713 for (i
= 0; i
< 3 * 256; ++i
)
2714 scm_port_class
[i
] = 0;
2716 for (i
= 0; i
< scm_numptob
; ++i
)
2717 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2721 make_struct_class (void *closure SCM_UNUSED
,
2722 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2724 if (scm_is_true (SCM_STRUCT_TABLE_NAME (data
)))
2725 SCM_SET_STRUCT_TABLE_CLASS (data
,
2726 scm_make_extended_class
2727 (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data
)),
2728 SCM_CLASS_FLAGS (vtable
) & SCM_CLASSF_OPERATOR
));
2729 return SCM_UNSPECIFIED
;
2733 create_struct_classes (void)
2735 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2738 /**********************************************************************
2742 **********************************************************************/
2747 if (!goops_loaded_p
)
2748 scm_c_resolve_module ("oop goops");
2753 scm_make_foreign_object (SCM
class, SCM initargs
)
2754 #define FUNC_NAME s_scm_make
2756 void * (*constructor
) (SCM
)
2757 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
2758 if (constructor
== 0)
2759 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
2760 return scm_wrap_object (class, constructor (initargs
));
2766 scm_free_foreign_object (SCM
*class, SCM
*data
)
2768 size_t (*destructor
) (void *)
2769 = (size_t (*) (void *)) class[scm_si_destructor
];
2770 return destructor (data
);
2774 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
2775 void * (*constructor
) (SCM initargs
),
2776 size_t (*destructor
) (void *))
2779 name
= scm_from_locale_symbol (s_name
);
2780 if (scm_is_null (supers
))
2781 supers
= scm_list_1 (scm_class_foreign_object
);
2782 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
2783 scm_sys_inherit_magic_x (class, supers
);
2785 if (destructor
!= 0)
2787 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
2788 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
2792 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light
);
2793 SCM_SET_CLASS_INSTANCE_SIZE (class, size
);
2796 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
2797 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
2802 SCM_SYMBOL (sym_o
, "o");
2803 SCM_SYMBOL (sym_x
, "x");
2805 SCM_KEYWORD (k_accessor
, "accessor");
2806 SCM_KEYWORD (k_getter
, "getter");
2809 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
2811 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
2816 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
2817 SCM (*getter
) (SCM obj
),
2818 SCM (*setter
) (SCM obj
, SCM x
),
2819 char *accessor_name
)
2822 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
2823 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
2824 setter
? setter
: default_setter
);
2826 /* Dirk:FIXME:: The following two expressions make use of the fact that
2827 * the memoizer will accept a subr-object in the place of a function.
2828 * This is not guaranteed to stay this way. */
2829 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2831 scm_list_2 (get
, sym_o
)),
2833 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2834 scm_list_2 (sym_o
, sym_x
),
2835 scm_list_3 (set
, sym_o
, sym_x
)),
2839 SCM name
= scm_from_locale_symbol (slot_name
);
2840 SCM aname
= scm_from_locale_symbol (accessor_name
);
2841 SCM gf
= scm_ensure_accessor (aname
);
2842 SCM slot
= scm_list_5 (name
,
2845 setter
? k_accessor
: k_getter
,
2847 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
2852 scm_add_method (scm_setter (gf
),
2853 scm_make (scm_list_5 (scm_class_accessor_method
,
2855 scm_list_2 (class, scm_class_top
),
2860 SCM_SET_SLOT (class, scm_si_slots
,
2861 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
2862 scm_list_1 (slot
))));
2864 SCM n
= SCM_SLOT (class, scm_si_nfields
);
2865 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1));
2866 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
2867 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
2868 scm_list_1 (gns
))));
2869 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
2876 scm_wrap_object (SCM
class, void *data
)
2878 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
2886 scm_wrap_component (SCM
class, SCM container
, void *data
)
2888 SCM obj
= scm_wrap_object (class, data
);
2889 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
2895 SCM_SETCDR (handle
, container
);
2900 scm_ensure_accessor (SCM name
)
2902 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2903 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2905 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2906 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2907 k_name
, name
, k_setter
, gf
));
2912 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2915 scm_add_method (SCM gf
, SCM m
)
2917 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2922 * Debugging utilities
2925 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2927 "Return @code{#t} if @var{obj} is a pure generic.")
2928 #define FUNC_NAME s_scm_pure_generic_p
2930 return scm_from_bool (SCM_PUREGENERICP (obj
));
2934 #endif /* GUILE_DEBUG */
2940 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2942 "Announce that GOOPS is loaded and perform initialization\n"
2943 "on the C level which depends on the loaded GOOPS modules.")
2944 #define FUNC_NAME s_scm_sys_goops_loaded
2947 var_compute_applicable_methods
=
2948 scm_sym2var (sym_compute_applicable_methods
, scm_goops_lookup_closure
,
2950 setup_extended_primitive_generics ();
2951 return SCM_UNSPECIFIED
;
2955 SCM scm_module_goops
;
2958 scm_init_goops_builtins (void)
2960 scm_module_goops
= scm_current_module ();
2961 scm_goops_lookup_closure
= scm_module_lookup_closure (scm_module_goops
);
2963 /* Not really necessary right now, but who knows...
2965 scm_permanent_object (scm_module_goops
);
2966 scm_permanent_object (scm_goops_lookup_closure
);
2968 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
2969 (scm_from_int (37)));
2971 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
2973 #include "libguile/goops.x"
2975 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
2977 hell
= scm_malloc (hell_size
);
2978 hell_mutex
= scm_permanent_object (scm_make_mutex ());
2980 create_basic_classes ();
2981 create_standard_classes ();
2982 create_smob_classes ();
2983 create_struct_classes ();
2984 create_port_classes ();
2987 SCM name
= scm_from_locale_symbol ("no-applicable-method");
2988 scm_no_applicable_method
2989 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
2992 DEFVAR (name
, scm_no_applicable_method
);
2995 return SCM_UNSPECIFIED
;
3001 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3002 scm_init_goops_builtins
);