1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
21 /* This software is a derivative work of other copyrighted softwares; the
22 * copyright notices of these softwares are placed in the file COPYRIGHTS
24 * This file is based upon stklos.c from the STk distribution by
25 * Erick Gallesio <eg@unice.fr>.
35 #include "libguile/_scm.h"
36 #include "libguile/alist.h"
37 #include "libguile/async.h"
38 #include "libguile/chars.h"
39 #include "libguile/debug.h"
40 #include "libguile/dynl.h"
41 #include "libguile/dynwind.h"
42 #include "libguile/eval.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/keywords.h"
45 #include "libguile/macros.h"
46 #include "libguile/modules.h"
47 #include "libguile/ports.h"
48 #include "libguile/procprop.h"
49 #include "libguile/programs.h"
50 #include "libguile/random.h"
51 #include "libguile/root.h"
52 #include "libguile/smob.h"
53 #include "libguile/strings.h"
54 #include "libguile/strports.h"
55 #include "libguile/vectors.h"
56 #include "libguile/weaks.h"
57 #include "libguile/vm.h"
59 #include "libguile/validate.h"
60 #include "libguile/goops.h"
62 #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
64 #define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
65 #define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
66 #define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
67 #define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
70 #define SCM_IN_PCLASS_INDEX 0
71 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
72 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
74 /* this file is a mess. in theory, though, we shouldn't have many SCM references
75 -- most of the references should be to vars. */
77 static SCM var_slot_unbound
= SCM_BOOL_F
;
78 static SCM var_slot_missing
= SCM_BOOL_F
;
79 static SCM var_compute_cpl
= SCM_BOOL_F
;
80 static SCM var_no_applicable_method
= SCM_BOOL_F
;
81 static SCM var_memoize_method_x
= SCM_BOOL_F
;
82 static SCM var_change_class
= SCM_BOOL_F
;
84 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
85 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
86 SCM_SYMBOL (sym_compute_cpl
, "compute-cpl");
87 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
88 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
89 SCM_SYMBOL (sym_change_class
, "change-class");
91 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
94 /* FIXME, exports should come from the scm file only */
95 #define DEFVAR(v, val) \
96 { scm_module_define (scm_module_goops, (v), (val)); \
97 scm_module_export (scm_module_goops, scm_list_1 ((v))); \
101 /* Class redefinition protocol:
103 A class is represented by a heap header h1 which points to a
104 malloc:ed memory block m1.
106 When a new version of a class is created, a new header h2 and
107 memory block m2 are allocated. The headers h1 and h2 then switch
108 pointers so that h1 refers to m2 and h2 to m1. In this way, names
109 bound to h1 will point to the new class at the same time as h2 will
110 be a handle which the GC will use to free m1.
112 The `redefined' slot of m1 will be set to point to h1. An old
113 instance will have its class pointer (the CAR of the heap header)
114 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
115 the class modification and the new class pointer can be found via
119 #define TEST_CHANGE_CLASS(obj, class) \
121 class = SCM_CLASS_OF (obj); \
122 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
124 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
125 class = SCM_CLASS_OF (obj); \
129 #define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
130 #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
132 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
133 #define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
135 static int goops_loaded_p
= 0;
136 static scm_t_rstate
*goops_rstate
;
138 /* These variables are filled in by the object system when loaded. */
139 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
140 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
141 SCM scm_class_procedure_with_setter
, scm_class_primitive_generic
;
142 SCM scm_class_vector
, scm_class_null
;
143 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
144 SCM scm_class_unknown
;
145 SCM scm_class_top
, scm_class_object
, scm_class_class
;
146 SCM scm_class_applicable
;
147 SCM scm_class_entity
, scm_class_entity_with_setter
;
148 SCM scm_class_generic
, scm_class_generic_with_setter
;
149 SCM scm_class_accessor
;
150 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
151 SCM scm_class_extended_accessor
;
152 SCM scm_class_method
;
153 SCM scm_class_simple_method
, scm_class_accessor_method
;
154 SCM scm_class_procedure_class
;
155 SCM scm_class_entity_class
;
156 SCM scm_class_number
, scm_class_list
;
157 SCM scm_class_keyword
;
158 SCM scm_class_port
, scm_class_input_output_port
;
159 SCM scm_class_input_port
, scm_class_output_port
;
160 SCM scm_class_foreign_class
, scm_class_foreign_object
;
161 SCM scm_class_foreign_slot
;
162 SCM scm_class_self
, scm_class_protected
;
163 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
164 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
166 SCM scm_class_int
, scm_class_float
, scm_class_double
;
168 /* Port classes. Allocate 3 times the maximum number of port types so that
169 input ports, output ports, and in/out ports can be stored at different
170 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
171 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
174 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
176 SCM scm_no_applicable_method
;
178 SCM_SYMBOL (scm_sym_define_public
, "define-public");
180 static SCM
scm_make_unbound (void);
181 static SCM
scm_unbound_p (SCM obj
);
182 static SCM
scm_assert_bound (SCM value
, SCM obj
);
183 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
184 static SCM
scm_sys_goops_loaded (void);
185 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
188 /* This function is used for efficient type dispatch. */
189 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
191 "Return the class of @var{x}.")
192 #define FUNC_NAME s_scm_class_of
194 switch (SCM_ITAG3 (x
))
198 return scm_class_integer
;
202 return scm_class_char
;
203 else if (scm_is_bool (x
))
204 return scm_class_boolean
;
205 else if (scm_is_null (x
))
206 return scm_class_null
;
208 return scm_class_unknown
;
211 switch (SCM_TYP7 (x
))
213 case scm_tcs_cons_nimcar
:
214 return scm_class_pair
;
215 case scm_tcs_closures
:
216 return scm_class_procedure
;
218 return scm_class_symbol
;
221 return scm_class_vector
;
223 return scm_class_string
;
225 switch SCM_TYP16 (x
) {
227 return scm_class_integer
;
229 return scm_class_real
;
230 case scm_tc16_complex
:
231 return scm_class_complex
;
232 case scm_tc16_fraction
:
233 return scm_class_fraction
;
243 case scm_tc7_subr_1o
:
244 case scm_tc7_subr_2o
:
245 case scm_tc7_lsubr_2
:
247 if (SCM_SUBR_GENERIC (x
) && *SCM_SUBR_GENERIC (x
))
248 return scm_class_primitive_generic
;
250 return scm_class_procedure
;
252 case scm_tc7_program
:
253 return scm_class_procedure
;
255 return scm_class_procedure_with_setter
;
259 scm_t_bits type
= SCM_TYP16 (x
);
260 if (type
!= scm_tc16_port_with_ps
)
261 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
262 x
= SCM_PORT_WITH_PS_PORT (x
);
263 /* fall through to ports */
266 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
267 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
268 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
269 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
270 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
272 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
273 return SCM_CLASS_OF (x
);
274 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
277 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
278 scm_change_object_class (x
,
279 SCM_CLASS_OF (x
), /* old */
280 SCM_OBJ_CLASS_REDEF (x
)); /* new */
281 return SCM_CLASS_OF (x
);
285 /* ordinary struct */
286 SCM handle
= scm_struct_create_handle (SCM_STRUCT_VTABLE (x
));
287 if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
))))
288 return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle
));
293 name
= SCM_STRUCT_TABLE_NAME (SCM_CDR (handle
));
294 if (!scm_is_symbol (name
))
295 name
= scm_string_to_symbol (scm_nullstr
);
298 scm_make_extended_class_from_symbol (name
,
299 SCM_STRUCT_APPLICABLE_P (x
));
300 SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle
), class);
306 return scm_class_pair
;
308 return scm_class_unknown
;
314 case scm_tc3_closure
:
318 return scm_class_unknown
;
322 /******************************************************************************
326 * This version doesn't fully handle multiple-inheritance. It serves
327 * only for booting classes and will be overloaded in Scheme
329 ******************************************************************************/
332 map (SCM (*proc
) (SCM
), SCM ls
)
334 if (scm_is_null (ls
))
338 SCM res
= scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
);
341 while (!scm_is_null (ls
))
343 SCM_SETCDR (h
, scm_cons (proc (SCM_CAR (ls
)), SCM_EOL
));
355 while (!scm_is_null (ls
))
357 SCM el
= SCM_CAR (ls
);
358 if (scm_is_false (scm_c_memq (el
, res
)))
359 res
= scm_cons (el
, res
);
366 compute_cpl (SCM
class)
369 return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl
), class);
372 SCM supers
= SCM_SLOT (class, scm_si_direct_supers
);
373 SCM ls
= scm_append (scm_acons (class, supers
,
374 map (compute_cpl
, supers
)));
375 return scm_reverse_x (filter_cpl (ls
), SCM_EOL
);
379 /******************************************************************************
383 ******************************************************************************/
386 remove_duplicate_slots (SCM l
, SCM res
, SCM slots_already_seen
)
394 if (!scm_is_symbol (tmp
))
395 scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp
));
397 if (scm_is_false (scm_c_memq (tmp
, slots_already_seen
))) {
398 res
= scm_cons (SCM_CAR (l
), res
);
399 slots_already_seen
= scm_cons (tmp
, slots_already_seen
);
402 return remove_duplicate_slots (SCM_CDR (l
), res
, slots_already_seen
);
406 build_slots_list (SCM dslots
, SCM cpl
)
408 register SCM res
= dslots
;
410 for (cpl
= SCM_CDR (cpl
); !scm_is_null (cpl
); cpl
= SCM_CDR (cpl
))
411 res
= scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl
),
412 scm_si_direct_slots
),
415 /* res contains a list of slots. Remove slots which appears more than once */
416 return remove_duplicate_slots (scm_reverse (res
), SCM_EOL
, SCM_EOL
);
423 while (!scm_is_null (ls
))
425 if (!scm_is_pair (SCM_CAR (ls
)))
426 SCM_SETCAR (ls
, scm_cons (SCM_CAR (ls
), SCM_EOL
));
433 SCM_DEFINE (scm_sys_compute_slots
, "%compute-slots", 1, 0, 0,
435 "Return a list consisting of the names of all slots belonging to\n"
436 "class @var{class}, i. e. the slots of @var{class} and of all of\n"
438 #define FUNC_NAME s_scm_sys_compute_slots
440 SCM_VALIDATE_CLASS (1, class);
441 return build_slots_list (SCM_SLOT (class, scm_si_direct_slots
),
442 SCM_SLOT (class, scm_si_cpl
));
447 /******************************************************************************
449 * compute-getters-n-setters
451 * This version doesn't handle slot options. It serves only for booting
452 * classes and will be overloaded in Scheme.
454 ******************************************************************************/
456 SCM_KEYWORD (k_init_value
, "init-value");
457 SCM_KEYWORD (k_init_thunk
, "init-thunk");
460 compute_getters_n_setters (SCM slots
)
466 for ( ; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
468 SCM init
= SCM_BOOL_F
;
469 SCM options
= SCM_CDAR (slots
);
470 if (!scm_is_null (options
))
472 init
= scm_get_keyword (k_init_value
, options
, 0);
475 init
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
477 scm_list_2 (scm_sym_quote
,
482 init
= scm_get_keyword (k_init_thunk
, options
, SCM_BOOL_F
);
484 *cdrloc
= scm_cons (scm_cons (SCM_CAAR (slots
),
486 scm_from_int (i
++))),
488 cdrloc
= SCM_CDRLOC (*cdrloc
);
493 /******************************************************************************
497 ******************************************************************************/
499 /*fixme* Manufacture keywords in advance */
501 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
505 for (i
= 0; i
!= len
; i
+= 2)
507 SCM obj
= SCM_CAR (l
);
509 if (!scm_is_keyword (obj
))
510 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
511 else if (scm_is_eq (obj
, key
))
517 return default_value
;
521 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
522 (SCM key
, SCM l
, SCM default_value
),
523 "Determine an associated value for the keyword @var{key} from\n"
524 "the list @var{l}. The list @var{l} has to consist of an even\n"
525 "number of elements, where, starting with the first, every\n"
526 "second element is a keyword, followed by its associated value.\n"
527 "If @var{l} does not hold a value for @var{key}, the value\n"
528 "@var{default_value} is returned.")
529 #define FUNC_NAME s_scm_get_keyword
533 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
534 len
= scm_ilength (l
);
535 if (len
< 0 || len
% 2 == 1)
536 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
538 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
543 SCM_KEYWORD (k_init_keyword
, "init-keyword");
545 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
546 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
548 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
549 (SCM obj
, SCM initargs
),
550 "Initialize the object @var{obj} with the given arguments\n"
552 #define FUNC_NAME s_scm_sys_initialize_object
554 SCM tmp
, get_n_set
, slots
;
555 SCM
class = SCM_CLASS_OF (obj
);
558 SCM_VALIDATE_INSTANCE (1, obj
);
559 n_initargs
= scm_ilength (initargs
);
560 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
562 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
563 slots
= SCM_SLOT (class, scm_si_slots
);
565 /* See for each slot how it must be initialized */
567 !scm_is_null (slots
);
568 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
570 SCM slot_name
= SCM_CAR (slots
);
573 if (!scm_is_null (SCM_CDR (slot_name
)))
575 /* This slot admits (perhaps) to be initialized at creation time */
576 long n
= scm_ilength (SCM_CDR (slot_name
));
577 if (n
& 1) /* odd or -1 */
578 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
579 scm_list_1 (slot_name
));
580 tmp
= scm_i_get_keyword (k_init_keyword
,
585 slot_name
= SCM_CAR (slot_name
);
588 /* an initarg was provided for this slot */
589 if (!scm_is_keyword (tmp
))
590 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
592 slot_value
= scm_i_get_keyword (tmp
,
601 /* set slot to provided value */
602 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
605 /* set slot to its :init-form if it exists */
606 tmp
= SCM_CADAR (get_n_set
);
607 if (scm_is_true (tmp
))
609 slot_value
= get_slot_value (class, obj
, SCM_CAR (get_n_set
));
610 if (SCM_GOOPS_UNBOUNDP (slot_value
))
611 set_slot_value (class,
623 /* NOTE: The following macros are interdependent with code
624 * in goops.scm:compute-getters-n-setters
626 #define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
627 (SCM_I_INUMP (SCM_CDDR (gns)) \
628 || (scm_is_pair (SCM_CDDR (gns)) \
629 && scm_is_pair (SCM_CDDDR (gns)) \
630 && scm_is_pair (SCM_CDDDDR (gns))))
631 #define SCM_GNS_INDEX(gns) \
632 (SCM_I_INUMP (SCM_CDDR (gns)) \
633 ? SCM_I_INUM (SCM_CDDR (gns)) \
634 : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
635 #define SCM_GNS_SIZE(gns) \
636 (SCM_I_INUMP (SCM_CDDR (gns)) \
638 : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
640 SCM_KEYWORD (k_class
, "class");
641 SCM_KEYWORD (k_allocation
, "allocation");
642 SCM_KEYWORD (k_instance
, "instance");
644 SCM_DEFINE (scm_sys_prep_layout_x
, "%prep-layout!", 1, 0, 0,
647 #define FUNC_NAME s_scm_sys_prep_layout_x
649 SCM slots
, getters_n_setters
, nfields
;
650 unsigned long int n
, i
;
654 SCM_VALIDATE_INSTANCE (1, class);
655 slots
= SCM_SLOT (class, scm_si_slots
);
656 getters_n_setters
= SCM_SLOT (class, scm_si_getters_n_setters
);
657 nfields
= SCM_SLOT (class, scm_si_nfields
);
658 if (!SCM_I_INUMP (nfields
) || SCM_I_INUM (nfields
) < 0)
659 SCM_MISC_ERROR ("bad value in nfields slot: ~S",
660 scm_list_1 (nfields
));
661 n
= 2 * SCM_I_INUM (nfields
);
662 if (n
< sizeof (SCM_CLASS_CLASS_LAYOUT
) - 1
663 && SCM_SUBCLASSP (class, scm_class_class
))
664 SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
665 scm_list_1 (nfields
));
667 layout
= scm_i_make_string (n
, &s
);
669 while (scm_is_pair (getters_n_setters
))
671 if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters
)))
674 int len
, index
, size
;
677 if (i
>= n
|| !scm_is_pair (slots
))
680 /* extract slot type */
681 len
= scm_ilength (SCM_CDAR (slots
));
682 type
= scm_i_get_keyword (k_class
, SCM_CDAR (slots
),
683 len
, SCM_BOOL_F
, FUNC_NAME
);
684 /* determine slot GC protection and access mode */
685 if (scm_is_false (type
))
692 if (!SCM_CLASSP (type
))
693 SCM_MISC_ERROR ("bad slot class", SCM_EOL
);
694 else if (SCM_SUBCLASSP (type
, scm_class_foreign_slot
))
696 if (SCM_SUBCLASSP (type
, scm_class_self
))
698 else if (SCM_SUBCLASSP (type
, scm_class_protected
))
703 if (SCM_SUBCLASSP (type
, scm_class_opaque
))
705 else if (SCM_SUBCLASSP (type
, scm_class_read_only
))
707 else if (SCM_SUBCLASSP (type
, scm_class_hidden
))
719 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
720 if (index
!= (i
>> 1))
722 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
730 slots
= SCM_CDR (slots
);
731 getters_n_setters
= SCM_CDR (getters_n_setters
);
733 if (!scm_is_null (slots
))
736 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
738 SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout
));
739 return SCM_UNSPECIFIED
;
743 static void prep_hashsets (SCM
);
745 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
746 (SCM
class, SCM dsupers
),
748 #define FUNC_NAME s_scm_sys_inherit_magic_x
752 SCM_VALIDATE_INSTANCE (1, class);
753 while (!scm_is_null (ls
))
755 SCM_ASSERT (scm_is_pair (ls
)
756 && SCM_INSTANCEP (SCM_CAR (ls
)),
760 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
764 SCM_SET_CLASS_FLAGS (class, flags
&~SCM_CLASSF_PURE_GENERIC
);
766 prep_hashsets (class);
768 return SCM_UNSPECIFIED
;
773 prep_hashsets (SCM
class)
777 for (i
= 0; i
< 8; ++i
)
778 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
781 /******************************************************************************/
784 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
786 SCM z
, cpl
, slots
, nfields
, g_n_s
;
788 /* Allocate one instance */
789 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
791 /* Initialize its slots */
792 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
793 cpl
= compute_cpl (z
);
794 slots
= build_slots_list (maplist (dslots
), cpl
);
795 nfields
= scm_from_int (scm_ilength (slots
));
796 g_n_s
= compute_getters_n_setters (slots
);
798 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
799 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
800 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
801 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
802 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
803 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
804 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
805 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
806 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
807 SCM_SET_SLOT (z
, scm_si_environment
,
808 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
810 /* Add this class in the direct-subclasses slot of dsupers */
813 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
814 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
815 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
816 scm_si_direct_subclasses
)));
819 /* Support for the underlying structs: */
820 /* FIXME: set entity flag on z if class == entity_class ? */
821 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_GOOPS_OR_VALID
);
826 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
828 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
829 scm_sys_inherit_magic_x (z
, dsupers
);
830 scm_sys_prep_layout_x (z
);
834 /******************************************************************************/
836 SCM_SYMBOL (sym_layout
, "layout");
837 SCM_SYMBOL (sym_flags
, "flags");
838 SCM_SYMBOL (sym_self
, "%self");
839 SCM_SYMBOL (sym_instance_finalizer
, "instance-finalizer");
840 SCM_SYMBOL (sym_reserved_0
, "%reserved-0");
841 SCM_SYMBOL (sym_reserved_1
, "%reserved-1");
842 SCM_SYMBOL (sym_print
, "print");
843 SCM_SYMBOL (sym_procedure
, "procedure");
844 SCM_SYMBOL (sym_setter
, "setter");
845 SCM_SYMBOL (sym_redefined
, "redefined");
846 SCM_SYMBOL (sym_h0
, "h0");
847 SCM_SYMBOL (sym_h1
, "h1");
848 SCM_SYMBOL (sym_h2
, "h2");
849 SCM_SYMBOL (sym_h3
, "h3");
850 SCM_SYMBOL (sym_h4
, "h4");
851 SCM_SYMBOL (sym_h5
, "h5");
852 SCM_SYMBOL (sym_h6
, "h6");
853 SCM_SYMBOL (sym_h7
, "h7");
854 SCM_SYMBOL (sym_name
, "name");
855 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
856 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
857 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
858 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
859 SCM_SYMBOL (sym_cpl
, "cpl");
860 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
861 SCM_SYMBOL (sym_slots
, "slots");
862 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
863 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
864 SCM_SYMBOL (sym_nfields
, "nfields");
865 SCM_SYMBOL (sym_environment
, "environment");
869 build_class_class_slots ()
871 /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
872 SCM_CLASS_CLASS_LAYOUT */
874 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
875 scm_list_3 (sym_flags
, k_class
, scm_class_hidden
),
876 scm_list_3 (sym_self
, k_class
, scm_class_self
),
877 scm_list_3 (sym_instance_finalizer
, k_class
, scm_class_hidden
),
878 scm_list_1 (sym_print
),
879 scm_list_3 (sym_name
, k_class
, scm_class_protected_hidden
),
880 scm_list_3 (sym_reserved_0
, k_class
, scm_class_hidden
),
881 scm_list_3 (sym_reserved_1
, k_class
, scm_class_hidden
),
882 scm_list_1 (sym_redefined
),
883 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
884 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
885 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
886 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
887 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
888 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
889 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
890 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
891 scm_list_1 (sym_direct_supers
),
892 scm_list_1 (sym_direct_slots
),
893 scm_list_1 (sym_direct_subclasses
),
894 scm_list_1 (sym_direct_methods
),
895 scm_list_1 (sym_cpl
),
896 scm_list_1 (sym_default_slot_definition_class
),
897 scm_list_1 (sym_slots
),
898 scm_list_1 (sym_getters_n_setters
),
899 scm_list_1 (sym_keyword_access
),
900 scm_list_1 (sym_nfields
),
901 scm_list_1 (sym_environment
),
906 create_basic_classes (void)
908 /* SCM slots_of_class = build_class_class_slots (); */
911 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
912 SCM name
= scm_from_locale_symbol ("<class>");
913 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
916 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
917 | SCM_CLASSF_METACLASS
));
919 SCM_SET_SLOT (scm_class_class
, scm_vtable_index_name
, name
);
920 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
921 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
922 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
923 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
924 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
925 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
926 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
927 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
928 compute_getters_n_setters (slots_of_class)); */
929 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
930 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
931 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
933 prep_hashsets (scm_class_class
);
935 DEFVAR(name
, scm_class_class
);
937 /**** <scm_class_top> ****/
938 name
= scm_from_locale_symbol ("<top>");
939 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
944 DEFVAR(name
, scm_class_top
);
946 /**** <scm_class_object> ****/
947 name
= scm_from_locale_symbol ("<object>");
948 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
950 scm_list_1 (scm_class_top
),
953 DEFVAR (name
, scm_class_object
);
955 /* <top> <object> and <class> were partially initialized. Correct them here */
956 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
958 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
959 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
962 /******************************************************************************/
964 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
966 "Return @code{#t} if @var{obj} is an instance.")
967 #define FUNC_NAME s_scm_instance_p
969 return scm_from_bool (SCM_INSTANCEP (obj
));
974 /******************************************************************************
976 * Meta object accessors
978 ******************************************************************************/
979 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
981 "Return the class name of @var{obj}.")
982 #define FUNC_NAME s_scm_class_name
984 SCM_VALIDATE_CLASS (1, obj
);
985 return scm_slot_ref (obj
, sym_name
);
989 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
991 "Return the direct superclasses of the class @var{obj}.")
992 #define FUNC_NAME s_scm_class_direct_supers
994 SCM_VALIDATE_CLASS (1, obj
);
995 return scm_slot_ref (obj
, sym_direct_supers
);
999 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1001 "Return the direct slots of the class @var{obj}.")
1002 #define FUNC_NAME s_scm_class_direct_slots
1004 SCM_VALIDATE_CLASS (1, obj
);
1005 return scm_slot_ref (obj
, sym_direct_slots
);
1009 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1011 "Return the direct subclasses of the class @var{obj}.")
1012 #define FUNC_NAME s_scm_class_direct_subclasses
1014 SCM_VALIDATE_CLASS (1, obj
);
1015 return scm_slot_ref(obj
, sym_direct_subclasses
);
1019 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1021 "Return the direct methods of the class @var{obj}")
1022 #define FUNC_NAME s_scm_class_direct_methods
1024 SCM_VALIDATE_CLASS (1, obj
);
1025 return scm_slot_ref (obj
, sym_direct_methods
);
1029 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1031 "Return the class precedence list of the class @var{obj}.")
1032 #define FUNC_NAME s_scm_class_precedence_list
1034 SCM_VALIDATE_CLASS (1, obj
);
1035 return scm_slot_ref (obj
, sym_cpl
);
1039 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1041 "Return the slot list of the class @var{obj}.")
1042 #define FUNC_NAME s_scm_class_slots
1044 SCM_VALIDATE_CLASS (1, obj
);
1045 return scm_slot_ref (obj
, sym_slots
);
1049 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1051 "Return the environment of the class @var{obj}.")
1052 #define FUNC_NAME s_scm_class_environment
1054 SCM_VALIDATE_CLASS (1, obj
);
1055 return scm_slot_ref(obj
, sym_environment
);
1060 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1062 "Return the name of the generic function @var{obj}.")
1063 #define FUNC_NAME s_scm_generic_function_name
1065 SCM_VALIDATE_GENERIC (1, obj
);
1066 return scm_procedure_property (obj
, scm_sym_name
);
1070 SCM_SYMBOL (sym_methods
, "methods");
1071 SCM_SYMBOL (sym_extended_by
, "extended-by");
1072 SCM_SYMBOL (sym_extends
, "extends");
1075 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1077 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1078 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1079 while (!scm_is_null (gfs
))
1081 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1082 gfs
= SCM_CDR (gfs
);
1084 return method_lists
;
1088 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1090 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1092 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1093 while (!scm_is_null (gfs
))
1095 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1096 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1099 gfs
= SCM_CDR (gfs
);
1102 return method_lists
;
1105 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1107 "Return the methods of the generic function @var{obj}.")
1108 #define FUNC_NAME s_scm_generic_function_methods
1111 SCM_VALIDATE_GENERIC (1, obj
);
1112 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1113 methods
= fold_downward_gf_methods (methods
, obj
);
1114 return scm_append (methods
);
1118 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1120 "Return the generic function for the method @var{obj}.")
1121 #define FUNC_NAME s_scm_method_generic_function
1123 SCM_VALIDATE_METHOD (1, obj
);
1124 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1128 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1130 "Return specializers of the method @var{obj}.")
1131 #define FUNC_NAME s_scm_method_specializers
1133 SCM_VALIDATE_METHOD (1, obj
);
1134 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1138 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1140 "Return the procedure of the method @var{obj}.")
1141 #define FUNC_NAME s_scm_method_procedure
1143 SCM_VALIDATE_METHOD (1, obj
);
1144 return scm_slot_ref (obj
, sym_procedure
);
1148 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1150 "Return the slot definition of the accessor @var{obj}.")
1151 #define FUNC_NAME s_scm_accessor_method_slot_definition
1153 SCM_VALIDATE_ACCESSOR (1, obj
);
1154 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
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 scm_call_1 (SCM_VARIABLE_REF (var_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 scm_call_1 (SCM_VARIABLE_REF (var_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,
1216 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1219 return SCM_SLOT (obj
, i
);
1223 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1224 (SCM obj
, SCM index
, SCM value
),
1225 "Set the slot with index @var{index} in @var{obj} to\n"
1227 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1229 unsigned long int i
;
1231 SCM_VALIDATE_INSTANCE (1, obj
);
1232 i
= scm_to_unsigned_integer (index
, 0,
1233 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1237 SCM_SET_SLOT (obj
, i
, value
);
1239 return SCM_UNSPECIFIED
;
1247 /* In the future, this function will return the effective slot
1248 * definition associated with SLOT_NAME. Now it just returns some of
1249 * the information which will be stored in the effective slot
1254 slot_definition_using_name (SCM
class, SCM slot_name
)
1256 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1257 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1258 if (SCM_CAAR (slots
) == slot_name
)
1259 return SCM_CAR (slots
);
1264 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1265 #define FUNC_NAME "%get-slot-value"
1267 SCM access
= SCM_CDDR (slotdef
);
1269 * - access is an integer (the offset of this slot in the slots vector)
1270 * - otherwise (car access) is the getter function to apply
1272 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1273 * we can just assume fixnums here.
1275 if (SCM_I_INUMP (access
))
1276 /* Don't poke at the slots directly, because scm_struct_ref handles the
1277 access bits for us. */
1278 return scm_struct_ref (obj
, access
);
1281 /* We must evaluate (apply (car access) (list obj))
1282 * where (car access) is known to be a closure of arity 1 */
1283 register SCM code
, env
;
1285 code
= SCM_CAR (access
);
1286 if (!SCM_CLOSUREP (code
))
1287 return scm_call_1 (code
, obj
);
1288 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1291 /* Evaluate the closure body */
1292 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1298 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1300 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1301 if (scm_is_true (slotdef
))
1302 return get_slot_value (class, obj
, slotdef
);
1304 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1308 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1309 #define FUNC_NAME "%set-slot-value"
1311 SCM access
= SCM_CDDR (slotdef
);
1313 * - access is an integer (the offset of this slot in the slots vector)
1314 * - otherwise (cadr access) is the setter function to apply
1316 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1317 * we can just assume fixnums here.
1319 if (SCM_I_INUMP (access
))
1320 /* obey permissions bits via going through struct-set! */
1321 scm_struct_set_x (obj
, access
, value
);
1324 /* We must evaluate (apply (cadr l) (list obj value))
1325 * where (cadr l) is known to be a closure of arity 2 */
1326 register SCM code
, env
;
1328 code
= SCM_CADR (access
);
1329 if (!SCM_CLOSUREP (code
))
1330 scm_call_2 (code
, obj
, value
);
1333 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1334 scm_list_2 (obj
, value
),
1336 /* Evaluate the closure body */
1337 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1340 return SCM_UNSPECIFIED
;
1345 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1347 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1348 if (scm_is_true (slotdef
))
1349 return set_slot_value (class, obj
, slotdef
, value
);
1351 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1355 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1359 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1360 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1366 /* ======================================== */
1368 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1369 (SCM
class, SCM obj
, SCM slot_name
),
1371 #define FUNC_NAME s_scm_slot_ref_using_class
1375 SCM_VALIDATE_CLASS (1, class);
1376 SCM_VALIDATE_INSTANCE (2, obj
);
1377 SCM_VALIDATE_SYMBOL (3, slot_name
);
1379 res
= get_slot_value_using_name (class, obj
, slot_name
);
1380 if (SCM_GOOPS_UNBOUNDP (res
))
1381 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1387 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1388 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1390 #define FUNC_NAME s_scm_slot_set_using_class_x
1392 SCM_VALIDATE_CLASS (1, class);
1393 SCM_VALIDATE_INSTANCE (2, obj
);
1394 SCM_VALIDATE_SYMBOL (3, slot_name
);
1396 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1401 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1402 (SCM
class, SCM obj
, SCM slot_name
),
1404 #define FUNC_NAME s_scm_slot_bound_using_class_p
1406 SCM_VALIDATE_CLASS (1, class);
1407 SCM_VALIDATE_INSTANCE (2, obj
);
1408 SCM_VALIDATE_SYMBOL (3, slot_name
);
1410 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1416 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1417 (SCM
class, SCM obj
, SCM slot_name
),
1419 #define FUNC_NAME s_scm_slot_exists_using_class_p
1421 SCM_VALIDATE_CLASS (1, class);
1422 SCM_VALIDATE_INSTANCE (2, obj
);
1423 SCM_VALIDATE_SYMBOL (3, slot_name
);
1424 return test_slot_existence (class, obj
, slot_name
);
1429 /* ======================================== */
1431 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1432 (SCM obj
, SCM slot_name
),
1433 "Return the value from @var{obj}'s slot with the name\n"
1435 #define FUNC_NAME s_scm_slot_ref
1439 SCM_VALIDATE_INSTANCE (1, obj
);
1440 TEST_CHANGE_CLASS (obj
, class);
1442 res
= get_slot_value_using_name (class, obj
, slot_name
);
1443 if (SCM_GOOPS_UNBOUNDP (res
))
1444 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1449 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1450 (SCM obj
, SCM slot_name
, SCM value
),
1451 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1452 #define FUNC_NAME s_scm_slot_set_x
1456 SCM_VALIDATE_INSTANCE (1, obj
);
1457 TEST_CHANGE_CLASS(obj
, class);
1459 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1463 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1465 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1466 (SCM obj
, SCM slot_name
),
1467 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1469 #define FUNC_NAME s_scm_slot_bound_p
1473 SCM_VALIDATE_INSTANCE (1, obj
);
1474 TEST_CHANGE_CLASS(obj
, class);
1476 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1484 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1485 (SCM obj
, SCM slot_name
),
1486 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1487 #define FUNC_NAME s_scm_slot_exists_p
1491 SCM_VALIDATE_INSTANCE (1, obj
);
1492 SCM_VALIDATE_SYMBOL (2, slot_name
);
1493 TEST_CHANGE_CLASS (obj
, class);
1495 return test_slot_existence (class, obj
, slot_name
);
1500 /******************************************************************************
1502 * %allocate-instance (the low level instance allocation primitive)
1504 ******************************************************************************/
1506 static void clear_method_cache (SCM
);
1509 goops_finalizer_trampoline (GC_PTR ptr
, GC_PTR unused_data
)
1511 SCM obj
= PTR2SCM (ptr
);
1512 scm_t_struct_finalize finalize
= SCM_STRUCT_FINALIZER (obj
);
1517 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1518 (SCM
class, SCM initargs
),
1519 "Create a new instance of class @var{class} and initialize it\n"
1520 "from the arguments @var{initargs}.")
1521 #define FUNC_NAME s_scm_sys_allocate_instance
1528 SCM_VALIDATE_CLASS (1, class);
1530 /* FIXME: duplicates some of scm_make_struct. */
1532 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1533 obj
= scm_alloc_struct (SCM_STRUCT_DATA (class), n
, "struct");
1535 layout
= SCM_VTABLE_LAYOUT (class);
1537 /* Set all SCM-holding slots to unbound */
1538 for (i
= 0; i
< n
; i
++)
1539 { scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1541 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1543 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1545 SCM_STRUCT_DATA (obj
)[i
] = 0;
1548 if (SCM_VTABLE_INSTANCE_FINALIZER (class))
1550 /* Register a finalizer for the newly created instance. */
1551 GC_finalization_proc prev_finalizer
;
1552 GC_PTR prev_finalizer_data
;
1553 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj
),
1554 goops_finalizer_trampoline
,
1557 &prev_finalizer_data
);
1560 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1561 clear_method_cache (obj
);
1564 /* if ((SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
1565 && (SCM_SUBCLASSP (class, scm_class_entity_class)))
1566 SCM_SET_CLASS_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE); */
1572 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1573 (SCM obj
, SCM setter
),
1575 #define FUNC_NAME s_scm_sys_set_object_setter_x
1577 SCM_ASSERT (SCM_STRUCTP (obj
)
1578 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1582 SCM_SET_GENERIC_SETTER (obj
, setter
);
1583 return SCM_UNSPECIFIED
;
1587 /******************************************************************************
1589 * %modify-instance (used by change-class to modify in place)
1591 ******************************************************************************/
1593 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1596 #define FUNC_NAME s_scm_sys_modify_instance
1598 SCM_VALIDATE_INSTANCE (1, old
);
1599 SCM_VALIDATE_INSTANCE (2, new);
1601 /* Exchange the data contained in old and new. We exchange rather than
1602 * scratch the old value with new to be correct with GC.
1603 * See "Class redefinition protocol above".
1605 SCM_CRITICAL_SECTION_START
;
1607 scm_t_bits word0
, word1
;
1608 word0
= SCM_CELL_WORD_0 (old
);
1609 word1
= SCM_CELL_WORD_1 (old
);
1610 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1611 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1612 SCM_SET_CELL_WORD_0 (new, word0
);
1613 SCM_SET_CELL_WORD_1 (new, word1
);
1615 SCM_CRITICAL_SECTION_END
;
1616 return SCM_UNSPECIFIED
;
1620 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1623 #define FUNC_NAME s_scm_sys_modify_class
1625 SCM_VALIDATE_CLASS (1, old
);
1626 SCM_VALIDATE_CLASS (2, new);
1628 SCM_CRITICAL_SECTION_START
;
1630 scm_t_bits word0
, word1
;
1631 word0
= SCM_CELL_WORD_0 (old
);
1632 word1
= SCM_CELL_WORD_1 (old
);
1633 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1634 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1635 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1636 SCM_SET_CELL_WORD_0 (new, word0
);
1637 SCM_SET_CELL_WORD_1 (new, word1
);
1638 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1640 SCM_CRITICAL_SECTION_END
;
1641 return SCM_UNSPECIFIED
;
1645 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1648 #define FUNC_NAME s_scm_sys_invalidate_class
1650 SCM_VALIDATE_CLASS (1, class);
1651 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1652 return SCM_UNSPECIFIED
;
1656 /* When instances change class, they finally get a new body, but
1657 * before that, they go through purgatory in hell. Odd as it may
1658 * seem, this data structure saves us from eternal suffering in
1659 * infinite recursions.
1662 static scm_t_bits
**hell
;
1663 static long n_hell
= 1; /* one place for the evil one himself */
1664 static long hell_size
= 4;
1665 static SCM hell_mutex
;
1671 for (i
= 1; i
< n_hell
; ++i
)
1672 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1678 go_to_hell (void *o
)
1680 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1681 scm_lock_mutex (hell_mutex
);
1682 if (n_hell
>= hell_size
)
1685 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1687 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1688 scm_unlock_mutex (hell_mutex
);
1692 go_to_heaven (void *o
)
1694 scm_lock_mutex (hell_mutex
);
1695 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1696 scm_unlock_mutex (hell_mutex
);
1700 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1703 purgatory (void *args
)
1705 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1706 SCM_PACK ((scm_t_bits
) args
));
1709 /* This function calls the generic function change-class for all
1710 * instances which aren't currently undergoing class change.
1714 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1717 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1718 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1719 (void *) SCM_UNPACK (obj
));
1722 /******************************************************************************
1728 * GGG E N E R I C F U N C T I O N S
1730 * This implementation provides
1731 * - generic functions (with class specializers)
1734 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1736 ******************************************************************************/
1738 SCM_KEYWORD (k_name
, "name");
1740 SCM_SYMBOL (sym_no_method
, "no-method");
1742 static SCM list_of_no_method
;
1744 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1747 /* The cache argument for scm_mcache_lookup_cmethod has one of two possible
1751 * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
1752 * #((TYPE1 ... . CMETHOD) ...)
1756 * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
1757 * #((TYPE1 ... CMETHOD) ...)
1760 * ARGS is either a list of expressions, in which case they
1761 * are interpreted as the arguments of an application, or
1762 * a non-pair, which is interpreted as a single expression
1763 * yielding all arguments.
1765 * SCM_IM_DISPATCH expressions in generic functions always
1766 * have ARGS = the symbol `args' or the iloc #@0-0.
1768 * We should probably not complicate this mechanism by
1769 * introducing "optimizations" for getters and setters or
1770 * primitive methods. Getters and setter will normally be
1771 * compiled into @slot-[ref|set!] or a procedure call.
1772 * They rely on the dispatch performed before executing
1773 * the code which contains them.
1775 * We might want to use a more efficient representation of
1776 * this form in the future, perhaps after we have introduced
1777 * low-level support for syntax-case macros.
1781 scm_mcache_lookup_cmethod (SCM cache
, SCM args
)
1783 unsigned long i
, mask
, n
, end
;
1784 SCM ls
, methods
, z
= SCM_CDDR (cache
);
1785 n
= scm_to_ulong (SCM_CAR (z
)); /* maximum number of specializers */
1786 methods
= SCM_CADR (z
);
1788 if (scm_is_simple_vector (methods
))
1790 /* cache format #1: prepare for linear search */
1793 end
= SCM_SIMPLE_VECTOR_LENGTH (methods
);
1797 /* cache format #2: compute a hash value */
1798 unsigned long hashset
= scm_to_ulong (methods
);
1801 mask
= scm_to_ulong (SCM_CAR (z
));
1802 methods
= SCM_CADR (z
);
1805 if (!scm_is_null (ls
))
1808 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls
)))
1809 [scm_si_hashsets
+ hashset
];
1812 while (j
-- && !scm_is_null (ls
));
1817 /* Search for match */
1821 z
= SCM_SIMPLE_VECTOR_REF (methods
, i
);
1822 ls
= args
; /* list of arguments */
1823 /* More arguments than specifiers => z = CMETHOD, not a pair.
1824 * Fewer arguments than specifiers => CAR != CLASS or `no-method'. */
1825 if (!scm_is_null (ls
) && scm_is_pair (z
))
1828 if (! scm_is_eq (scm_class_of (SCM_CAR (ls
)), SCM_CAR (z
)))
1833 while (j
-- && !scm_is_null (ls
) && scm_is_pair (z
));
1834 if (!scm_is_pair (z
))
1843 scm_mcache_compute_cmethod (SCM cache
, SCM args
)
1845 SCM cmethod
= scm_mcache_lookup_cmethod (cache
, args
);
1846 if (scm_is_false (cmethod
))
1847 /* No match - memoize */
1848 return scm_memoize_method (cache
, args
);
1853 scm_apply_generic (SCM gf
, SCM args
)
1855 SCM cmethod
= scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf
), args
);
1856 if (SCM_PROGRAM_P (cmethod
))
1857 return scm_vm_apply (scm_the_vm (), cmethod
, args
);
1858 else if (scm_is_pair (cmethod
))
1859 return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod
)),
1860 SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod
)),
1862 SCM_CMETHOD_ENV (cmethod
)));
1864 return scm_apply (cmethod
, args
, SCM_EOL
);
1868 scm_call_generic_0 (SCM gf
)
1870 return scm_apply_generic (gf
, SCM_EOL
);
1874 scm_call_generic_1 (SCM gf
, SCM a1
)
1876 return scm_apply_generic (gf
, scm_list_1 (a1
));
1880 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1882 return scm_apply_generic (gf
, scm_list_2 (a1
, a2
));
1886 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1888 return scm_apply_generic (gf
, scm_list_3 (a1
, a2
, a3
));
1892 scm_make_method_cache (SCM gf
)
1894 return scm_list_5 (SCM_IM_DISPATCH
,
1897 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1903 clear_method_cache (SCM gf
)
1905 SCM cache
= scm_make_method_cache (gf
);
1906 SCM_SET_GENERIC_METHOD_CACHE (gf
, cache
);
1907 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, SCM_BOOL_F
);
1908 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1911 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1914 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1916 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1917 clear_method_cache (gf
);
1918 /* The sign of n-specialized is a flag indicating rest args. */
1919 SCM_SET_MCACHE_N_SPECIALIZED (SCM_GENERIC_METHOD_CACHE (gf
),
1920 SCM_SLOT (gf
, scm_si_n_specialized
));
1921 return SCM_UNSPECIFIED
;
1925 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1928 #define FUNC_NAME s_scm_generic_capability_p
1930 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1931 proc
, SCM_ARG1
, FUNC_NAME
);
1932 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1938 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1941 #define FUNC_NAME s_scm_enable_primitive_generic_x
1943 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1944 while (!scm_is_null (subrs
))
1946 SCM subr
= SCM_CAR (subrs
);
1947 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1948 subr
, SCM_ARGn
, FUNC_NAME
);
1949 *SCM_SUBR_GENERIC (subr
)
1950 = scm_make (scm_list_3 (scm_class_generic
,
1952 SCM_SUBR_NAME (subr
)));
1953 subrs
= SCM_CDR (subrs
);
1955 return SCM_UNSPECIFIED
;
1959 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1962 #define FUNC_NAME s_scm_primitive_generic_generic
1964 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
1966 if (!*SCM_SUBR_GENERIC (subr
))
1967 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1968 return *SCM_SUBR_GENERIC (subr
);
1970 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1974 typedef struct t_extension
{
1975 struct t_extension
*next
;
1981 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1983 static const char extension_gc_hint
[] = "GOOPS extension";
1985 static t_extension
*extensions
= 0;
1987 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
1990 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1995 if (!*SCM_SUBR_GENERIC (extended
))
1996 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1997 gf
= *SCM_SUBR_GENERIC (extended
);
1998 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
2000 SCM_SUBR_NAME (extension
));
2001 SCM_SET_SUBR_GENERIC (extension
, gext
);
2005 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
2007 t_extension
**loc
= &extensions
;
2008 /* Make sure that extensions are placed before their own
2009 * extensions in the extensions list. O(N^2) algorithm, but
2010 * extensions of primitive generics are rare.
2012 while (*loc
&& extension
!= (*loc
)->extended
)
2013 loc
= &(*loc
)->next
;
2015 e
->extended
= extended
;
2016 e
->extension
= extension
;
2022 setup_extended_primitive_generics ()
2026 t_extension
*e
= extensions
;
2027 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
2028 extensions
= e
->next
;
2032 /******************************************************************************
2034 * Protocol for calling a generic fumction
2035 * This protocol is roughly equivalent to (parameter are a little bit different
2036 * for efficiency reasons):
2038 * + apply-generic (gf args)
2039 * + compute-applicable-methods (gf args ...)
2040 * + sort-applicable-methods (methods args)
2041 * + apply-methods (gf methods args)
2043 * apply-methods calls make-next-method to build the "continuation" of a a
2044 * method. Applying a next-method will call apply-next-method which in
2045 * turn will call apply again to call effectively the following method.
2047 ******************************************************************************/
2050 applicablep (SCM actual
, SCM formal
)
2052 /* We already know that the cpl is well formed. */
2053 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
2057 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
2059 register SCM s1
, s2
;
2063 * m1 and m2 can have != length (i.e. one can be one element longer than the
2064 * other when we have a dotted parameter list). For instance, with the call
2067 * (define-method M (a . l) ....)
2068 * (define-method M (a) ....)
2070 * we consider that the second method is more specific.
2072 * BTW, targs is an array of types. We don't need it's size since
2073 * we already know that m1 and m2 are applicable (no risk to go past
2074 * the end of this array).
2077 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
2078 if (scm_is_null(s1
)) return 1;
2079 if (scm_is_null(s2
)) return 0;
2080 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
2081 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
2083 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
2084 if (cs1
== SCM_CAR(l
))
2086 if (cs2
== SCM_CAR(l
))
2089 return 0;/* should not occur! */
2092 return 0; /* should not occur! */
2095 #define BUFFSIZE 32 /* big enough for most uses */
2098 scm_i_vector2list (SCM l
, long len
)
2101 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2103 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
2104 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2110 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2113 SCM
*v
, vector
= SCM_EOL
;
2114 SCM buffer
[BUFFSIZE
];
2115 SCM save
= method_list
;
2116 scm_t_array_handle handle
;
2118 /* For reasonably sized method_lists we can try to avoid all the
2119 * consing and reorder the list in place...
2120 * This idea is due to David McClain <Dave_McClain@msn.com>
2122 if (size
<= BUFFSIZE
)
2124 for (i
= 0; i
< size
; i
++)
2126 buffer
[i
] = SCM_CAR (method_list
);
2127 method_list
= SCM_CDR (method_list
);
2133 /* Too many elements in method_list to keep everything locally */
2134 vector
= scm_i_vector2list (save
, size
);
2135 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2138 /* Use a simple shell sort since it is generally faster than qsort on
2139 * small vectors (which is probably mostly the case when we have to
2140 * sort a list of applicable methods).
2142 for (incr
= size
/ 2; incr
; incr
/= 2)
2144 for (i
= incr
; i
< size
; i
++)
2146 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2148 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2152 SCM tmp
= v
[j
+ incr
];
2160 if (size
<= BUFFSIZE
)
2162 /* We did it in locally, so restore the original list (reordered) in-place */
2163 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2165 SCM_SETCAR (method_list
, *v
);
2166 method_list
= SCM_CDR (method_list
);
2171 /* If we are here, that's that we did it the hard way... */
2172 scm_array_handle_release (&handle
);
2173 return scm_vector_to_list (vector
);
2177 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2181 SCM l
, fl
, applicable
= SCM_EOL
;
2183 SCM buffer
[BUFFSIZE
];
2187 scm_t_array_handle handle
;
2189 /* Build the list of arguments types */
2190 if (len
>= BUFFSIZE
)
2192 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2193 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2196 note that we don't have to work to reset the generation
2197 count. TMP is a new vector anyway, and it is found
2204 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2205 *p
++ = scm_class_of (SCM_CAR (args
));
2207 /* Build a list of all applicable methods */
2208 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2210 fl
= SPEC_OF (SCM_CAR (l
));
2211 /* Only accept accessors which match exactly in first arg. */
2212 if (SCM_ACCESSORP (SCM_CAR (l
))
2213 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2215 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2217 if (SCM_INSTANCEP (fl
)
2218 /* We have a dotted argument list */
2219 || (i
>= len
&& scm_is_null (fl
)))
2220 { /* both list exhausted */
2221 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2227 || !applicablep (types
[i
], SCM_CAR (fl
)))
2232 if (len
>= BUFFSIZE
)
2233 scm_array_handle_release (&handle
);
2239 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2240 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2246 : sort_applicable_methods (applicable
, count
, types
));
2250 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2253 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2256 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2257 #define FUNC_NAME s_sys_compute_applicable_methods
2260 SCM_VALIDATE_GENERIC (1, gf
);
2261 n
= scm_ilength (args
);
2262 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2263 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2267 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2268 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
));
2271 lock_cache_mutex (void *m
)
2273 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2274 scm_lock_mutex (mutex
);
2278 unlock_cache_mutex (void *m
)
2280 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2281 scm_unlock_mutex (mutex
);
2285 call_memoize_method (void *a
)
2287 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2288 SCM gf
= SCM_CAR (args
);
2289 SCM x
= SCM_CADR (args
);
2290 /* First check if another thread has inserted a method between
2291 * the cache miss and locking the mutex.
2293 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2294 if (scm_is_true (cmethod
))
2297 if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x
)))
2298 var_memoize_method_x
=
2299 scm_permanent_object
2300 (scm_module_variable (scm_module_goops
, sym_memoize_method_x
));
2302 return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x
), gf
, SCM_CDDR (args
), x
);
2306 scm_memoize_method (SCM x
, SCM args
)
2308 SCM gf
= SCM_CAR (scm_last_pair (x
));
2309 return scm_internal_dynamic_wind (
2311 call_memoize_method
,
2313 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2314 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2317 /******************************************************************************
2319 * A simple make (which will be redefined later in Scheme)
2320 * This version handles only creation of gf, methods and classes (no instances)
2322 * Since this code will disappear when Goops will be fully booted,
2323 * no precaution is taken to be efficient.
2325 ******************************************************************************/
2327 SCM_KEYWORD (k_setter
, "setter");
2328 SCM_KEYWORD (k_specializers
, "specializers");
2329 SCM_KEYWORD (k_procedure
, "procedure");
2330 SCM_KEYWORD (k_formals
, "formals");
2331 SCM_KEYWORD (k_body
, "body");
2332 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2333 SCM_KEYWORD (k_dsupers
, "dsupers");
2334 SCM_KEYWORD (k_slots
, "slots");
2335 SCM_KEYWORD (k_gf
, "generic-function");
2337 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2339 "Make a new object. @var{args} must contain the class and\n"
2340 "all necessary initialization information.")
2341 #define FUNC_NAME s_scm_make
2344 long len
= scm_ilength (args
);
2346 if (len
<= 0 || (len
& 1) == 0)
2347 SCM_WRONG_NUM_ARGS ();
2349 class = SCM_CAR(args
);
2350 args
= SCM_CDR(args
);
2352 if (class == scm_class_generic
|| class == scm_class_accessor
)
2354 z
= scm_make_struct (class, SCM_INUM0
,
2355 scm_list_4 (SCM_EOL
,
2359 scm_set_procedure_property_x (z
, scm_sym_name
,
2360 scm_get_keyword (k_name
,
2363 clear_method_cache (z
);
2364 if (class == scm_class_accessor
)
2366 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2367 if (scm_is_true (setter
))
2368 scm_sys_set_object_setter_x (z
, setter
);
2373 z
= scm_sys_allocate_instance (class, args
);
2375 if (class == scm_class_method
2376 || class == scm_class_simple_method
2377 || class == scm_class_accessor_method
)
2379 SCM_SET_SLOT (z
, scm_si_generic_function
,
2380 scm_i_get_keyword (k_gf
,
2385 SCM_SET_SLOT (z
, scm_si_specializers
,
2386 scm_i_get_keyword (k_specializers
,
2391 SCM_SET_SLOT (z
, scm_si_procedure
,
2392 scm_i_get_keyword (k_procedure
,
2397 SCM_SET_SLOT (z
, scm_si_formals
,
2398 scm_i_get_keyword (k_formals
,
2403 SCM_SET_SLOT (z
, scm_si_body
,
2404 scm_i_get_keyword (k_body
,
2409 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2410 scm_i_get_keyword (k_make_procedure
,
2418 /* In all the others case, make a new class .... No instance here */
2419 SCM_SET_SLOT (z
, scm_vtable_index_name
,
2420 scm_i_get_keyword (k_name
,
2423 scm_from_locale_symbol ("???"),
2425 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2426 scm_i_get_keyword (k_dsupers
,
2431 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2432 scm_i_get_keyword (k_slots
,
2443 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2446 #define FUNC_NAME s_scm_find_method
2449 long len
= scm_ilength (l
);
2452 SCM_WRONG_NUM_ARGS ();
2454 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2455 SCM_VALIDATE_GENERIC (1, gf
);
2456 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2457 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2459 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2463 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2464 (SCM m1
, SCM m2
, SCM targs
),
2465 "Return true if method @var{m1} is more specific than @var{m2} "
2466 "given the argument types (classes) listed in @var{targs}.")
2467 #define FUNC_NAME s_scm_sys_method_more_specific_p
2471 long i
, len
, m1_specs
, m2_specs
;
2472 scm_t_array_handle handle
;
2474 SCM_VALIDATE_METHOD (1, m1
);
2475 SCM_VALIDATE_METHOD (2, m2
);
2477 len
= scm_ilength (targs
);
2478 m1_specs
= scm_ilength (SPEC_OF (m1
));
2479 m2_specs
= scm_ilength (SPEC_OF (m2
));
2480 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2481 targs
, SCM_ARG3
, FUNC_NAME
);
2483 /* Verify that all the arguments of TARGS are classes and place them
2486 v
= scm_c_make_vector (len
, SCM_EOL
);
2487 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2489 for (i
= 0, l
= targs
;
2490 i
< len
&& scm_is_pair (l
);
2491 i
++, l
= SCM_CDR (l
))
2493 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2494 v_elts
[i
] = SCM_CAR (l
);
2496 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2498 scm_array_handle_release (&handle
);
2506 /******************************************************************************
2510 ******************************************************************************/
2513 fix_cpl (SCM c
, SCM before
, SCM after
)
2515 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2516 SCM ls
= scm_c_memq (after
, cpl
);
2517 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2518 if (scm_is_false (ls
))
2519 /* if this condition occurs, fix_cpl should not be applied this way */
2521 SCM_SETCAR (ls
, before
);
2522 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2524 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2525 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2526 SCM g_n_s
= compute_getters_n_setters (slots
);
2527 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2528 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2534 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2536 SCM tmp
= scm_from_locale_symbol (name
);
2538 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2542 : scm_list_1 (super
),
2548 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2551 create_standard_classes (void)
2554 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2555 scm_from_locale_symbol ("specializers"),
2557 scm_from_locale_symbol ("formals"),
2558 scm_from_locale_symbol ("body"),
2559 scm_from_locale_symbol ("make-procedure"),
2561 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2563 k_slot_definition
));
2564 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2565 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2569 SCM gf_slots
= scm_list_n (scm_from_locale_symbol ("methods"),
2570 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2573 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2576 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2579 scm_from_locale_symbol ("%cache"),
2580 scm_from_locale_symbol ("dispatch-procedure"),
2581 scm_from_locale_symbol ("effective-methods"),
2583 SCM setter_slots
= scm_list_1 (sym_setter
);
2584 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2587 /* Foreign class slot classes */
2588 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2589 scm_class_class
, scm_class_top
, SCM_EOL
);
2590 make_stdcls (&scm_class_protected
, "<protected-slot>",
2591 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2592 make_stdcls (&scm_class_hidden
, "<hidden-slot>",
2593 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2594 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2595 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2596 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2597 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2598 make_stdcls (&scm_class_self
, "<self-slot>",
2599 scm_class_class
, scm_class_read_only
, SCM_EOL
);
2600 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2602 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2604 make_stdcls (&scm_class_protected_hidden
, "<protected-hidden-slot>",
2606 scm_list_2 (scm_class_protected
, scm_class_hidden
),
2608 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2610 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2612 make_stdcls (&scm_class_scm
, "<scm-slot>",
2613 scm_class_class
, scm_class_protected
, SCM_EOL
);
2614 make_stdcls (&scm_class_int
, "<int-slot>",
2615 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2616 make_stdcls (&scm_class_float
, "<float-slot>",
2617 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2618 make_stdcls (&scm_class_double
, "<double-slot>",
2619 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2621 /* Continue initialization of class <class> */
2623 slots
= build_class_class_slots ();
2624 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2625 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2626 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2627 compute_getters_n_setters (slots
));
2629 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2630 scm_class_class
, scm_class_class
,
2631 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2634 scm_list_3 (scm_from_locale_symbol ("destructor"),
2636 scm_class_opaque
)));
2637 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2638 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2639 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2641 /* scm_class_generic functions classes */
2642 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2643 scm_class_class
, scm_class_class
, SCM_EOL
);
2644 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2645 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2646 make_stdcls (&scm_class_method
, "<method>",
2647 scm_class_class
, scm_class_object
, method_slots
);
2648 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2649 scm_class_class
, scm_class_method
, SCM_EOL
);
2650 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2651 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2652 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2653 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2654 make_stdcls (&scm_class_applicable
, "<applicable>",
2655 scm_class_class
, scm_class_top
, SCM_EOL
);
2656 make_stdcls (&scm_class_entity
, "<entity>",
2657 scm_class_entity_class
,
2658 scm_list_2 (scm_class_object
, scm_class_applicable
),
2660 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2661 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2662 make_stdcls (&scm_class_generic
, "<generic>",
2663 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2664 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2665 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2666 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2667 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2668 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2669 scm_class_entity_class
,
2670 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2672 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2673 make_stdcls (&scm_class_accessor
, "<accessor>",
2674 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2675 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2676 make_stdcls (&scm_class_extended_generic_with_setter
,
2677 "<extended-generic-with-setter>",
2678 scm_class_entity_class
,
2679 scm_list_2 (scm_class_generic_with_setter
,
2680 scm_class_extended_generic
),
2682 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2683 SCM_CLASSF_PURE_GENERIC
);
2684 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2685 scm_class_entity_class
,
2686 scm_list_2 (scm_class_accessor
,
2687 scm_class_extended_generic_with_setter
),
2689 fix_cpl (scm_class_extended_accessor
,
2690 scm_class_extended_generic
, scm_class_generic
);
2691 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2693 /* Primitive types classes */
2694 make_stdcls (&scm_class_boolean
, "<boolean>",
2695 scm_class_class
, scm_class_top
, SCM_EOL
);
2696 make_stdcls (&scm_class_char
, "<char>",
2697 scm_class_class
, scm_class_top
, SCM_EOL
);
2698 make_stdcls (&scm_class_list
, "<list>",
2699 scm_class_class
, scm_class_top
, SCM_EOL
);
2700 make_stdcls (&scm_class_pair
, "<pair>",
2701 scm_class_class
, scm_class_list
, SCM_EOL
);
2702 make_stdcls (&scm_class_null
, "<null>",
2703 scm_class_class
, scm_class_list
, SCM_EOL
);
2704 make_stdcls (&scm_class_string
, "<string>",
2705 scm_class_class
, scm_class_top
, SCM_EOL
);
2706 make_stdcls (&scm_class_symbol
, "<symbol>",
2707 scm_class_class
, scm_class_top
, SCM_EOL
);
2708 make_stdcls (&scm_class_vector
, "<vector>",
2709 scm_class_class
, scm_class_top
, SCM_EOL
);
2710 make_stdcls (&scm_class_number
, "<number>",
2711 scm_class_class
, scm_class_top
, SCM_EOL
);
2712 make_stdcls (&scm_class_complex
, "<complex>",
2713 scm_class_class
, scm_class_number
, SCM_EOL
);
2714 make_stdcls (&scm_class_real
, "<real>",
2715 scm_class_class
, scm_class_complex
, SCM_EOL
);
2716 make_stdcls (&scm_class_integer
, "<integer>",
2717 scm_class_class
, scm_class_real
, SCM_EOL
);
2718 make_stdcls (&scm_class_fraction
, "<fraction>",
2719 scm_class_class
, scm_class_real
, SCM_EOL
);
2720 make_stdcls (&scm_class_keyword
, "<keyword>",
2721 scm_class_class
, scm_class_top
, SCM_EOL
);
2722 make_stdcls (&scm_class_unknown
, "<unknown>",
2723 scm_class_class
, scm_class_top
, SCM_EOL
);
2724 make_stdcls (&scm_class_procedure
, "<procedure>",
2725 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2726 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2727 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2728 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2729 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2730 make_stdcls (&scm_class_port
, "<port>",
2731 scm_class_class
, scm_class_top
, SCM_EOL
);
2732 make_stdcls (&scm_class_input_port
, "<input-port>",
2733 scm_class_class
, scm_class_port
, SCM_EOL
);
2734 make_stdcls (&scm_class_output_port
, "<output-port>",
2735 scm_class_class
, scm_class_port
, SCM_EOL
);
2736 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2738 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2742 /**********************************************************************
2746 **********************************************************************/
2749 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2755 sprintf (buffer
, template, type_name
);
2756 name
= scm_from_locale_symbol (buffer
);
2759 name
= SCM_GOOPS_UNBOUND
;
2761 class = scm_permanent_object (scm_basic_make_class (applicablep
2762 ? scm_class_procedure_class
2768 /* Only define name if doesn't already exist. */
2769 if (!SCM_GOOPS_UNBOUNDP (name
)
2770 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2771 DEFVAR (name
, class);
2776 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2779 if (type_name_sym
!= SCM_BOOL_F
)
2781 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2782 scm_symbol_to_string (type_name_sym
),
2783 scm_from_locale_string (">")));
2784 name
= scm_string_to_symbol (name
);
2787 name
= SCM_GOOPS_UNBOUND
;
2789 class = scm_permanent_object (scm_basic_make_class (applicablep
2790 ? scm_class_procedure_class
2796 /* Only define name if doesn't already exist. */
2797 if (!SCM_GOOPS_UNBOUNDP (name
)
2798 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2799 DEFVAR (name
, class);
2804 scm_make_extended_class (char const *type_name
, int applicablep
)
2806 return make_class_from_template ("<%s>",
2808 scm_list_1 (applicablep
2809 ? scm_class_applicable
2815 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2817 return make_class_from_symbol (type_name_sym
,
2818 scm_list_1 (applicablep
2819 ? scm_class_applicable
2825 scm_i_inherit_applicable (SCM c
)
2827 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2829 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2830 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2831 /* patch scm_class_applicable into direct-supers */
2832 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2833 if (scm_is_false (top
))
2834 dsupers
= scm_append (scm_list_2 (dsupers
,
2835 scm_list_1 (scm_class_applicable
)));
2838 SCM_SETCAR (top
, scm_class_applicable
);
2839 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2841 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2842 /* patch scm_class_applicable into cpl */
2843 top
= scm_c_memq (scm_class_top
, cpl
);
2844 if (scm_is_false (top
))
2848 SCM_SETCAR (top
, scm_class_applicable
);
2849 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2851 /* add class to direct-subclasses of scm_class_applicable */
2852 SCM_SET_SLOT (scm_class_applicable
,
2853 scm_si_direct_subclasses
,
2854 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2855 scm_si_direct_subclasses
)));
2860 create_smob_classes (void)
2864 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2865 scm_smob_class
[i
] = 0;
2867 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2869 for (i
= 0; i
< scm_numsmob
; ++i
)
2870 if (!scm_smob_class
[i
])
2871 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2872 scm_smobs
[i
].apply
!= 0);
2876 scm_make_port_classes (long ptobnum
, char *type_name
)
2878 SCM c
, class = make_class_from_template ("<%s-port>",
2880 scm_list_1 (scm_class_port
),
2882 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2883 = make_class_from_template ("<%s-input-port>",
2885 scm_list_2 (class, scm_class_input_port
),
2887 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2888 = make_class_from_template ("<%s-output-port>",
2890 scm_list_2 (class, scm_class_output_port
),
2892 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2894 = make_class_from_template ("<%s-input-output-port>",
2896 scm_list_2 (class, scm_class_input_output_port
),
2898 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2899 SCM_SET_SLOT (c
, scm_si_cpl
,
2900 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2904 create_port_classes (void)
2908 for (i
= 0; i
< scm_numptob
; ++i
)
2909 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2913 make_struct_class (void *closure SCM_UNUSED
,
2914 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2916 SCM sym
= SCM_STRUCT_TABLE_NAME (data
);
2917 if (scm_is_true (sym
))
2919 int applicablep
= SCM_CLASS_FLAGS (vtable
) & SCM_VTABLE_FLAG_APPLICABLE
;
2921 SCM_SET_STRUCT_TABLE_CLASS (data
,
2922 scm_make_extended_class_from_symbol (sym
, applicablep
));
2925 scm_remember_upto_here_2 (data
, vtable
);
2926 return SCM_UNSPECIFIED
;
2930 create_struct_classes (void)
2932 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2935 /**********************************************************************
2939 **********************************************************************/
2944 if (!goops_loaded_p
)
2945 scm_c_resolve_module ("oop goops");
2949 SCM_SYMBOL (sym_o
, "o");
2950 SCM_SYMBOL (sym_x
, "x");
2952 SCM_KEYWORD (k_accessor
, "accessor");
2953 SCM_KEYWORD (k_getter
, "getter");
2956 scm_ensure_accessor (SCM name
)
2958 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
2959 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
2961 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
2962 gf
= scm_make (scm_list_5 (scm_class_accessor
,
2963 k_name
, name
, k_setter
, gf
));
2968 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
2971 scm_add_method (SCM gf
, SCM m
)
2973 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
2978 * Debugging utilities
2981 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
2983 "Return @code{#t} if @var{obj} is a pure generic.")
2984 #define FUNC_NAME s_scm_pure_generic_p
2986 return scm_from_bool (SCM_PUREGENERICP (obj
));
2990 #endif /* GUILE_DEBUG */
2996 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
2998 "Announce that GOOPS is loaded and perform initialization\n"
2999 "on the C level which depends on the loaded GOOPS modules.")
3000 #define FUNC_NAME s_scm_sys_goops_loaded
3003 var_compute_applicable_methods
=
3004 scm_permanent_object
3005 (scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
));
3007 scm_permanent_object
3008 (scm_module_variable (scm_module_goops
, sym_slot_unbound
));
3010 scm_permanent_object
3011 (scm_module_variable (scm_module_goops
, sym_slot_missing
));
3013 scm_permanent_object
3014 (scm_module_variable (scm_module_goops
, sym_compute_cpl
));
3015 var_no_applicable_method
=
3016 scm_permanent_object
3017 (scm_module_variable (scm_module_goops
, sym_no_applicable_method
));
3019 scm_permanent_object
3020 (scm_module_variable (scm_module_goops
, sym_change_class
));
3021 setup_extended_primitive_generics ();
3022 return SCM_UNSPECIFIED
;
3026 SCM scm_module_goops
;
3029 scm_init_goops_builtins (void)
3031 scm_module_goops
= scm_current_module ();
3033 /* Not really necessary right now, but who knows...
3035 scm_permanent_object (scm_module_goops
);
3037 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3039 #include "libguile/goops.x"
3041 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3043 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3044 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3046 create_basic_classes ();
3047 create_standard_classes ();
3048 create_smob_classes ();
3049 create_struct_classes ();
3050 create_port_classes ();
3053 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3054 scm_no_applicable_method
3055 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3058 DEFVAR (name
, scm_no_applicable_method
);
3061 return SCM_UNSPECIFIED
;
3067 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3068 scm_init_goops_builtins
);