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_opaque
, scm_class_read_only
;
164 SCM 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
);
297 /* FIXME APPLICABLE structs */
299 scm_make_extended_class_from_symbol (name
, 0);
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
))
717 index
= SCM_GNS_INDEX (SCM_CAR (getters_n_setters
));
718 if (index
!= (i
>> 1))
720 size
= SCM_GNS_SIZE (SCM_CAR (getters_n_setters
));
728 slots
= SCM_CDR (slots
);
729 getters_n_setters
= SCM_CDR (getters_n_setters
);
731 if (!scm_is_null (slots
))
734 SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL
);
736 SCM_SET_SLOT (class, scm_si_layout
, scm_string_to_symbol (layout
));
737 return SCM_UNSPECIFIED
;
741 static void prep_hashsets (SCM
);
743 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
744 (SCM
class, SCM dsupers
),
746 #define FUNC_NAME s_scm_sys_inherit_magic_x
750 SCM_VALIDATE_INSTANCE (1, class);
751 while (!scm_is_null (ls
))
753 SCM_ASSERT (scm_is_pair (ls
)
754 && SCM_INSTANCEP (SCM_CAR (ls
)),
758 flags
|= SCM_CLASS_FLAGS (SCM_CAR (ls
));
761 flags
&= SCM_CLASSF_INHERIT
;
763 if (! (flags
& SCM_CLASSF_PURE_GENERIC
))
765 long n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
768 * We could avoid calling scm_gc_malloc in the allocation code
769 * (in which case the following two lines are needed). Instead
770 * we make 0-slot instances non-light, so that the light case
771 * can be handled without special cases.
774 SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0
);
776 if (n
> 0 && !(flags
& SCM_CLASSF_METACLASS
))
778 flags
|= SCM_STRUCTF_LIGHT
; /* use light representation */
781 SCM_SET_CLASS_FLAGS (class, flags
);
783 prep_hashsets (class);
785 return SCM_UNSPECIFIED
;
790 prep_hashsets (SCM
class)
794 for (i
= 0; i
< 8; ++i
)
795 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
798 /******************************************************************************/
801 scm_basic_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
803 SCM z
, cpl
, slots
, nfields
, g_n_s
;
805 /* Allocate one instance */
806 z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
808 /* Initialize its slots */
809 SCM_SET_SLOT (z
, scm_si_direct_supers
, dsupers
);
810 cpl
= compute_cpl (z
);
811 slots
= build_slots_list (maplist (dslots
), cpl
);
812 nfields
= scm_from_int (scm_ilength (slots
));
813 g_n_s
= compute_getters_n_setters (slots
);
815 SCM_SET_SLOT (z
, scm_si_name
, name
);
816 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
);
817 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
818 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
819 SCM_SET_SLOT (z
, scm_si_cpl
, cpl
);
820 SCM_SET_SLOT (z
, scm_si_slots
, slots
);
821 SCM_SET_SLOT (z
, scm_si_nfields
, nfields
);
822 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, g_n_s
);
823 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
824 SCM_SET_SLOT (z
, scm_si_environment
,
825 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
827 /* Add this class in the direct-subclasses slot of dsupers */
830 for (tmp
= dsupers
; !scm_is_null (tmp
); tmp
= SCM_CDR (tmp
))
831 SCM_SET_SLOT (SCM_CAR (tmp
), scm_si_direct_subclasses
,
832 scm_cons (z
, SCM_SLOT (SCM_CAR (tmp
),
833 scm_si_direct_subclasses
)));
836 /* Support for the underlying structs: */
837 /* FIXME: set entity flag on z if class == entity_class ? */
838 SCM_SET_CLASS_FLAGS (z
, SCM_CLASSF_GOOPS_OR_VALID
);
843 scm_basic_make_class (SCM
class, SCM name
, SCM dsupers
, SCM dslots
)
845 SCM z
= scm_basic_basic_make_class (class, name
, dsupers
, dslots
);
846 scm_sys_inherit_magic_x (z
, dsupers
);
847 scm_sys_prep_layout_x (z
);
851 /******************************************************************************/
853 SCM_SYMBOL (sym_layout
, "layout");
854 SCM_SYMBOL (sym_vcell
, "vcell");
855 SCM_SYMBOL (sym_vtable
, "vtable");
856 SCM_SYMBOL (sym_print
, "print");
857 SCM_SYMBOL (sym_procedure
, "procedure");
858 SCM_SYMBOL (sym_setter
, "setter");
859 SCM_SYMBOL (sym_redefined
, "redefined");
860 SCM_SYMBOL (sym_h0
, "h0");
861 SCM_SYMBOL (sym_h1
, "h1");
862 SCM_SYMBOL (sym_h2
, "h2");
863 SCM_SYMBOL (sym_h3
, "h3");
864 SCM_SYMBOL (sym_h4
, "h4");
865 SCM_SYMBOL (sym_h5
, "h5");
866 SCM_SYMBOL (sym_h6
, "h6");
867 SCM_SYMBOL (sym_h7
, "h7");
868 SCM_SYMBOL (sym_name
, "name");
869 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
870 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
871 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
872 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
873 SCM_SYMBOL (sym_cpl
, "cpl");
874 SCM_SYMBOL (sym_default_slot_definition_class
, "default-slot-definition-class");
875 SCM_SYMBOL (sym_slots
, "slots");
876 SCM_SYMBOL (sym_getters_n_setters
, "getters-n-setters");
877 SCM_SYMBOL (sym_keyword_access
, "keyword-access");
878 SCM_SYMBOL (sym_nfields
, "nfields");
879 SCM_SYMBOL (sym_environment
, "environment");
883 build_class_class_slots ()
886 scm_list_3 (sym_layout
, k_class
, scm_class_protected_read_only
),
887 scm_list_3 (sym_vtable
, k_class
, scm_class_self
),
888 scm_list_1 (sym_print
),
889 scm_list_3 (sym_procedure
, k_class
, scm_class_protected_opaque
),
890 scm_list_3 (sym_setter
, k_class
, scm_class_protected_opaque
),
891 scm_list_1 (sym_redefined
),
892 scm_list_3 (sym_h0
, k_class
, scm_class_int
),
893 scm_list_3 (sym_h1
, k_class
, scm_class_int
),
894 scm_list_3 (sym_h2
, k_class
, scm_class_int
),
895 scm_list_3 (sym_h3
, k_class
, scm_class_int
),
896 scm_list_3 (sym_h4
, k_class
, scm_class_int
),
897 scm_list_3 (sym_h5
, k_class
, scm_class_int
),
898 scm_list_3 (sym_h6
, k_class
, scm_class_int
),
899 scm_list_3 (sym_h7
, k_class
, scm_class_int
),
900 scm_list_1 (sym_name
),
901 scm_list_1 (sym_direct_supers
),
902 scm_list_1 (sym_direct_slots
),
903 scm_list_1 (sym_direct_subclasses
),
904 scm_list_1 (sym_direct_methods
),
905 scm_list_1 (sym_cpl
),
906 scm_list_1 (sym_default_slot_definition_class
),
907 scm_list_1 (sym_slots
),
908 scm_list_1 (sym_getters_n_setters
),
909 scm_list_1 (sym_keyword_access
),
910 scm_list_1 (sym_nfields
),
911 scm_list_1 (sym_environment
),
916 create_basic_classes (void)
918 /* SCM slots_of_class = build_class_class_slots (); */
920 /**** <scm_class_class> ****/
921 SCM cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
922 + 2 * scm_vtable_offset_user
);
923 SCM name
= scm_from_locale_symbol ("<class>");
924 scm_class_class
= scm_permanent_object (scm_make_vtable_vtable (cs
,
927 SCM_SET_CLASS_FLAGS (scm_class_class
, (SCM_CLASSF_GOOPS_OR_VALID
928 | SCM_CLASSF_METACLASS
));
930 SCM_SET_SLOT (scm_class_class
, scm_si_name
, name
);
931 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
932 /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
933 SCM_SET_SLOT (scm_class_class
, scm_si_direct_subclasses
, SCM_EOL
);
934 SCM_SET_SLOT (scm_class_class
, scm_si_direct_methods
, SCM_EOL
);
935 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, SCM_EOL
); /* will be changed */
936 /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
937 SCM_SET_SLOT (scm_class_class
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
938 /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
939 compute_getters_n_setters (slots_of_class)); */
940 SCM_SET_SLOT (scm_class_class
, scm_si_redefined
, SCM_BOOL_F
);
941 SCM_SET_SLOT (scm_class_class
, scm_si_environment
,
942 scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE
));
944 prep_hashsets (scm_class_class
);
946 DEFVAR(name
, scm_class_class
);
948 /**** <scm_class_top> ****/
949 name
= scm_from_locale_symbol ("<top>");
950 scm_class_top
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
955 DEFVAR(name
, scm_class_top
);
957 /**** <scm_class_object> ****/
958 name
= scm_from_locale_symbol ("<object>");
959 scm_class_object
= scm_permanent_object (scm_basic_make_class (scm_class_class
,
961 scm_list_1 (scm_class_top
),
964 DEFVAR (name
, scm_class_object
);
966 /* <top> <object> and <class> were partially initialized. Correct them here */
967 SCM_SET_SLOT (scm_class_object
, scm_si_direct_subclasses
, scm_list_1 (scm_class_class
));
969 SCM_SET_SLOT (scm_class_class
, scm_si_direct_supers
, scm_list_1 (scm_class_object
));
970 SCM_SET_SLOT (scm_class_class
, scm_si_cpl
, scm_list_3 (scm_class_class
, scm_class_object
, scm_class_top
));
973 /******************************************************************************/
975 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
977 "Return @code{#t} if @var{obj} is an instance.")
978 #define FUNC_NAME s_scm_instance_p
980 return scm_from_bool (SCM_INSTANCEP (obj
));
985 /******************************************************************************
987 * Meta object accessors
989 ******************************************************************************/
990 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
992 "Return the class name of @var{obj}.")
993 #define FUNC_NAME s_scm_class_name
995 SCM_VALIDATE_CLASS (1, obj
);
996 return scm_slot_ref (obj
, sym_name
);
1000 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
1002 "Return the direct superclasses of the class @var{obj}.")
1003 #define FUNC_NAME s_scm_class_direct_supers
1005 SCM_VALIDATE_CLASS (1, obj
);
1006 return scm_slot_ref (obj
, sym_direct_supers
);
1010 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
1012 "Return the direct slots of the class @var{obj}.")
1013 #define FUNC_NAME s_scm_class_direct_slots
1015 SCM_VALIDATE_CLASS (1, obj
);
1016 return scm_slot_ref (obj
, sym_direct_slots
);
1020 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
1022 "Return the direct subclasses of the class @var{obj}.")
1023 #define FUNC_NAME s_scm_class_direct_subclasses
1025 SCM_VALIDATE_CLASS (1, obj
);
1026 return scm_slot_ref(obj
, sym_direct_subclasses
);
1030 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
1032 "Return the direct methods of the class @var{obj}")
1033 #define FUNC_NAME s_scm_class_direct_methods
1035 SCM_VALIDATE_CLASS (1, obj
);
1036 return scm_slot_ref (obj
, sym_direct_methods
);
1040 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
1042 "Return the class precedence list of the class @var{obj}.")
1043 #define FUNC_NAME s_scm_class_precedence_list
1045 SCM_VALIDATE_CLASS (1, obj
);
1046 return scm_slot_ref (obj
, sym_cpl
);
1050 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
1052 "Return the slot list of the class @var{obj}.")
1053 #define FUNC_NAME s_scm_class_slots
1055 SCM_VALIDATE_CLASS (1, obj
);
1056 return scm_slot_ref (obj
, sym_slots
);
1060 SCM_DEFINE (scm_class_environment
, "class-environment", 1, 0, 0,
1062 "Return the environment of the class @var{obj}.")
1063 #define FUNC_NAME s_scm_class_environment
1065 SCM_VALIDATE_CLASS (1, obj
);
1066 return scm_slot_ref(obj
, sym_environment
);
1071 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
1073 "Return the name of the generic function @var{obj}.")
1074 #define FUNC_NAME s_scm_generic_function_name
1076 SCM_VALIDATE_GENERIC (1, obj
);
1077 return scm_procedure_property (obj
, scm_sym_name
);
1081 SCM_SYMBOL (sym_methods
, "methods");
1082 SCM_SYMBOL (sym_extended_by
, "extended-by");
1083 SCM_SYMBOL (sym_extends
, "extends");
1086 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
1088 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
1089 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
1090 while (!scm_is_null (gfs
))
1092 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
1093 gfs
= SCM_CDR (gfs
);
1095 return method_lists
;
1099 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
1101 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
1103 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
1104 while (!scm_is_null (gfs
))
1106 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
1107 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
1110 gfs
= SCM_CDR (gfs
);
1113 return method_lists
;
1116 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
1118 "Return the methods of the generic function @var{obj}.")
1119 #define FUNC_NAME s_scm_generic_function_methods
1122 SCM_VALIDATE_GENERIC (1, obj
);
1123 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
1124 methods
= fold_downward_gf_methods (methods
, obj
);
1125 return scm_append (methods
);
1129 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
1131 "Return the generic function for the method @var{obj}.")
1132 #define FUNC_NAME s_scm_method_generic_function
1134 SCM_VALIDATE_METHOD (1, obj
);
1135 return scm_slot_ref (obj
, scm_from_locale_symbol ("generic-function"));
1139 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
1141 "Return specializers of the method @var{obj}.")
1142 #define FUNC_NAME s_scm_method_specializers
1144 SCM_VALIDATE_METHOD (1, obj
);
1145 return scm_slot_ref (obj
, scm_from_locale_symbol ("specializers"));
1149 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
1151 "Return the procedure of the method @var{obj}.")
1152 #define FUNC_NAME s_scm_method_procedure
1154 SCM_VALIDATE_METHOD (1, obj
);
1155 return scm_slot_ref (obj
, sym_procedure
);
1159 SCM_DEFINE (scm_accessor_method_slot_definition
, "accessor-method-slot-definition", 1, 0, 0,
1161 "Return the slot definition of the accessor @var{obj}.")
1162 #define FUNC_NAME s_scm_accessor_method_slot_definition
1164 SCM_VALIDATE_ACCESSOR (1, obj
);
1165 return scm_slot_ref (obj
, scm_from_locale_symbol ("slot-definition"));
1169 /******************************************************************************
1171 * S l o t a c c e s s
1173 ******************************************************************************/
1175 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
1177 "Return the unbound value.")
1178 #define FUNC_NAME s_scm_make_unbound
1180 return SCM_GOOPS_UNBOUND
;
1184 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
1186 "Return @code{#t} if @var{obj} is unbound.")
1187 #define FUNC_NAME s_scm_unbound_p
1189 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1193 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
1194 (SCM value
, SCM obj
),
1195 "Return @var{value} if it is bound, and invoke the\n"
1196 "@var{slot-unbound} method of @var{obj} if it is not.")
1197 #define FUNC_NAME s_scm_assert_bound
1199 if (SCM_GOOPS_UNBOUNDP (value
))
1200 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1205 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
1206 (SCM obj
, SCM index
),
1207 "Like @code{assert-bound}, but use @var{index} for accessing\n"
1208 "the value from @var{obj}.")
1209 #define FUNC_NAME s_scm_at_assert_bound_ref
1211 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
1212 if (SCM_GOOPS_UNBOUNDP (value
))
1213 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
1218 SCM_DEFINE (scm_sys_fast_slot_ref
, "%fast-slot-ref", 2, 0, 0,
1219 (SCM obj
, SCM index
),
1220 "Return the slot value with index @var{index} from @var{obj}.")
1221 #define FUNC_NAME s_scm_sys_fast_slot_ref
1223 unsigned long int i
;
1225 SCM_VALIDATE_INSTANCE (1, obj
);
1226 i
= scm_to_unsigned_integer (index
, 0,
1227 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1230 return SCM_SLOT (obj
, i
);
1234 SCM_DEFINE (scm_sys_fast_slot_set_x
, "%fast-slot-set!", 3, 0, 0,
1235 (SCM obj
, SCM index
, SCM value
),
1236 "Set the slot with index @var{index} in @var{obj} to\n"
1238 #define FUNC_NAME s_scm_sys_fast_slot_set_x
1240 unsigned long int i
;
1242 SCM_VALIDATE_INSTANCE (1, obj
);
1243 i
= scm_to_unsigned_integer (index
, 0,
1244 SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj
),
1248 SCM_SET_SLOT (obj
, i
, value
);
1250 return SCM_UNSPECIFIED
;
1258 /* In the future, this function will return the effective slot
1259 * definition associated with SLOT_NAME. Now it just returns some of
1260 * the information which will be stored in the effective slot
1265 slot_definition_using_name (SCM
class, SCM slot_name
)
1267 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
1268 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
1269 if (SCM_CAAR (slots
) == slot_name
)
1270 return SCM_CAR (slots
);
1275 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
1276 #define FUNC_NAME "%get-slot-value"
1278 SCM access
= SCM_CDDR (slotdef
);
1280 * - access is an integer (the offset of this slot in the slots vector)
1281 * - otherwise (car access) is the getter function to apply
1283 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1284 * we can just assume fixnums here.
1286 if (SCM_I_INUMP (access
))
1287 /* Don't poke at the slots directly, because scm_struct_ref handles the
1288 access bits for us. */
1289 return scm_struct_ref (obj
, access
);
1292 /* We must evaluate (apply (car access) (list obj))
1293 * where (car access) is known to be a closure of arity 1 */
1294 register SCM code
, env
;
1296 code
= SCM_CAR (access
);
1297 if (!SCM_CLOSUREP (code
))
1298 return scm_call_1 (code
, obj
);
1299 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1302 /* Evaluate the closure body */
1303 return scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1309 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
1311 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1312 if (scm_is_true (slotdef
))
1313 return get_slot_value (class, obj
, slotdef
);
1315 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
1319 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
1320 #define FUNC_NAME "%set-slot-value"
1322 SCM access
= SCM_CDDR (slotdef
);
1324 * - access is an integer (the offset of this slot in the slots vector)
1325 * - otherwise (cadr access) is the setter function to apply
1327 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
1328 * we can just assume fixnums here.
1330 if (SCM_I_INUMP (access
))
1331 /* obey permissions bits via going through struct-set! */
1332 scm_struct_set_x (obj
, access
, value
);
1335 /* We must evaluate (apply (cadr l) (list obj value))
1336 * where (cadr l) is known to be a closure of arity 2 */
1337 register SCM code
, env
;
1339 code
= SCM_CADR (access
);
1340 if (!SCM_CLOSUREP (code
))
1341 scm_call_2 (code
, obj
, value
);
1344 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
1345 scm_list_2 (obj
, value
),
1347 /* Evaluate the closure body */
1348 scm_eval_body (SCM_CLOSURE_BODY (code
), env
);
1351 return SCM_UNSPECIFIED
;
1356 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
1358 SCM slotdef
= slot_definition_using_name (class, slot_name
);
1359 if (scm_is_true (slotdef
))
1360 return set_slot_value (class, obj
, slotdef
, value
);
1362 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
1366 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
1370 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
1371 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
1377 /* ======================================== */
1379 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
1380 (SCM
class, SCM obj
, SCM slot_name
),
1382 #define FUNC_NAME s_scm_slot_ref_using_class
1386 SCM_VALIDATE_CLASS (1, class);
1387 SCM_VALIDATE_INSTANCE (2, obj
);
1388 SCM_VALIDATE_SYMBOL (3, slot_name
);
1390 res
= get_slot_value_using_name (class, obj
, slot_name
);
1391 if (SCM_GOOPS_UNBOUNDP (res
))
1392 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1398 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
1399 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
1401 #define FUNC_NAME s_scm_slot_set_using_class_x
1403 SCM_VALIDATE_CLASS (1, class);
1404 SCM_VALIDATE_INSTANCE (2, obj
);
1405 SCM_VALIDATE_SYMBOL (3, slot_name
);
1407 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1412 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
1413 (SCM
class, SCM obj
, SCM slot_name
),
1415 #define FUNC_NAME s_scm_slot_bound_using_class_p
1417 SCM_VALIDATE_CLASS (1, class);
1418 SCM_VALIDATE_INSTANCE (2, obj
);
1419 SCM_VALIDATE_SYMBOL (3, slot_name
);
1421 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
1427 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
1428 (SCM
class, SCM obj
, SCM slot_name
),
1430 #define FUNC_NAME s_scm_slot_exists_using_class_p
1432 SCM_VALIDATE_CLASS (1, class);
1433 SCM_VALIDATE_INSTANCE (2, obj
);
1434 SCM_VALIDATE_SYMBOL (3, slot_name
);
1435 return test_slot_existence (class, obj
, slot_name
);
1440 /* ======================================== */
1442 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
1443 (SCM obj
, SCM slot_name
),
1444 "Return the value from @var{obj}'s slot with the name\n"
1446 #define FUNC_NAME s_scm_slot_ref
1450 SCM_VALIDATE_INSTANCE (1, obj
);
1451 TEST_CHANGE_CLASS (obj
, class);
1453 res
= get_slot_value_using_name (class, obj
, slot_name
);
1454 if (SCM_GOOPS_UNBOUNDP (res
))
1455 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
1460 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
1461 (SCM obj
, SCM slot_name
, SCM value
),
1462 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
1463 #define FUNC_NAME s_scm_slot_set_x
1467 SCM_VALIDATE_INSTANCE (1, obj
);
1468 TEST_CHANGE_CLASS(obj
, class);
1470 return set_slot_value_using_name (class, obj
, slot_name
, value
);
1474 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
1476 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
1477 (SCM obj
, SCM slot_name
),
1478 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
1480 #define FUNC_NAME s_scm_slot_bound_p
1484 SCM_VALIDATE_INSTANCE (1, obj
);
1485 TEST_CHANGE_CLASS(obj
, class);
1487 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1495 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1496 (SCM obj
, SCM slot_name
),
1497 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1498 #define FUNC_NAME s_scm_slot_exists_p
1502 SCM_VALIDATE_INSTANCE (1, obj
);
1503 SCM_VALIDATE_SYMBOL (2, slot_name
);
1504 TEST_CHANGE_CLASS (obj
, class);
1506 return test_slot_existence (class, obj
, slot_name
);
1511 /******************************************************************************
1513 * %allocate-instance (the low level instance allocation primitive)
1515 ******************************************************************************/
1517 static void clear_method_cache (SCM
);
1520 wrap_init (SCM
class, SCM
*m
, long n
)
1523 scm_t_bits slayout
= SCM_STRUCT_DATA (class)[scm_vtable_index_layout
];
1524 SCM layout
= SCM_PACK (slayout
);
1526 /* Set all SCM-holding slots to unbound */
1527 for (i
= 0; i
< n
; i
++)
1528 if (scm_i_symbol_ref (layout
, i
*2) == 'p')
1529 m
[i
] = SCM_GOOPS_UNBOUND
;
1533 return scm_double_cell ((((scm_t_bits
) SCM_STRUCT_DATA (class))
1535 (scm_t_bits
) m
, 0, 0);
1538 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1539 (SCM
class, SCM initargs
),
1540 "Create a new instance of class @var{class} and initialize it\n"
1541 "from the arguments @var{initargs}.")
1542 #define FUNC_NAME s_scm_sys_allocate_instance
1547 SCM_VALIDATE_CLASS (1, class);
1549 /* Most instances */
1550 if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT
)
1552 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1553 m
= (SCM
*) scm_gc_malloc (n
* sizeof (SCM
), "struct");
1554 return wrap_init (class, m
, n
);
1557 /* Foreign objects */
1558 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN
)
1559 return scm_make_foreign_object (class, initargs
);
1561 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1563 /* FIXME applicable structs */
1564 /* Generic functions */
1565 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1568 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_entity_n_extra_words
,
1569 "generic function");
1570 m
[scm_struct_i_setter
] = SCM_BOOL_F
;
1571 m
[scm_struct_i_procedure
] = SCM_BOOL_F
;
1572 gf
= wrap_init (class, m
, n
);
1573 clear_method_cache (gf
);
1578 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS
)
1582 /* allocate class object */
1583 SCM z
= scm_make_struct (class, SCM_INUM0
, SCM_EOL
);
1585 SCM_SET_SLOT (z
, scm_si_print
, SCM_GOOPS_UNBOUND
);
1586 for (i
= scm_si_goops_fields
; i
< n
; i
++)
1587 SCM_SET_SLOT (z
, i
, SCM_GOOPS_UNBOUND
);
1589 /* FIXME propagate applicable struct flag */
1594 /* Non-light instances */
1596 m
= (SCM
*) scm_alloc_struct (n
, scm_struct_n_extra_words
, "heavy struct");
1597 return wrap_init (class, m
, n
);
1602 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1603 (SCM obj
, SCM setter
),
1605 #define FUNC_NAME s_scm_sys_set_object_setter_x
1607 SCM_ASSERT (SCM_STRUCTP (obj
)
1608 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1612 SCM_SET_GENERIC_SETTER (obj
, setter
);
1613 return SCM_UNSPECIFIED
;
1617 /******************************************************************************
1619 * %modify-instance (used by change-class to modify in place)
1621 ******************************************************************************/
1623 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1626 #define FUNC_NAME s_scm_sys_modify_instance
1628 SCM_VALIDATE_INSTANCE (1, old
);
1629 SCM_VALIDATE_INSTANCE (2, new);
1631 /* Exchange the data contained in old and new. We exchange rather than
1632 * scratch the old value with new to be correct with GC.
1633 * See "Class redefinition protocol above".
1635 SCM_CRITICAL_SECTION_START
;
1637 scm_t_bits word0
, word1
;
1638 word0
= SCM_CELL_WORD_0 (old
);
1639 word1
= SCM_CELL_WORD_1 (old
);
1640 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1641 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1642 SCM_SET_CELL_WORD_0 (new, word0
);
1643 SCM_SET_CELL_WORD_1 (new, word1
);
1645 SCM_CRITICAL_SECTION_END
;
1646 return SCM_UNSPECIFIED
;
1650 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1653 #define FUNC_NAME s_scm_sys_modify_class
1655 SCM_VALIDATE_CLASS (1, old
);
1656 SCM_VALIDATE_CLASS (2, new);
1658 SCM_CRITICAL_SECTION_START
;
1660 scm_t_bits word0
, word1
;
1661 word0
= SCM_CELL_WORD_0 (old
);
1662 word1
= SCM_CELL_WORD_1 (old
);
1663 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1664 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1665 SCM_STRUCT_DATA (old
)[scm_vtable_index_vtable
] = SCM_UNPACK (old
);
1666 SCM_SET_CELL_WORD_0 (new, word0
);
1667 SCM_SET_CELL_WORD_1 (new, word1
);
1668 SCM_STRUCT_DATA (new)[scm_vtable_index_vtable
] = SCM_UNPACK (new);
1670 SCM_CRITICAL_SECTION_END
;
1671 return SCM_UNSPECIFIED
;
1675 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1678 #define FUNC_NAME s_scm_sys_invalidate_class
1680 SCM_VALIDATE_CLASS (1, class);
1681 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1682 return SCM_UNSPECIFIED
;
1686 /* When instances change class, they finally get a new body, but
1687 * before that, they go through purgatory in hell. Odd as it may
1688 * seem, this data structure saves us from eternal suffering in
1689 * infinite recursions.
1692 static scm_t_bits
**hell
;
1693 static long n_hell
= 1; /* one place for the evil one himself */
1694 static long hell_size
= 4;
1695 static SCM hell_mutex
;
1701 for (i
= 1; i
< n_hell
; ++i
)
1702 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1708 go_to_hell (void *o
)
1710 SCM obj
= SCM_PACK ((scm_t_bits
) o
);
1711 scm_lock_mutex (hell_mutex
);
1712 if (n_hell
>= hell_size
)
1715 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1717 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1718 scm_unlock_mutex (hell_mutex
);
1722 go_to_heaven (void *o
)
1724 scm_lock_mutex (hell_mutex
);
1725 hell
[burnin (SCM_PACK ((scm_t_bits
) o
))] = hell
[--n_hell
];
1726 scm_unlock_mutex (hell_mutex
);
1730 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1733 purgatory (void *args
)
1735 return scm_apply_0 (SCM_VARIABLE_REF (var_change_class
),
1736 SCM_PACK ((scm_t_bits
) args
));
1739 /* This function calls the generic function change-class for all
1740 * instances which aren't currently undergoing class change.
1744 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1747 scm_internal_dynamic_wind (go_to_hell
, purgatory
, go_to_heaven
,
1748 (void *) SCM_UNPACK (scm_list_2 (obj
, new_class
)),
1749 (void *) SCM_UNPACK (obj
));
1752 /******************************************************************************
1758 * GGG E N E R I C F U N C T I O N S
1760 * This implementation provides
1761 * - generic functions (with class specializers)
1764 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1766 ******************************************************************************/
1768 SCM_KEYWORD (k_name
, "name");
1770 SCM_SYMBOL (sym_no_method
, "no-method");
1772 static SCM list_of_no_method
;
1774 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1777 /* The cache argument for scm_mcache_lookup_cmethod has one of two possible
1781 * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
1782 * #((TYPE1 ... ENV FORMALS FORM ...) ...)
1786 * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
1787 * #((TYPE1 ... ENV FORMALS FORM ...) ...)
1790 * ARGS is either a list of expressions, in which case they
1791 * are interpreted as the arguments of an application, or
1792 * a non-pair, which is interpreted as a single expression
1793 * yielding all arguments.
1795 * SCM_IM_DISPATCH expressions in generic functions always
1796 * have ARGS = the symbol `args' or the iloc #@0-0.
1798 * Need FORMALS in order to support varying arity. This
1799 * also avoids the need for renaming of bindings.
1801 * We should probably not complicate this mechanism by
1802 * introducing "optimizations" for getters and setters or
1803 * primitive methods. Getters and setter will normally be
1804 * compiled into @slot-[ref|set!] or a procedure call.
1805 * They rely on the dispatch performed before executing
1806 * the code which contains them.
1808 * We might want to use a more efficient representation of
1809 * this form in the future, perhaps after we have introduced
1810 * low-level support for syntax-case macros.
1814 scm_mcache_lookup_cmethod (SCM cache
, SCM args
)
1816 unsigned long i
, mask
, n
, end
;
1817 SCM ls
, methods
, z
= SCM_CDDR (cache
);
1818 n
= scm_to_ulong (SCM_CAR (z
)); /* maximum number of specializers */
1819 methods
= SCM_CADR (z
);
1821 if (scm_is_simple_vector (methods
))
1823 /* cache format #1: prepare for linear search */
1826 end
= SCM_SIMPLE_VECTOR_LENGTH (methods
);
1830 /* cache format #2: compute a hash value */
1831 unsigned long hashset
= scm_to_ulong (methods
);
1834 mask
= scm_to_ulong (SCM_CAR (z
));
1835 methods
= SCM_CADR (z
);
1838 if (!scm_is_null (ls
))
1841 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls
)))
1842 [scm_si_hashsets
+ hashset
];
1845 while (j
-- && !scm_is_null (ls
));
1850 /* Search for match */
1854 z
= SCM_SIMPLE_VECTOR_REF (methods
, i
);
1855 ls
= args
; /* list of arguments */
1856 if (!scm_is_null (ls
))
1859 /* More arguments than specifiers => CLASS != ENV */
1860 if (! scm_is_eq (scm_class_of (SCM_CAR (ls
)), SCM_CAR (z
)))
1865 while (j
-- && !scm_is_null (ls
));
1866 /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
1867 if (!scm_is_pair (z
)
1868 || (!SCM_CLASSP (SCM_CAR (z
)) && !scm_is_symbol (SCM_CAR (z
))))
1877 scm_mcache_compute_cmethod (SCM cache
, SCM args
)
1879 SCM cmethod
= scm_mcache_lookup_cmethod (cache
, args
);
1880 if (scm_is_false (cmethod
))
1881 /* No match - memoize */
1882 return scm_memoize_method (cache
, args
);
1887 scm_apply_generic (SCM gf
, SCM args
)
1889 SCM cmethod
= scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf
), args
);
1890 if (SCM_PROGRAM_P (cmethod
))
1891 return scm_vm_apply (scm_the_vm (), cmethod
, args
);
1892 else if (scm_is_pair (cmethod
))
1893 return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod
)),
1894 SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod
)),
1896 SCM_CMETHOD_ENV (cmethod
)));
1898 return scm_apply (cmethod
, args
, SCM_EOL
);
1902 scm_call_generic_0 (SCM gf
)
1904 return scm_apply_generic (gf
, SCM_EOL
);
1908 scm_call_generic_1 (SCM gf
, SCM a1
)
1910 return scm_apply_generic (gf
, scm_list_1 (a1
));
1914 scm_call_generic_2 (SCM gf
, SCM a1
, SCM a2
)
1916 return scm_apply_generic (gf
, scm_list_2 (a1
, a2
));
1920 scm_call_generic_3 (SCM gf
, SCM a1
, SCM a2
, SCM a3
)
1922 return scm_apply_generic (gf
, scm_list_3 (a1
, a2
, a3
));
1926 scm_make_method_cache (SCM gf
)
1928 return scm_list_5 (SCM_IM_DISPATCH
,
1931 scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE
,
1937 clear_method_cache (SCM gf
)
1939 SCM cache
= scm_make_method_cache (gf
);
1940 SCM_SET_GENERIC_METHOD_CACHE (gf
, cache
);
1941 SCM_SET_SLOT (gf
, scm_si_used_by
, SCM_BOOL_F
);
1944 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1947 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1950 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1951 used_by
= SCM_SLOT (gf
, scm_si_used_by
);
1952 if (scm_is_true (used_by
))
1954 SCM methods
= SCM_SLOT (gf
, scm_si_methods
);
1955 for (; scm_is_pair (used_by
); used_by
= SCM_CDR (used_by
))
1956 scm_sys_invalidate_method_cache_x (SCM_CAR (used_by
));
1957 clear_method_cache (gf
);
1958 for (; scm_is_pair (methods
); methods
= SCM_CDR (methods
))
1959 SCM_SET_SLOT (SCM_CAR (methods
), scm_si_code_table
, SCM_EOL
);
1962 SCM n
= SCM_SLOT (gf
, scm_si_n_specialized
);
1963 /* The sign of n is a flag indicating rest args. */
1964 SCM_SET_MCACHE_N_SPECIALIZED (SCM_GENERIC_METHOD_CACHE (gf
), n
);
1966 return SCM_UNSPECIFIED
;
1970 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1973 #define FUNC_NAME s_scm_generic_capability_p
1975 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1976 proc
, SCM_ARG1
, FUNC_NAME
);
1977 return (scm_subr_p (proc
) && SCM_SUBR_GENERIC (proc
)
1983 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1986 #define FUNC_NAME s_scm_enable_primitive_generic_x
1988 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1989 while (!scm_is_null (subrs
))
1991 SCM subr
= SCM_CAR (subrs
);
1992 SCM_ASSERT (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
),
1993 subr
, SCM_ARGn
, FUNC_NAME
);
1994 *SCM_SUBR_GENERIC (subr
)
1995 = scm_make (scm_list_3 (scm_class_generic
,
1997 SCM_SUBR_NAME (subr
)));
1998 subrs
= SCM_CDR (subrs
);
2000 return SCM_UNSPECIFIED
;
2004 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
2007 #define FUNC_NAME s_scm_primitive_generic_generic
2009 if (scm_subr_p (subr
) && SCM_SUBR_GENERIC (subr
))
2011 if (!*SCM_SUBR_GENERIC (subr
))
2012 scm_enable_primitive_generic_x (scm_list_1 (subr
));
2013 return *SCM_SUBR_GENERIC (subr
);
2015 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
2019 typedef struct t_extension
{
2020 struct t_extension
*next
;
2026 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
2028 static const char extension_gc_hint
[] = "GOOPS extension";
2030 static t_extension
*extensions
= 0;
2032 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
2035 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
2040 if (!*SCM_SUBR_GENERIC (extended
))
2041 scm_enable_primitive_generic_x (scm_list_1 (extended
));
2042 gf
= *SCM_SUBR_GENERIC (extended
);
2043 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
2045 SCM_SUBR_NAME (extension
));
2046 SCM_SET_SUBR_GENERIC (extension
, gext
);
2050 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
2052 t_extension
**loc
= &extensions
;
2053 /* Make sure that extensions are placed before their own
2054 * extensions in the extensions list. O(N^2) algorithm, but
2055 * extensions of primitive generics are rare.
2057 while (*loc
&& extension
!= (*loc
)->extended
)
2058 loc
= &(*loc
)->next
;
2060 e
->extended
= extended
;
2061 e
->extension
= extension
;
2067 setup_extended_primitive_generics ()
2071 t_extension
*e
= extensions
;
2072 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
2073 extensions
= e
->next
;
2077 /******************************************************************************
2079 * Protocol for calling a generic fumction
2080 * This protocol is roughly equivalent to (parameter are a little bit different
2081 * for efficiency reasons):
2083 * + apply-generic (gf args)
2084 * + compute-applicable-methods (gf args ...)
2085 * + sort-applicable-methods (methods args)
2086 * + apply-methods (gf methods args)
2088 * apply-methods calls make-next-method to build the "continuation" of a a
2089 * method. Applying a next-method will call apply-next-method which in
2090 * turn will call apply again to call effectively the following method.
2092 ******************************************************************************/
2095 applicablep (SCM actual
, SCM formal
)
2097 /* We already know that the cpl is well formed. */
2098 return scm_is_true (scm_c_memq (formal
, SCM_SLOT (actual
, scm_si_cpl
)));
2102 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
2104 register SCM s1
, s2
;
2108 * m1 and m2 can have != length (i.e. one can be one element longer than the
2109 * other when we have a dotted parameter list). For instance, with the call
2112 * (define-method M (a . l) ....)
2113 * (define-method M (a) ....)
2115 * we consider that the second method is more specific.
2117 * BTW, targs is an array of types. We don't need it's size since
2118 * we already know that m1 and m2 are applicable (no risk to go past
2119 * the end of this array).
2122 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
2123 if (scm_is_null(s1
)) return 1;
2124 if (scm_is_null(s2
)) return 0;
2125 if (SCM_CAR(s1
) != SCM_CAR(s2
)) {
2126 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
2128 for (l
= SCM_SLOT (targs
[i
], scm_si_cpl
); ; l
= SCM_CDR(l
)) {
2129 if (cs1
== SCM_CAR(l
))
2131 if (cs2
== SCM_CAR(l
))
2134 return 0;/* should not occur! */
2137 return 0; /* should not occur! */
2140 #define BUFFSIZE 32 /* big enough for most uses */
2143 scm_i_vector2list (SCM l
, long len
)
2146 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2148 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
2149 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
2155 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
2158 SCM
*v
, vector
= SCM_EOL
;
2159 SCM buffer
[BUFFSIZE
];
2160 SCM save
= method_list
;
2161 scm_t_array_handle handle
;
2163 /* For reasonably sized method_lists we can try to avoid all the
2164 * consing and reorder the list in place...
2165 * This idea is due to David McClain <Dave_McClain@msn.com>
2167 if (size
<= BUFFSIZE
)
2169 for (i
= 0; i
< size
; i
++)
2171 buffer
[i
] = SCM_CAR (method_list
);
2172 method_list
= SCM_CDR (method_list
);
2178 /* Too many elements in method_list to keep everything locally */
2179 vector
= scm_i_vector2list (save
, size
);
2180 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
2183 /* Use a simple shell sort since it is generally faster than qsort on
2184 * small vectors (which is probably mostly the case when we have to
2185 * sort a list of applicable methods).
2187 for (incr
= size
/ 2; incr
; incr
/= 2)
2189 for (i
= incr
; i
< size
; i
++)
2191 for (j
= i
- incr
; j
>= 0; j
-= incr
)
2193 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
2197 SCM tmp
= v
[j
+ incr
];
2205 if (size
<= BUFFSIZE
)
2207 /* We did it in locally, so restore the original list (reordered) in-place */
2208 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
2210 SCM_SETCAR (method_list
, *v
);
2211 method_list
= SCM_CDR (method_list
);
2216 /* If we are here, that's that we did it the hard way... */
2217 scm_array_handle_release (&handle
);
2218 return scm_vector_to_list (vector
);
2222 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
2226 SCM l
, fl
, applicable
= SCM_EOL
;
2228 SCM buffer
[BUFFSIZE
];
2232 scm_t_array_handle handle
;
2234 /* Build the list of arguments types */
2235 if (len
>= BUFFSIZE
)
2237 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
2238 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
2241 note that we don't have to work to reset the generation
2242 count. TMP is a new vector anyway, and it is found
2249 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
2250 *p
++ = scm_class_of (SCM_CAR (args
));
2252 /* Build a list of all applicable methods */
2253 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
2255 fl
= SPEC_OF (SCM_CAR (l
));
2256 /* Only accept accessors which match exactly in first arg. */
2257 if (SCM_ACCESSORP (SCM_CAR (l
))
2258 && (scm_is_null (fl
) || types
[0] != SCM_CAR (fl
)))
2260 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
2262 if (SCM_INSTANCEP (fl
)
2263 /* We have a dotted argument list */
2264 || (i
>= len
&& scm_is_null (fl
)))
2265 { /* both list exhausted */
2266 applicable
= scm_cons (SCM_CAR (l
), applicable
);
2272 || !applicablep (types
[i
], SCM_CAR (fl
)))
2277 if (len
>= BUFFSIZE
)
2278 scm_array_handle_release (&handle
);
2284 scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method
), gf
, save
);
2285 /* if we are here, it's because no-applicable-method hasn't signaled an error */
2291 : sort_applicable_methods (applicable
, count
, types
));
2295 SCM_PROC (s_sys_compute_applicable_methods
, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods
);
2298 static const char s_sys_compute_applicable_methods
[] = "%compute-applicable-methods";
2301 scm_sys_compute_applicable_methods (SCM gf
, SCM args
)
2302 #define FUNC_NAME s_sys_compute_applicable_methods
2305 SCM_VALIDATE_GENERIC (1, gf
);
2306 n
= scm_ilength (args
);
2307 SCM_ASSERT (n
>= 0, args
, SCM_ARG2
, FUNC_NAME
);
2308 return scm_compute_applicable_methods (gf
, args
, n
, 1);
2312 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
2313 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
));
2316 lock_cache_mutex (void *m
)
2318 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2319 scm_lock_mutex (mutex
);
2323 unlock_cache_mutex (void *m
)
2325 SCM mutex
= SCM_PACK ((scm_t_bits
) m
);
2326 scm_unlock_mutex (mutex
);
2330 call_memoize_method (void *a
)
2332 SCM args
= SCM_PACK ((scm_t_bits
) a
);
2333 SCM gf
= SCM_CAR (args
);
2334 SCM x
= SCM_CADR (args
);
2335 /* First check if another thread has inserted a method between
2336 * the cache miss and locking the mutex.
2338 SCM cmethod
= scm_mcache_lookup_cmethod (x
, SCM_CDDR (args
));
2339 if (scm_is_true (cmethod
))
2342 if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x
)))
2343 var_memoize_method_x
=
2344 scm_permanent_object
2345 (scm_module_variable (scm_module_goops
, sym_memoize_method_x
));
2347 return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x
), gf
, SCM_CDDR (args
), x
);
2351 scm_memoize_method (SCM x
, SCM args
)
2353 SCM gf
= SCM_CAR (scm_last_pair (x
));
2354 return scm_internal_dynamic_wind (
2356 call_memoize_method
,
2358 (void *) SCM_UNPACK (scm_cons2 (gf
, x
, args
)),
2359 (void *) SCM_UNPACK (SCM_SLOT (gf
, scm_si_cache_mutex
)));
2362 /******************************************************************************
2364 * A simple make (which will be redefined later in Scheme)
2365 * This version handles only creation of gf, methods and classes (no instances)
2367 * Since this code will disappear when Goops will be fully booted,
2368 * no precaution is taken to be efficient.
2370 ******************************************************************************/
2372 SCM_KEYWORD (k_setter
, "setter");
2373 SCM_KEYWORD (k_specializers
, "specializers");
2374 SCM_KEYWORD (k_procedure
, "procedure");
2375 SCM_KEYWORD (k_formals
, "formals");
2376 SCM_KEYWORD (k_body
, "body");
2377 SCM_KEYWORD (k_make_procedure
, "make-procedure");
2378 SCM_KEYWORD (k_dsupers
, "dsupers");
2379 SCM_KEYWORD (k_slots
, "slots");
2380 SCM_KEYWORD (k_gf
, "generic-function");
2382 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
2384 "Make a new object. @var{args} must contain the class and\n"
2385 "all necessary initialization information.")
2386 #define FUNC_NAME s_scm_make
2389 long len
= scm_ilength (args
);
2391 if (len
<= 0 || (len
& 1) == 0)
2392 SCM_WRONG_NUM_ARGS ();
2394 class = SCM_CAR(args
);
2395 args
= SCM_CDR(args
);
2397 if (class == scm_class_generic
|| class == scm_class_accessor
)
2399 z
= scm_make_struct (class, SCM_INUM0
,
2400 scm_list_5 (SCM_EOL
,
2405 scm_set_procedure_property_x (z
, scm_sym_name
,
2406 scm_get_keyword (k_name
,
2409 clear_method_cache (z
);
2410 if (class == scm_class_accessor
)
2412 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
2413 if (scm_is_true (setter
))
2414 scm_sys_set_object_setter_x (z
, setter
);
2419 z
= scm_sys_allocate_instance (class, args
);
2421 if (class == scm_class_method
2422 || class == scm_class_simple_method
2423 || class == scm_class_accessor_method
)
2425 SCM_SET_SLOT (z
, scm_si_generic_function
,
2426 scm_i_get_keyword (k_gf
,
2431 SCM_SET_SLOT (z
, scm_si_specializers
,
2432 scm_i_get_keyword (k_specializers
,
2437 SCM_SET_SLOT (z
, scm_si_procedure
,
2438 scm_i_get_keyword (k_procedure
,
2443 SCM_SET_SLOT (z
, scm_si_code_table
, SCM_EOL
);
2444 SCM_SET_SLOT (z
, scm_si_formals
,
2445 scm_i_get_keyword (k_formals
,
2450 SCM_SET_SLOT (z
, scm_si_body
,
2451 scm_i_get_keyword (k_body
,
2456 SCM_SET_SLOT (z
, scm_si_make_procedure
,
2457 scm_i_get_keyword (k_make_procedure
,
2465 /* In all the others case, make a new class .... No instance here */
2466 SCM_SET_SLOT (z
, scm_si_name
,
2467 scm_i_get_keyword (k_name
,
2470 scm_from_locale_symbol ("???"),
2472 SCM_SET_SLOT (z
, scm_si_direct_supers
,
2473 scm_i_get_keyword (k_dsupers
,
2478 SCM_SET_SLOT (z
, scm_si_direct_slots
,
2479 scm_i_get_keyword (k_slots
,
2490 SCM_DEFINE (scm_find_method
, "find-method", 0, 0, 1,
2493 #define FUNC_NAME s_scm_find_method
2496 long len
= scm_ilength (l
);
2499 SCM_WRONG_NUM_ARGS ();
2501 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
2502 SCM_VALIDATE_GENERIC (1, gf
);
2503 if (scm_is_null (SCM_SLOT (gf
, scm_si_methods
)))
2504 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
2506 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
2510 SCM_DEFINE (scm_sys_method_more_specific_p
, "%method-more-specific?", 3, 0, 0,
2511 (SCM m1
, SCM m2
, SCM targs
),
2512 "Return true if method @var{m1} is more specific than @var{m2} "
2513 "given the argument types (classes) listed in @var{targs}.")
2514 #define FUNC_NAME s_scm_sys_method_more_specific_p
2518 long i
, len
, m1_specs
, m2_specs
;
2519 scm_t_array_handle handle
;
2521 SCM_VALIDATE_METHOD (1, m1
);
2522 SCM_VALIDATE_METHOD (2, m2
);
2524 len
= scm_ilength (targs
);
2525 m1_specs
= scm_ilength (SPEC_OF (m1
));
2526 m2_specs
= scm_ilength (SPEC_OF (m2
));
2527 SCM_ASSERT ((len
>= m1_specs
) || (len
>= m2_specs
),
2528 targs
, SCM_ARG3
, FUNC_NAME
);
2530 /* Verify that all the arguments of TARGS are classes and place them
2533 v
= scm_c_make_vector (len
, SCM_EOL
);
2534 v_elts
= scm_vector_writable_elements (v
, &handle
, NULL
, NULL
);
2536 for (i
= 0, l
= targs
;
2537 i
< len
&& scm_is_pair (l
);
2538 i
++, l
= SCM_CDR (l
))
2540 SCM_ASSERT (SCM_CLASSP (SCM_CAR (l
)), targs
, SCM_ARG3
, FUNC_NAME
);
2541 v_elts
[i
] = SCM_CAR (l
);
2543 result
= more_specificp (m1
, m2
, v_elts
) ? SCM_BOOL_T
: SCM_BOOL_F
;
2545 scm_array_handle_release (&handle
);
2553 /******************************************************************************
2557 ******************************************************************************/
2560 fix_cpl (SCM c
, SCM before
, SCM after
)
2562 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2563 SCM ls
= scm_c_memq (after
, cpl
);
2564 SCM tail
= scm_delq1_x (before
, SCM_CDR (ls
));
2565 if (scm_is_false (ls
))
2566 /* if this condition occurs, fix_cpl should not be applied this way */
2568 SCM_SETCAR (ls
, before
);
2569 SCM_SETCDR (ls
, scm_cons (after
, tail
));
2571 SCM dslots
= SCM_SLOT (c
, scm_si_direct_slots
);
2572 SCM slots
= build_slots_list (maplist (dslots
), cpl
);
2573 SCM g_n_s
= compute_getters_n_setters (slots
);
2574 SCM_SET_SLOT (c
, scm_si_slots
, slots
);
2575 SCM_SET_SLOT (c
, scm_si_getters_n_setters
, g_n_s
);
2581 make_stdcls (SCM
*var
, char *name
, SCM meta
, SCM super
, SCM slots
)
2583 SCM tmp
= scm_from_locale_symbol (name
);
2585 *var
= scm_permanent_object (scm_basic_make_class (meta
,
2589 : scm_list_1 (super
),
2595 SCM_KEYWORD (k_slot_definition
, "slot-definition");
2598 create_standard_classes (void)
2601 SCM method_slots
= scm_list_n (scm_from_locale_symbol ("generic-function"),
2602 scm_from_locale_symbol ("specializers"),
2604 scm_from_locale_symbol ("code-table"),
2605 scm_from_locale_symbol ("formals"),
2606 scm_from_locale_symbol ("body"),
2607 scm_from_locale_symbol ("make-procedure"),
2609 SCM amethod_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
2611 k_slot_definition
));
2612 SCM mutex_slot
= scm_list_1 (scm_from_locale_symbol ("make-mutex"));
2613 SCM mutex_closure
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
2617 SCM gf_slots
= scm_list_5 (scm_from_locale_symbol ("methods"),
2618 scm_list_3 (scm_from_locale_symbol ("n-specialized"),
2621 scm_list_3 (scm_from_locale_symbol ("used-by"),
2624 scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
2627 scm_list_3 (scm_from_locale_symbol ("extended-by"),
2630 SCM egf_slots
= scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
2633 /* Foreign class slot classes */
2634 make_stdcls (&scm_class_foreign_slot
, "<foreign-slot>",
2635 scm_class_class
, scm_class_top
, SCM_EOL
);
2636 make_stdcls (&scm_class_protected
, "<protected-slot>",
2637 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2638 make_stdcls (&scm_class_opaque
, "<opaque-slot>",
2639 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2640 make_stdcls (&scm_class_read_only
, "<read-only-slot>",
2641 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2642 make_stdcls (&scm_class_self
, "<self-slot>",
2644 scm_class_read_only
,
2646 make_stdcls (&scm_class_protected_opaque
, "<protected-opaque-slot>",
2648 scm_list_2 (scm_class_protected
, scm_class_opaque
),
2650 make_stdcls (&scm_class_protected_read_only
, "<protected-read-only-slot>",
2652 scm_list_2 (scm_class_protected
, scm_class_read_only
),
2654 make_stdcls (&scm_class_scm
, "<scm-slot>",
2655 scm_class_class
, scm_class_protected
, SCM_EOL
);
2656 make_stdcls (&scm_class_int
, "<int-slot>",
2657 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2658 make_stdcls (&scm_class_float
, "<float-slot>",
2659 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2660 make_stdcls (&scm_class_double
, "<double-slot>",
2661 scm_class_class
, scm_class_foreign_slot
, SCM_EOL
);
2663 /* Continue initialization of class <class> */
2665 slots
= build_class_class_slots ();
2666 SCM_SET_SLOT (scm_class_class
, scm_si_direct_slots
, slots
);
2667 SCM_SET_SLOT (scm_class_class
, scm_si_slots
, slots
);
2668 SCM_SET_SLOT (scm_class_class
, scm_si_getters_n_setters
,
2669 compute_getters_n_setters (slots
));
2671 make_stdcls (&scm_class_foreign_class
, "<foreign-class>",
2672 scm_class_class
, scm_class_class
,
2673 scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
2676 scm_list_3 (scm_from_locale_symbol ("destructor"),
2678 scm_class_opaque
)));
2679 make_stdcls (&scm_class_foreign_object
, "<foreign-object>",
2680 scm_class_foreign_class
, scm_class_object
, SCM_EOL
);
2681 SCM_SET_CLASS_FLAGS (scm_class_foreign_object
, SCM_CLASSF_FOREIGN
);
2683 /* scm_class_generic functions classes */
2684 make_stdcls (&scm_class_procedure_class
, "<procedure-class>",
2685 scm_class_class
, scm_class_class
, SCM_EOL
);
2686 make_stdcls (&scm_class_entity_class
, "<entity-class>",
2687 scm_class_class
, scm_class_procedure_class
, SCM_EOL
);
2688 make_stdcls (&scm_class_method
, "<method>",
2689 scm_class_class
, scm_class_object
, method_slots
);
2690 make_stdcls (&scm_class_simple_method
, "<simple-method>",
2691 scm_class_class
, scm_class_method
, SCM_EOL
);
2692 SCM_SET_CLASS_FLAGS (scm_class_simple_method
, SCM_CLASSF_SIMPLE_METHOD
);
2693 make_stdcls (&scm_class_accessor_method
, "<accessor-method>",
2694 scm_class_class
, scm_class_simple_method
, amethod_slots
);
2695 SCM_SET_CLASS_FLAGS (scm_class_accessor_method
, SCM_CLASSF_ACCESSOR_METHOD
);
2696 make_stdcls (&scm_class_applicable
, "<applicable>",
2697 scm_class_class
, scm_class_top
, SCM_EOL
);
2698 make_stdcls (&scm_class_entity
, "<entity>",
2699 scm_class_entity_class
,
2700 scm_list_2 (scm_class_object
, scm_class_applicable
),
2702 SCM_CLEAR_CLASS_FLAGS (scm_class_entity
, SCM_STRUCTF_LIGHT
);
2703 make_stdcls (&scm_class_entity_with_setter
, "<entity-with-setter>",
2704 scm_class_entity_class
, scm_class_entity
, SCM_EOL
);
2705 SCM_CLEAR_CLASS_FLAGS (scm_class_entity_with_setter
, SCM_STRUCTF_LIGHT
);
2706 make_stdcls (&scm_class_generic
, "<generic>",
2707 scm_class_entity_class
, scm_class_entity
, gf_slots
);
2708 SCM_CLEAR_CLASS_FLAGS (scm_class_generic
, SCM_STRUCTF_LIGHT
);
2709 SCM_SET_CLASS_FLAGS (scm_class_generic
, SCM_CLASSF_PURE_GENERIC
);
2710 make_stdcls (&scm_class_extended_generic
, "<extended-generic>",
2711 scm_class_entity_class
, scm_class_generic
, egf_slots
);
2712 SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic
, SCM_STRUCTF_LIGHT
);
2713 SCM_SET_CLASS_FLAGS (scm_class_extended_generic
, SCM_CLASSF_PURE_GENERIC
);
2714 make_stdcls (&scm_class_generic_with_setter
, "<generic-with-setter>",
2715 scm_class_entity_class
,
2716 scm_list_2 (scm_class_generic
, scm_class_entity_with_setter
),
2718 SCM_CLEAR_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_STRUCTF_LIGHT
);
2719 SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter
, SCM_CLASSF_PURE_GENERIC
);
2720 make_stdcls (&scm_class_accessor
, "<accessor>",
2721 scm_class_entity_class
, scm_class_generic_with_setter
, SCM_EOL
);
2722 SCM_CLEAR_CLASS_FLAGS (scm_class_accessor
, SCM_STRUCTF_LIGHT
);
2723 SCM_SET_CLASS_FLAGS (scm_class_accessor
, SCM_CLASSF_PURE_GENERIC
);
2724 make_stdcls (&scm_class_extended_generic_with_setter
,
2725 "<extended-generic-with-setter>",
2726 scm_class_entity_class
,
2727 scm_list_2 (scm_class_generic_with_setter
,
2728 scm_class_extended_generic
),
2730 SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic_with_setter
, SCM_STRUCTF_LIGHT
);
2731 SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter
,
2732 SCM_CLASSF_PURE_GENERIC
);
2733 make_stdcls (&scm_class_extended_accessor
, "<extended-accessor>",
2734 scm_class_entity_class
,
2735 scm_list_2 (scm_class_accessor
,
2736 scm_class_extended_generic_with_setter
),
2738 fix_cpl (scm_class_extended_accessor
,
2739 scm_class_extended_generic
, scm_class_generic
);
2740 SCM_CLEAR_CLASS_FLAGS (scm_class_extended_accessor
, SCM_STRUCTF_LIGHT
);
2741 SCM_SET_CLASS_FLAGS (scm_class_extended_accessor
, SCM_CLASSF_PURE_GENERIC
);
2743 /* Primitive types classes */
2744 make_stdcls (&scm_class_boolean
, "<boolean>",
2745 scm_class_class
, scm_class_top
, SCM_EOL
);
2746 make_stdcls (&scm_class_char
, "<char>",
2747 scm_class_class
, scm_class_top
, SCM_EOL
);
2748 make_stdcls (&scm_class_list
, "<list>",
2749 scm_class_class
, scm_class_top
, SCM_EOL
);
2750 make_stdcls (&scm_class_pair
, "<pair>",
2751 scm_class_class
, scm_class_list
, SCM_EOL
);
2752 make_stdcls (&scm_class_null
, "<null>",
2753 scm_class_class
, scm_class_list
, SCM_EOL
);
2754 make_stdcls (&scm_class_string
, "<string>",
2755 scm_class_class
, scm_class_top
, SCM_EOL
);
2756 make_stdcls (&scm_class_symbol
, "<symbol>",
2757 scm_class_class
, scm_class_top
, SCM_EOL
);
2758 make_stdcls (&scm_class_vector
, "<vector>",
2759 scm_class_class
, scm_class_top
, SCM_EOL
);
2760 make_stdcls (&scm_class_number
, "<number>",
2761 scm_class_class
, scm_class_top
, SCM_EOL
);
2762 make_stdcls (&scm_class_complex
, "<complex>",
2763 scm_class_class
, scm_class_number
, SCM_EOL
);
2764 make_stdcls (&scm_class_real
, "<real>",
2765 scm_class_class
, scm_class_complex
, SCM_EOL
);
2766 make_stdcls (&scm_class_integer
, "<integer>",
2767 scm_class_class
, scm_class_real
, SCM_EOL
);
2768 make_stdcls (&scm_class_fraction
, "<fraction>",
2769 scm_class_class
, scm_class_real
, SCM_EOL
);
2770 make_stdcls (&scm_class_keyword
, "<keyword>",
2771 scm_class_class
, scm_class_top
, SCM_EOL
);
2772 make_stdcls (&scm_class_unknown
, "<unknown>",
2773 scm_class_class
, scm_class_top
, SCM_EOL
);
2774 make_stdcls (&scm_class_procedure
, "<procedure>",
2775 scm_class_procedure_class
, scm_class_applicable
, SCM_EOL
);
2776 make_stdcls (&scm_class_procedure_with_setter
, "<procedure-with-setter>",
2777 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2778 make_stdcls (&scm_class_primitive_generic
, "<primitive-generic>",
2779 scm_class_procedure_class
, scm_class_procedure
, SCM_EOL
);
2780 make_stdcls (&scm_class_port
, "<port>",
2781 scm_class_class
, scm_class_top
, SCM_EOL
);
2782 make_stdcls (&scm_class_input_port
, "<input-port>",
2783 scm_class_class
, scm_class_port
, SCM_EOL
);
2784 make_stdcls (&scm_class_output_port
, "<output-port>",
2785 scm_class_class
, scm_class_port
, SCM_EOL
);
2786 make_stdcls (&scm_class_input_output_port
, "<input-output-port>",
2788 scm_list_2 (scm_class_input_port
, scm_class_output_port
),
2792 /**********************************************************************
2796 **********************************************************************/
2799 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
2805 sprintf (buffer
, template, type_name
);
2806 name
= scm_from_locale_symbol (buffer
);
2809 name
= SCM_GOOPS_UNBOUND
;
2811 class = scm_permanent_object (scm_basic_make_class (applicablep
2812 ? scm_class_procedure_class
2818 /* Only define name if doesn't already exist. */
2819 if (!SCM_GOOPS_UNBOUNDP (name
)
2820 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2821 DEFVAR (name
, class);
2826 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
2829 if (type_name_sym
!= SCM_BOOL_F
)
2831 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
2832 scm_symbol_to_string (type_name_sym
),
2833 scm_from_locale_string (">")));
2834 name
= scm_string_to_symbol (name
);
2837 name
= SCM_GOOPS_UNBOUND
;
2839 class = scm_permanent_object (scm_basic_make_class (applicablep
2840 ? scm_class_procedure_class
2846 /* Only define name if doesn't already exist. */
2847 if (!SCM_GOOPS_UNBOUNDP (name
)
2848 && scm_is_false (scm_module_variable (scm_module_goops
, name
)))
2849 DEFVAR (name
, class);
2854 scm_make_extended_class (char const *type_name
, int applicablep
)
2856 return make_class_from_template ("<%s>",
2858 scm_list_1 (applicablep
2859 ? scm_class_applicable
2865 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
2867 return make_class_from_symbol (type_name_sym
,
2868 scm_list_1 (applicablep
2869 ? scm_class_applicable
2875 scm_i_inherit_applicable (SCM c
)
2877 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
2879 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
2880 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
2881 /* patch scm_class_applicable into direct-supers */
2882 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
2883 if (scm_is_false (top
))
2884 dsupers
= scm_append (scm_list_2 (dsupers
,
2885 scm_list_1 (scm_class_applicable
)));
2888 SCM_SETCAR (top
, scm_class_applicable
);
2889 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2891 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
2892 /* patch scm_class_applicable into cpl */
2893 top
= scm_c_memq (scm_class_top
, cpl
);
2894 if (scm_is_false (top
))
2898 SCM_SETCAR (top
, scm_class_applicable
);
2899 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
2901 /* add class to direct-subclasses of scm_class_applicable */
2902 SCM_SET_SLOT (scm_class_applicable
,
2903 scm_si_direct_subclasses
,
2904 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
2905 scm_si_direct_subclasses
)));
2910 create_smob_classes (void)
2914 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
2915 scm_smob_class
[i
] = 0;
2917 scm_smob_class
[SCM_TC2SMOBNUM (scm_tc16_keyword
)] = scm_class_keyword
;
2919 for (i
= 0; i
< scm_numsmob
; ++i
)
2920 if (!scm_smob_class
[i
])
2921 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
2922 scm_smobs
[i
].apply
!= 0);
2926 scm_make_port_classes (long ptobnum
, char *type_name
)
2928 SCM c
, class = make_class_from_template ("<%s-port>",
2930 scm_list_1 (scm_class_port
),
2932 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
2933 = make_class_from_template ("<%s-input-port>",
2935 scm_list_2 (class, scm_class_input_port
),
2937 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
2938 = make_class_from_template ("<%s-output-port>",
2940 scm_list_2 (class, scm_class_output_port
),
2942 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
2944 = make_class_from_template ("<%s-input-output-port>",
2946 scm_list_2 (class, scm_class_input_output_port
),
2948 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
2949 SCM_SET_SLOT (c
, scm_si_cpl
,
2950 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
2954 create_port_classes (void)
2958 for (i
= 0; i
< scm_numptob
; ++i
)
2959 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
2963 make_struct_class (void *closure SCM_UNUSED
,
2964 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
2966 SCM sym
= SCM_STRUCT_TABLE_NAME (data
);
2967 if (scm_is_true (sym
))
2969 int applicablep
= 0; /* FIXME SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY */
2971 SCM_SET_STRUCT_TABLE_CLASS (data
,
2972 scm_make_extended_class_from_symbol (sym
, applicablep
));
2975 scm_remember_upto_here_2 (data
, vtable
);
2976 return SCM_UNSPECIFIED
;
2980 create_struct_classes (void)
2982 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
, scm_struct_table
);
2985 /**********************************************************************
2989 **********************************************************************/
2994 if (!goops_loaded_p
)
2995 scm_c_resolve_module ("oop goops");
3000 scm_make_foreign_object (SCM
class, SCM initargs
)
3001 #define FUNC_NAME s_scm_make
3003 void * (*constructor
) (SCM
)
3004 = (void * (*) (SCM
)) SCM_SLOT (class, scm_si_constructor
);
3005 if (constructor
== 0)
3006 SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
3007 return scm_wrap_object (class, constructor (initargs
));
3013 scm_free_foreign_object (SCM
*class, SCM
*data
)
3015 size_t (*destructor
) (void *)
3016 = (size_t (*) (void *)) class[scm_si_destructor
];
3017 return destructor (data
);
3021 scm_make_class (SCM meta
, char *s_name
, SCM supers
, size_t size
,
3022 void * (*constructor
) (SCM initargs
),
3023 size_t (*destructor
) (void *))
3026 name
= scm_from_locale_symbol (s_name
);
3027 if (scm_is_null (supers
))
3028 supers
= scm_list_1 (scm_class_foreign_object
);
3029 class = scm_basic_basic_make_class (meta
, name
, supers
, SCM_EOL
);
3030 scm_sys_inherit_magic_x (class, supers
);
3032 if (destructor
!= 0)
3034 SCM_SET_SLOT (class, scm_si_destructor
, (SCM
) destructor
);
3035 SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object
);
3038 SCM_SET_SLOT (class, scm_si_layout
, scm_from_locale_symbol (""));
3039 SCM_SET_SLOT (class, scm_si_constructor
, (SCM
) constructor
);
3044 SCM_SYMBOL (sym_o
, "o");
3045 SCM_SYMBOL (sym_x
, "x");
3047 SCM_KEYWORD (k_accessor
, "accessor");
3048 SCM_KEYWORD (k_getter
, "getter");
3051 default_setter (SCM obj SCM_UNUSED
, SCM c SCM_UNUSED
)
3053 scm_misc_error ("slot-set!", "read-only slot", SCM_EOL
);
3058 scm_add_slot (SCM
class, char *slot_name
, SCM slot_class
,
3059 SCM (*getter
) (SCM obj
),
3060 SCM (*setter
) (SCM obj
, SCM x
),
3061 char *accessor_name
)
3064 SCM get
= scm_c_make_subr ("goops:get", scm_tc7_subr_1
, getter
);
3065 SCM set
= scm_c_make_subr ("goops:set", scm_tc7_subr_2
,
3066 setter
? setter
: default_setter
);
3068 /* Dirk:FIXME:: The following two expressions make use of the fact that
3069 * the memoizer will accept a subr-object in the place of a function.
3070 * This is not guaranteed to stay this way. */
3071 SCM getm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
3073 scm_list_2 (get
, sym_o
)),
3075 SCM setm
= scm_i_eval_x (scm_list_3 (scm_sym_lambda
,
3076 scm_list_2 (sym_o
, sym_x
),
3077 scm_list_3 (set
, sym_o
, sym_x
)),
3081 SCM name
= scm_from_locale_symbol (slot_name
);
3082 SCM aname
= scm_from_locale_symbol (accessor_name
);
3083 SCM gf
= scm_ensure_accessor (aname
);
3084 SCM slot
= scm_list_5 (name
,
3087 setter
? k_accessor
: k_getter
,
3089 scm_add_method (gf
, scm_make (scm_list_5 (scm_class_accessor_method
,
3094 scm_add_method (scm_setter (gf
),
3095 scm_make (scm_list_5 (scm_class_accessor_method
,
3097 scm_list_2 (class, scm_class_top
),
3102 SCM_SET_SLOT (class, scm_si_slots
,
3103 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots
),
3104 scm_list_1 (slot
))));
3106 SCM n
= SCM_SLOT (class, scm_si_nfields
);
3107 SCM gns
= scm_list_n (name
, SCM_BOOL_F
, get
, set
, n
, scm_from_int (1),
3109 SCM_SET_SLOT (class, scm_si_getters_n_setters
,
3110 scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters
),
3111 scm_list_1 (gns
))));
3112 SCM_SET_SLOT (class, scm_si_nfields
, scm_sum (n
, scm_from_int (1)));
3119 scm_wrap_object (SCM
class, void *data
)
3121 return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct
,
3129 scm_wrap_component (SCM
class, SCM container
, void *data
)
3131 SCM obj
= scm_wrap_object (class, data
);
3132 SCM handle
= scm_hash_fn_create_handle_x (scm_components
,
3136 (scm_t_assoc_fn
) scm_sloppy_assq
,
3138 SCM_SETCDR (handle
, container
);
3143 scm_ensure_accessor (SCM name
)
3145 SCM gf
= scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE
, name
, SCM_BOOL_F
);
3146 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
3148 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
3149 gf
= scm_make (scm_list_5 (scm_class_accessor
,
3150 k_name
, name
, k_setter
, gf
));
3155 SCM_SYMBOL (sym_internal_add_method_x
, "internal-add-method!");
3158 scm_add_method (SCM gf
, SCM m
)
3160 scm_eval (scm_list_3 (sym_internal_add_method_x
, gf
, m
), scm_module_goops
);
3165 * Debugging utilities
3168 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
3170 "Return @code{#t} if @var{obj} is a pure generic.")
3171 #define FUNC_NAME s_scm_pure_generic_p
3173 return scm_from_bool (SCM_PUREGENERICP (obj
));
3177 #endif /* GUILE_DEBUG */
3183 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
3185 "Announce that GOOPS is loaded and perform initialization\n"
3186 "on the C level which depends on the loaded GOOPS modules.")
3187 #define FUNC_NAME s_scm_sys_goops_loaded
3190 var_compute_applicable_methods
=
3191 scm_permanent_object
3192 (scm_module_variable (scm_module_goops
, sym_compute_applicable_methods
));
3194 scm_permanent_object
3195 (scm_module_variable (scm_module_goops
, sym_slot_unbound
));
3197 scm_permanent_object
3198 (scm_module_variable (scm_module_goops
, sym_slot_missing
));
3200 scm_permanent_object
3201 (scm_module_variable (scm_module_goops
, sym_compute_cpl
));
3202 var_no_applicable_method
=
3203 scm_permanent_object
3204 (scm_module_variable (scm_module_goops
, sym_no_applicable_method
));
3206 scm_permanent_object
3207 (scm_module_variable (scm_module_goops
, sym_change_class
));
3208 setup_extended_primitive_generics ();
3209 return SCM_UNSPECIFIED
;
3213 SCM scm_module_goops
;
3216 scm_init_goops_builtins (void)
3218 scm_module_goops
= scm_current_module ();
3220 /* Not really necessary right now, but who knows...
3222 scm_permanent_object (scm_module_goops
);
3224 scm_components
= scm_permanent_object (scm_make_weak_key_hash_table
3225 (scm_from_int (37)));
3227 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
3229 #include "libguile/goops.x"
3231 list_of_no_method
= scm_permanent_object (scm_list_1 (sym_no_method
));
3233 hell
= scm_calloc (hell_size
* sizeof (*hell
));
3234 hell_mutex
= scm_permanent_object (scm_make_mutex ());
3236 create_basic_classes ();
3237 create_standard_classes ();
3238 create_smob_classes ();
3239 create_struct_classes ();
3240 create_port_classes ();
3243 SCM name
= scm_from_locale_symbol ("no-applicable-method");
3244 scm_no_applicable_method
3245 = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic
,
3248 DEFVAR (name
, scm_no_applicable_method
);
3251 return SCM_UNSPECIFIED
;
3257 scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
3258 scm_init_goops_builtins
);