1 /* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
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>.
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/chars.h"
38 #include "libguile/debug.h"
39 #include "libguile/dynl.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eval.h"
42 #include "libguile/gsubr.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/vm.h"
58 #include "libguile/validate.h"
59 #include "libguile/goops.h"
62 #define SCM_IN_PCLASS_INDEX 0
63 #define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
64 #define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
66 /* Objects have identity, so references to classes and instances are by
67 value, not by reference. Redefinition of a class or modification of
68 an instance causes in-place update; you can think of GOOPS as
69 building in its own indirection, and for that reason referring to
70 GOOPS values by variable reference is unnecessary.
72 References to ordinary procedures is by reference (by variable),
73 though, as in the rest of Guile. */
75 static SCM var_make_standard_class
= SCM_BOOL_F
;
76 static SCM var_slot_unbound
= SCM_BOOL_F
;
77 static SCM var_slot_missing
= SCM_BOOL_F
;
78 static SCM var_no_applicable_method
= SCM_BOOL_F
;
79 static SCM var_change_class
= SCM_BOOL_F
;
80 static SCM var_make
= SCM_BOOL_F
;
82 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
83 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
84 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
85 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
86 SCM_SYMBOL (sym_change_class
, "change-class");
88 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
91 /* Class redefinition protocol:
93 A class is represented by a heap header h1 which points to a
94 malloc:ed memory block m1.
96 When a new version of a class is created, a new header h2 and
97 memory block m2 are allocated. The headers h1 and h2 then switch
98 pointers so that h1 refers to m2 and h2 to m1. In this way, names
99 bound to h1 will point to the new class at the same time as h2 will
100 be a handle which the GC will use to free m1.
102 The `redefined' slot of m1 will be set to point to h1. An old
103 instance will have its class pointer (the CAR of the heap header)
104 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
105 the class modification and the new class pointer can be found via
109 #define TEST_CHANGE_CLASS(obj, class) \
111 class = SCM_CLASS_OF (obj); \
112 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
114 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
115 class = SCM_CLASS_OF (obj); \
119 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
120 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
122 static int goops_loaded_p
= 0;
123 static scm_t_rstate
*goops_rstate
;
125 /* These variables are filled in by the object system when loaded. */
126 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
127 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
128 SCM scm_class_primitive_generic
;
129 SCM scm_class_vector
, scm_class_null
;
130 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
131 SCM scm_class_unknown
;
132 SCM scm_class_top
, scm_class_object
, scm_class_class
;
133 SCM scm_class_applicable
;
134 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
135 SCM scm_class_generic
, scm_class_generic_with_setter
;
136 SCM scm_class_accessor
;
137 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
138 SCM scm_class_extended_accessor
;
139 SCM scm_class_method
;
140 SCM scm_class_accessor_method
;
141 SCM scm_class_procedure_class
;
142 SCM scm_class_applicable_struct_class
;
143 static SCM scm_class_applicable_struct_with_setter_class
;
144 SCM scm_class_number
, scm_class_list
;
145 SCM scm_class_keyword
;
146 SCM scm_class_port
, scm_class_input_output_port
;
147 SCM scm_class_input_port
, scm_class_output_port
;
148 SCM scm_class_foreign_slot
;
149 SCM scm_class_self
, scm_class_protected
;
150 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
151 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
153 SCM scm_class_int
, scm_class_float
, scm_class_double
;
155 static SCM class_foreign
;
156 static SCM class_hashtable
;
157 static SCM class_fluid
;
158 static SCM class_dynamic_state
;
159 static SCM class_frame
;
160 static SCM class_vm_cont
;
161 static SCM class_bytevector
;
162 static SCM class_uvec
;
163 static SCM class_array
;
164 static SCM class_bitvector
;
166 static SCM vtable_class_map
= SCM_BOOL_F
;
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 static SCM
scm_make_unbound (void);
177 static SCM
scm_unbound_p (SCM obj
);
178 static SCM
scm_assert_bound (SCM value
, SCM obj
);
179 static SCM
scm_at_assert_bound_ref (SCM obj
, SCM index
);
180 static SCM
scm_sys_bless_applicable_struct_vtables_x (SCM applicable
,
182 static SCM
scm_sys_bless_pure_generic_vtable_x (SCM vtable
);
183 static SCM
scm_sys_make_root_class (SCM name
, SCM dslots
,
184 SCM getters_n_setters
);
185 static SCM
scm_sys_init_layout_x (SCM
class, SCM layout
);
186 static SCM
scm_sys_goops_early_init (void);
187 static SCM
scm_sys_goops_loaded (void);
190 /* This function is used for efficient type dispatch. */
191 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
193 "Return the class of @var{x}.")
194 #define FUNC_NAME s_scm_class_of
196 switch (SCM_ITAG3 (x
))
200 return scm_class_integer
;
204 return scm_class_char
;
205 else if (scm_is_bool (x
))
206 return scm_class_boolean
;
207 else if (scm_is_null (x
))
208 return scm_class_null
;
210 return scm_class_unknown
;
213 switch (SCM_TYP7 (x
))
215 case scm_tcs_cons_nimcar
:
216 return scm_class_pair
;
218 return scm_class_symbol
;
221 return scm_class_vector
;
222 case scm_tc7_pointer
:
223 return class_foreign
;
224 case scm_tc7_hashtable
:
225 return class_hashtable
;
228 case scm_tc7_dynamic_state
:
229 return class_dynamic_state
;
232 case scm_tc7_keyword
:
233 return scm_class_keyword
;
234 case scm_tc7_vm_cont
:
235 return class_vm_cont
;
236 case scm_tc7_bytevector
:
237 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
238 return class_bytevector
;
243 case scm_tc7_bitvector
:
244 return class_bitvector
;
246 return scm_class_string
;
248 switch SCM_TYP16 (x
) {
250 return scm_class_integer
;
252 return scm_class_real
;
253 case scm_tc16_complex
:
254 return scm_class_complex
;
255 case scm_tc16_fraction
:
256 return scm_class_fraction
;
258 case scm_tc7_program
:
259 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
260 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
261 return scm_class_primitive_generic
;
263 return scm_class_procedure
;
267 scm_t_bits type
= SCM_TYP16 (x
);
268 if (type
!= scm_tc16_port_with_ps
)
269 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
270 x
= SCM_PORT_WITH_PS_PORT (x
);
271 /* fall through to ports */
274 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
275 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
276 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
277 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
278 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
280 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
281 return SCM_CLASS_OF (x
);
282 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
285 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
286 scm_change_object_class (x
,
287 SCM_CLASS_OF (x
), /* old */
288 SCM_OBJ_CLASS_REDEF (x
)); /* new */
289 return SCM_CLASS_OF (x
);
292 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
295 return scm_class_pair
;
297 return scm_class_unknown
;
303 /* case scm_tc3_unused: */
307 return scm_class_unknown
;
311 /******************************************************************************
315 ******************************************************************************/
317 /*fixme* Manufacture keywords in advance */
319 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
323 for (i
= 0; i
!= len
; i
+= 2)
325 SCM obj
= SCM_CAR (l
);
327 if (!scm_is_keyword (obj
))
328 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
329 else if (scm_is_eq (obj
, key
))
335 return default_value
;
339 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
340 (SCM key
, SCM l
, SCM default_value
),
341 "Determine an associated value for the keyword @var{key} from\n"
342 "the list @var{l}. The list @var{l} has to consist of an even\n"
343 "number of elements, where, starting with the first, every\n"
344 "second element is a keyword, followed by its associated value.\n"
345 "If @var{l} does not hold a value for @var{key}, the value\n"
346 "@var{default_value} is returned.")
347 #define FUNC_NAME s_scm_get_keyword
351 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
352 len
= scm_ilength (l
);
353 if (len
< 0 || len
% 2 == 1)
354 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
356 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
361 SCM_KEYWORD (k_init_keyword
, "init-keyword");
363 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
364 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
366 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
367 (SCM obj
, SCM initargs
),
368 "Initialize the object @var{obj} with the given arguments\n"
370 #define FUNC_NAME s_scm_sys_initialize_object
372 SCM tmp
, get_n_set
, slots
;
373 SCM
class = SCM_CLASS_OF (obj
);
376 SCM_VALIDATE_INSTANCE (1, obj
);
377 n_initargs
= scm_ilength (initargs
);
378 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
380 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
381 slots
= SCM_SLOT (class, scm_si_slots
);
383 /* See for each slot how it must be initialized */
385 !scm_is_null (slots
);
386 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
388 SCM slot_name
= SCM_CAR (slots
);
389 SCM slot_value
= SCM_GOOPS_UNBOUND
;
391 if (!scm_is_null (SCM_CDR (slot_name
)))
393 /* This slot admits (perhaps) to be initialized at creation time */
394 long n
= scm_ilength (SCM_CDR (slot_name
));
395 if (n
& 1) /* odd or -1 */
396 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
397 scm_list_1 (slot_name
));
398 tmp
= scm_i_get_keyword (k_init_keyword
,
403 slot_name
= SCM_CAR (slot_name
);
404 if (SCM_UNPACK (tmp
))
406 /* an initarg was provided for this slot */
407 if (!scm_is_keyword (tmp
))
408 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
410 slot_value
= scm_i_get_keyword (tmp
,
418 if (!SCM_GOOPS_UNBOUNDP (slot_value
))
419 /* set slot to provided value */
420 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
423 /* set slot to its :init-form if it exists */
424 tmp
= SCM_CADAR (get_n_set
);
425 if (scm_is_true (tmp
))
426 set_slot_value (class,
437 SCM_DEFINE (scm_sys_init_layout_x
, "%init-layout!", 2, 0, 0,
438 (SCM
class, SCM layout
),
440 #define FUNC_NAME s_scm_sys_init_layout_x
442 SCM_VALIDATE_INSTANCE (1, class);
443 SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME
);
444 SCM_VALIDATE_STRING (2, layout
);
446 SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout
));
447 return SCM_UNSPECIFIED
;
451 static void prep_hashsets (SCM
);
453 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
454 (SCM
class, SCM dsupers
),
456 #define FUNC_NAME s_scm_sys_inherit_magic_x
458 SCM_VALIDATE_INSTANCE (1, class);
459 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
460 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
462 prep_hashsets (class);
464 return SCM_UNSPECIFIED
;
469 prep_hashsets (SCM
class)
473 for (i
= 0; i
< 8; ++i
)
474 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
477 /******************************************************************************/
480 scm_make_standard_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
482 return scm_call_4 (scm_variable_ref (var_make_standard_class
),
483 meta
, name
, dsupers
, dslots
);
486 /******************************************************************************/
488 SCM_DEFINE (scm_sys_make_root_class
, "%make-root-class", 3, 0, 0,
489 (SCM name
, SCM dslots
, SCM getters_n_setters
),
491 #define FUNC_NAME s_scm_sys_make_root_class
495 cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
496 z
= scm_i_make_vtable_vtable (cs
);
497 SCM_SET_CLASS_FLAGS (z
, (SCM_CLASSF_GOOPS_OR_VALID
498 | SCM_CLASSF_METACLASS
));
500 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
501 SCM_SET_SLOT (z
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
502 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
); /* will be changed */
503 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
504 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
505 SCM_SET_SLOT (z
, scm_si_cpl
, SCM_EOL
); /* will be changed */
506 SCM_SET_SLOT (z
, scm_si_slots
, dslots
); /* will be changed */
507 SCM_SET_SLOT (z
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
508 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, getters_n_setters
); /* will be changed */
509 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
517 /******************************************************************************/
519 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
521 "Return @code{#t} if @var{obj} is an instance.")
522 #define FUNC_NAME s_scm_instance_p
524 return scm_from_bool (SCM_INSTANCEP (obj
));
529 /******************************************************************************
531 * Meta object accessors
533 ******************************************************************************/
535 SCM_SYMBOL (sym_procedure
, "procedure");
536 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
537 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
538 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
539 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
540 SCM_SYMBOL (sym_cpl
, "cpl");
541 SCM_SYMBOL (sym_slots
, "slots");
543 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
545 "Return the class name of @var{obj}.")
546 #define FUNC_NAME s_scm_class_name
548 SCM_VALIDATE_CLASS (1, obj
);
549 return scm_slot_ref (obj
, scm_sym_name
);
553 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
555 "Return the direct superclasses of the class @var{obj}.")
556 #define FUNC_NAME s_scm_class_direct_supers
558 SCM_VALIDATE_CLASS (1, obj
);
559 return scm_slot_ref (obj
, sym_direct_supers
);
563 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
565 "Return the direct slots of the class @var{obj}.")
566 #define FUNC_NAME s_scm_class_direct_slots
568 SCM_VALIDATE_CLASS (1, obj
);
569 return scm_slot_ref (obj
, sym_direct_slots
);
573 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
575 "Return the direct subclasses of the class @var{obj}.")
576 #define FUNC_NAME s_scm_class_direct_subclasses
578 SCM_VALIDATE_CLASS (1, obj
);
579 return scm_slot_ref(obj
, sym_direct_subclasses
);
583 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
585 "Return the direct methods of the class @var{obj}")
586 #define FUNC_NAME s_scm_class_direct_methods
588 SCM_VALIDATE_CLASS (1, obj
);
589 return scm_slot_ref (obj
, sym_direct_methods
);
593 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
595 "Return the class precedence list of the class @var{obj}.")
596 #define FUNC_NAME s_scm_class_precedence_list
598 SCM_VALIDATE_CLASS (1, obj
);
599 return scm_slot_ref (obj
, sym_cpl
);
603 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
605 "Return the slot list of the class @var{obj}.")
606 #define FUNC_NAME s_scm_class_slots
608 SCM_VALIDATE_CLASS (1, obj
);
609 return scm_slot_ref (obj
, sym_slots
);
613 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
615 "Return the name of the generic function @var{obj}.")
616 #define FUNC_NAME s_scm_generic_function_name
618 SCM_VALIDATE_GENERIC (1, obj
);
619 return scm_procedure_property (obj
, scm_sym_name
);
623 SCM_SYMBOL (sym_methods
, "methods");
624 SCM_SYMBOL (sym_extended_by
, "extended-by");
625 SCM_SYMBOL (sym_extends
, "extends");
628 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
630 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
631 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
632 while (!scm_is_null (gfs
))
634 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
641 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
643 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
645 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
646 while (!scm_is_null (gfs
))
648 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
649 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
658 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
660 "Return the methods of the generic function @var{obj}.")
661 #define FUNC_NAME s_scm_generic_function_methods
664 SCM_VALIDATE_GENERIC (1, obj
);
665 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
666 methods
= fold_downward_gf_methods (methods
, obj
);
667 return scm_append (methods
);
671 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
673 "Return the generic function for the method @var{obj}.")
674 #define FUNC_NAME s_scm_method_generic_function
676 SCM_VALIDATE_METHOD (1, obj
);
677 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
681 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
683 "Return specializers of the method @var{obj}.")
684 #define FUNC_NAME s_scm_method_specializers
686 SCM_VALIDATE_METHOD (1, obj
);
687 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
691 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
693 "Return the procedure of the method @var{obj}.")
694 #define FUNC_NAME s_scm_method_procedure
696 SCM_VALIDATE_METHOD (1, obj
);
697 return scm_slot_ref (obj
, sym_procedure
);
701 /******************************************************************************
703 * S l o t a c c e s s
705 ******************************************************************************/
707 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
709 "Return the unbound value.")
710 #define FUNC_NAME s_scm_make_unbound
712 return SCM_GOOPS_UNBOUND
;
716 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
718 "Return @code{#t} if @var{obj} is unbound.")
719 #define FUNC_NAME s_scm_unbound_p
721 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
725 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
726 (SCM value
, SCM obj
),
727 "Return @var{value} if it is bound, and invoke the\n"
728 "@var{slot-unbound} method of @var{obj} if it is not.")
729 #define FUNC_NAME s_scm_assert_bound
731 if (SCM_GOOPS_UNBOUNDP (value
))
732 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
737 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
738 (SCM obj
, SCM index
),
739 "Like @code{assert-bound}, but use @var{index} for accessing\n"
740 "the value from @var{obj}.")
741 #define FUNC_NAME s_scm_at_assert_bound_ref
743 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
744 if (SCM_GOOPS_UNBOUNDP (value
))
745 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
754 /* In the future, this function will return the effective slot
755 * definition associated with SLOT_NAME. Now it just returns some of
756 * the information which will be stored in the effective slot
761 slot_definition_using_name (SCM
class, SCM slot_name
)
763 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
764 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
765 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
766 return SCM_CAR (slots
);
771 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
772 #define FUNC_NAME "%get-slot-value"
774 SCM access
= SCM_CDDR (slotdef
);
776 * - access is an integer (the offset of this slot in the slots vector)
777 * - otherwise (car access) is the getter function to apply
779 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
780 * we can just assume fixnums here.
782 if (SCM_I_INUMP (access
))
783 /* Don't poke at the slots directly, because scm_struct_ref handles the
784 access bits for us. */
785 return scm_struct_ref (obj
, access
);
787 return scm_call_1 (SCM_CAR (access
), obj
);
792 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
794 SCM slotdef
= slot_definition_using_name (class, slot_name
);
795 if (scm_is_true (slotdef
))
796 return get_slot_value (class, obj
, slotdef
);
798 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
802 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
803 #define FUNC_NAME "%set-slot-value"
805 SCM access
= SCM_CDDR (slotdef
);
807 * - access is an integer (the offset of this slot in the slots vector)
808 * - otherwise (cadr access) is the setter function to apply
810 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
811 * we can just assume fixnums here.
813 if (SCM_I_INUMP (access
))
814 /* obey permissions bits via going through struct-set! */
815 scm_struct_set_x (obj
, access
, value
);
817 /* ((cadr l) obj value) */
818 scm_call_2 (SCM_CADR (access
), obj
, value
);
819 return SCM_UNSPECIFIED
;
824 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
826 SCM slotdef
= slot_definition_using_name (class, slot_name
);
827 if (scm_is_true (slotdef
))
828 return set_slot_value (class, obj
, slotdef
, value
);
830 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
834 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
838 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
839 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
845 /* ======================================== */
847 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
848 (SCM
class, SCM obj
, SCM slot_name
),
850 #define FUNC_NAME s_scm_slot_ref_using_class
854 SCM_VALIDATE_CLASS (1, class);
855 SCM_VALIDATE_INSTANCE (2, obj
);
856 SCM_VALIDATE_SYMBOL (3, slot_name
);
858 res
= get_slot_value_using_name (class, obj
, slot_name
);
859 if (SCM_GOOPS_UNBOUNDP (res
))
860 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
866 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
867 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
869 #define FUNC_NAME s_scm_slot_set_using_class_x
871 SCM_VALIDATE_CLASS (1, class);
872 SCM_VALIDATE_INSTANCE (2, obj
);
873 SCM_VALIDATE_SYMBOL (3, slot_name
);
875 return set_slot_value_using_name (class, obj
, slot_name
, value
);
880 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
881 (SCM
class, SCM obj
, SCM slot_name
),
883 #define FUNC_NAME s_scm_slot_bound_using_class_p
885 SCM_VALIDATE_CLASS (1, class);
886 SCM_VALIDATE_INSTANCE (2, obj
);
887 SCM_VALIDATE_SYMBOL (3, slot_name
);
889 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
895 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
896 (SCM
class, SCM obj
, SCM slot_name
),
898 #define FUNC_NAME s_scm_slot_exists_using_class_p
900 SCM_VALIDATE_CLASS (1, class);
901 SCM_VALIDATE_INSTANCE (2, obj
);
902 SCM_VALIDATE_SYMBOL (3, slot_name
);
903 return test_slot_existence (class, obj
, slot_name
);
908 /* ======================================== */
910 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
911 (SCM obj
, SCM slot_name
),
912 "Return the value from @var{obj}'s slot with the name\n"
914 #define FUNC_NAME s_scm_slot_ref
918 SCM_VALIDATE_INSTANCE (1, obj
);
919 TEST_CHANGE_CLASS (obj
, class);
921 res
= get_slot_value_using_name (class, obj
, slot_name
);
922 if (SCM_GOOPS_UNBOUNDP (res
))
923 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
928 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
929 (SCM obj
, SCM slot_name
, SCM value
),
930 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
931 #define FUNC_NAME s_scm_slot_set_x
935 SCM_VALIDATE_INSTANCE (1, obj
);
936 TEST_CHANGE_CLASS(obj
, class);
938 return set_slot_value_using_name (class, obj
, slot_name
, value
);
942 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
943 (SCM obj
, SCM slot_name
),
944 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
946 #define FUNC_NAME s_scm_slot_bound_p
950 SCM_VALIDATE_INSTANCE (1, obj
);
951 TEST_CHANGE_CLASS(obj
, class);
953 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
961 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
962 (SCM obj
, SCM slot_name
),
963 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
964 #define FUNC_NAME s_scm_slot_exists_p
968 SCM_VALIDATE_INSTANCE (1, obj
);
969 SCM_VALIDATE_SYMBOL (2, slot_name
);
970 TEST_CHANGE_CLASS (obj
, class);
972 return test_slot_existence (class, obj
, slot_name
);
977 /******************************************************************************
979 * %allocate-instance (the low level instance allocation primitive)
981 ******************************************************************************/
983 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
984 (SCM
class, SCM initargs
),
985 "Create a new instance of class @var{class} and initialize it\n"
986 "from the arguments @var{initargs}.")
987 #define FUNC_NAME s_scm_sys_allocate_instance
990 scm_t_signed_bits n
, i
;
993 SCM_VALIDATE_CLASS (1, class);
995 /* FIXME: duplicates some of scm_make_struct. */
997 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
998 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1000 layout
= SCM_VTABLE_LAYOUT (class);
1002 /* Set all SCM-holding slots to unbound */
1003 for (i
= 0; i
< n
; i
++)
1005 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1007 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1009 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1011 SCM_STRUCT_DATA (obj
)[i
] = 0;
1018 /******************************************************************************
1020 * %modify-instance (used by change-class to modify in place)
1022 ******************************************************************************/
1024 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1027 #define FUNC_NAME s_scm_sys_modify_instance
1029 SCM_VALIDATE_INSTANCE (1, old
);
1030 SCM_VALIDATE_INSTANCE (2, new);
1032 /* Exchange the data contained in old and new. We exchange rather than
1033 * scratch the old value with new to be correct with GC.
1034 * See "Class redefinition protocol above".
1036 SCM_CRITICAL_SECTION_START
;
1038 scm_t_bits word0
, word1
;
1039 word0
= SCM_CELL_WORD_0 (old
);
1040 word1
= SCM_CELL_WORD_1 (old
);
1041 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1042 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1043 SCM_SET_CELL_WORD_0 (new, word0
);
1044 SCM_SET_CELL_WORD_1 (new, word1
);
1046 SCM_CRITICAL_SECTION_END
;
1047 return SCM_UNSPECIFIED
;
1051 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1054 #define FUNC_NAME s_scm_sys_modify_class
1056 SCM_VALIDATE_CLASS (1, old
);
1057 SCM_VALIDATE_CLASS (2, new);
1059 SCM_CRITICAL_SECTION_START
;
1061 scm_t_bits word0
, word1
;
1062 word0
= SCM_CELL_WORD_0 (old
);
1063 word1
= SCM_CELL_WORD_1 (old
);
1064 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1065 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1066 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1067 SCM_SET_CELL_WORD_0 (new, word0
);
1068 SCM_SET_CELL_WORD_1 (new, word1
);
1069 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1071 SCM_CRITICAL_SECTION_END
;
1072 return SCM_UNSPECIFIED
;
1076 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1079 #define FUNC_NAME s_scm_sys_invalidate_class
1081 SCM_VALIDATE_CLASS (1, class);
1082 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1083 return SCM_UNSPECIFIED
;
1087 /* When instances change class, they finally get a new body, but
1088 * before that, they go through purgatory in hell. Odd as it may
1089 * seem, this data structure saves us from eternal suffering in
1090 * infinite recursions.
1093 static scm_t_bits
**hell
;
1094 static long n_hell
= 1; /* one place for the evil one himself */
1095 static long hell_size
= 4;
1096 static SCM hell_mutex
;
1102 for (i
= 1; i
< n_hell
; ++i
)
1103 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1109 go_to_hell (void *o
)
1112 scm_lock_mutex (hell_mutex
);
1113 if (n_hell
>= hell_size
)
1116 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1118 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1119 scm_unlock_mutex (hell_mutex
);
1123 go_to_heaven (void *o
)
1126 scm_lock_mutex (hell_mutex
);
1127 hell
[burnin (obj
)] = hell
[--n_hell
];
1128 scm_unlock_mutex (hell_mutex
);
1132 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1135 purgatory (SCM obj
, SCM new_class
)
1137 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1140 /* This function calls the generic function change-class for all
1141 * instances which aren't currently undergoing class change.
1145 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1149 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1150 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1151 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1152 purgatory (obj
, new_class
);
1157 /******************************************************************************
1163 * GGG E N E R I C F U N C T I O N S
1165 * This implementation provides
1166 * - generic functions (with class specializers)
1169 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1171 ******************************************************************************/
1173 SCM_KEYWORD (k_name
, "name");
1174 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1176 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1179 #define FUNC_NAME s_scm_generic_capability_p
1181 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1182 proc
, SCM_ARG1
, FUNC_NAME
);
1183 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1187 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1190 #define FUNC_NAME s_scm_enable_primitive_generic_x
1192 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1193 while (!scm_is_null (subrs
))
1195 SCM subr
= SCM_CAR (subrs
);
1196 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1197 SCM_SET_SUBR_GENERIC (subr
,
1198 scm_make (scm_list_3 (scm_class_generic
,
1200 SCM_SUBR_NAME (subr
))));
1201 subrs
= SCM_CDR (subrs
);
1203 return SCM_UNSPECIFIED
;
1207 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1208 (SCM subr
, SCM generic
),
1210 #define FUNC_NAME s_scm_set_primitive_generic_x
1212 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1213 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1214 SCM_SET_SUBR_GENERIC (subr
, generic
);
1215 return SCM_UNSPECIFIED
;
1219 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1222 #define FUNC_NAME s_scm_primitive_generic_generic
1224 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1226 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1227 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1228 return *SCM_SUBR_GENERIC (subr
);
1230 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1234 typedef struct t_extension
{
1235 struct t_extension
*next
;
1241 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1243 static const char extension_gc_hint
[] = "GOOPS extension";
1245 static t_extension
*extensions
= 0;
1248 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1253 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1254 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1255 gf
= *SCM_SUBR_GENERIC (extended
);
1256 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1258 SCM_SUBR_NAME (extension
));
1259 SCM_SET_SUBR_GENERIC (extension
, gext
);
1263 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1265 t_extension
**loc
= &extensions
;
1266 /* Make sure that extensions are placed before their own
1267 * extensions in the extensions list. O(N^2) algorithm, but
1268 * extensions of primitive generics are rare.
1270 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1271 loc
= &(*loc
)->next
;
1273 e
->extended
= extended
;
1274 e
->extension
= extension
;
1280 setup_extended_primitive_generics ()
1284 t_extension
*e
= extensions
;
1285 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1286 extensions
= e
->next
;
1290 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1291 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1292 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1296 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1298 if (!SCM_UNPACK (gf
))
1299 scm_error_num_args_subr (subr
);
1301 return scm_call_0 (gf
);
1305 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1307 if (!SCM_UNPACK (gf
))
1308 scm_wrong_type_arg (subr
, pos
, a1
);
1310 return scm_call_1 (gf
, a1
);
1314 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1316 if (!SCM_UNPACK (gf
))
1317 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1319 return scm_call_2 (gf
, a1
, a2
);
1323 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1325 if (!SCM_UNPACK (gf
))
1326 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1328 return scm_apply_0 (gf
, args
);
1331 /******************************************************************************
1333 * Protocol for calling a generic fumction
1334 * This protocol is roughly equivalent to (parameter are a little bit different
1335 * for efficiency reasons):
1337 * + apply-generic (gf args)
1338 * + compute-applicable-methods (gf args ...)
1339 * + sort-applicable-methods (methods args)
1340 * + apply-methods (gf methods args)
1342 * apply-methods calls make-next-method to build the "continuation" of a a
1343 * method. Applying a next-method will call apply-next-method which in
1344 * turn will call apply again to call effectively the following method.
1346 ******************************************************************************/
1348 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
1350 "Make a new object. @var{args} must contain the class and\n"
1351 "all necessary initialization information.")
1352 #define FUNC_NAME s_scm_make
1354 return scm_apply_0 (scm_variable_ref (var_make
), args
);
1359 /**********************************************************************
1363 **********************************************************************/
1366 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
1373 sprintf (buffer
, template, type_name
);
1374 name
= scm_from_utf8_symbol (buffer
);
1377 name
= SCM_GOOPS_UNBOUND
;
1379 meta
= applicablep
? scm_class_procedure_class
: scm_class_class
;
1381 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
1385 scm_make_extended_class (char const *type_name
, int applicablep
)
1387 return make_class_from_template ("<%s>",
1389 scm_list_1 (applicablep
1390 ? scm_class_applicable
1396 scm_i_inherit_applicable (SCM c
)
1398 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
1400 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
1401 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
1402 /* patch scm_class_applicable into direct-supers */
1403 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
1404 if (scm_is_false (top
))
1405 dsupers
= scm_append (scm_list_2 (dsupers
,
1406 scm_list_1 (scm_class_applicable
)));
1409 SCM_SETCAR (top
, scm_class_applicable
);
1410 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
1412 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
1413 /* patch scm_class_applicable into cpl */
1414 top
= scm_c_memq (scm_class_top
, cpl
);
1415 if (scm_is_false (top
))
1419 SCM_SETCAR (top
, scm_class_applicable
);
1420 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
1422 /* add class to direct-subclasses of scm_class_applicable */
1423 SCM_SET_SLOT (scm_class_applicable
,
1424 scm_si_direct_subclasses
,
1425 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
1426 scm_si_direct_subclasses
)));
1431 create_smob_classes (void)
1435 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
1436 scm_smob_class
[i
] = SCM_BOOL_F
;
1438 for (i
= 0; i
< scm_numsmob
; ++i
)
1439 if (scm_is_false (scm_smob_class
[i
]))
1440 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
1441 scm_smobs
[i
].apply
!= 0);
1445 scm_make_port_classes (long ptobnum
, char *type_name
)
1447 SCM c
, class = make_class_from_template ("<%s-port>",
1449 scm_list_1 (scm_class_port
),
1451 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
1452 = make_class_from_template ("<%s-input-port>",
1454 scm_list_2 (class, scm_class_input_port
),
1456 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
1457 = make_class_from_template ("<%s-output-port>",
1459 scm_list_2 (class, scm_class_output_port
),
1461 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
1463 = make_class_from_template ("<%s-input-output-port>",
1465 scm_list_2 (class, scm_class_input_output_port
),
1467 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
1468 SCM_SET_SLOT (c
, scm_si_cpl
,
1469 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
1473 create_port_classes (void)
1477 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
1478 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
1482 scm_i_define_class_for_vtable (SCM vtable
)
1486 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
1487 if (scm_is_false (vtable_class_map
))
1488 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
1489 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
1491 if (scm_is_false (scm_struct_vtable_p (vtable
)))
1494 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
1496 if (scm_is_false (class))
1498 if (SCM_UNPACK (scm_class_class
))
1500 SCM name
, meta
, supers
;
1502 name
= SCM_VTABLE_NAME (vtable
);
1503 if (scm_is_symbol (name
))
1504 name
= scm_string_to_symbol
1506 (scm_list_3 (scm_from_latin1_string ("<"),
1507 scm_symbol_to_string (name
),
1508 scm_from_latin1_string (">"))));
1510 name
= scm_from_latin1_symbol ("<>");
1512 if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER
))
1514 meta
= scm_class_applicable_struct_with_setter_class
;
1515 supers
= scm_list_1 (scm_class_applicable_struct_with_setter
);
1517 else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable
,
1518 SCM_VTABLE_FLAG_APPLICABLE
))
1520 meta
= scm_class_applicable_struct_class
;
1521 supers
= scm_list_1 (scm_class_applicable_struct
);
1525 meta
= scm_class_class
;
1526 supers
= scm_list_1 (scm_class_top
);
1529 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
1532 /* `create_struct_classes' will fill this in later. */
1535 /* Don't worry about races. This only happens when creating a
1536 vtable, which happens by definition in one thread. */
1537 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
1544 make_struct_class (void *closure SCM_UNUSED
,
1545 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
1547 if (scm_is_false (data
))
1548 scm_i_define_class_for_vtable (vtable
);
1549 return SCM_UNSPECIFIED
;
1553 create_struct_classes (void)
1555 /* FIXME: take the vtable_class_map while initializing goops? */
1556 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
1560 /**********************************************************************
1564 **********************************************************************/
1569 if (!goops_loaded_p
)
1570 scm_c_resolve_module ("oop goops");
1574 SCM_KEYWORD (k_setter
, "setter");
1577 scm_ensure_accessor (SCM name
)
1581 var
= scm_module_variable (scm_current_module (), name
);
1582 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
1583 gf
= SCM_VARIABLE_REF (var
);
1587 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
1589 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
1590 gf
= scm_make (scm_list_5 (scm_class_accessor
,
1591 k_name
, name
, k_setter
, gf
));
1599 * Debugging utilities
1602 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
1604 "Return @code{#t} if @var{obj} is a pure generic.")
1605 #define FUNC_NAME s_scm_pure_generic_p
1607 return scm_from_bool (SCM_PUREGENERICP (obj
));
1611 #endif /* GUILE_DEBUG */
1617 SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x
, "%bless-applicable-struct-vtables!", 2, 0, 0,
1618 (SCM applicable
, SCM setter
),
1620 #define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
1622 SCM_VALIDATE_CLASS (1, applicable
);
1623 SCM_VALIDATE_CLASS (2, setter
);
1624 SCM_SET_VTABLE_FLAGS (applicable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1625 SCM_SET_VTABLE_FLAGS (setter
, SCM_VTABLE_FLAG_SETTER_VTABLE
);
1626 return SCM_UNSPECIFIED
;
1630 SCM_DEFINE (scm_sys_bless_pure_generic_vtable_x
, "%bless-pure-generic-vtable!", 1, 0, 0,
1633 #define FUNC_NAME s_scm_sys_bless_pure_generic_vtable_x
1635 SCM_VALIDATE_CLASS (1, vtable
);
1636 SCM_SET_CLASS_FLAGS (vtable
, SCM_CLASSF_PURE_GENERIC
);
1637 return SCM_UNSPECIFIED
;
1641 SCM_DEFINE (scm_sys_goops_early_init
, "%goops-early-init", 0, 0, 0,
1644 #define FUNC_NAME s_scm_sys_goops_early_init
1646 var_make_standard_class
= scm_c_lookup ("make-standard-class");
1647 var_make
= scm_c_lookup ("make");
1649 scm_class_class
= scm_variable_ref (scm_c_lookup ("<class>"));
1650 scm_class_top
= scm_variable_ref (scm_c_lookup ("<top>"));
1651 scm_class_object
= scm_variable_ref (scm_c_lookup ("<object>"));
1653 scm_class_foreign_slot
= scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
1654 scm_class_protected
= scm_variable_ref (scm_c_lookup ("<protected-slot>"));
1655 scm_class_hidden
= scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
1656 scm_class_opaque
= scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
1657 scm_class_read_only
= scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
1658 scm_class_self
= scm_variable_ref (scm_c_lookup ("<self-slot>"));
1659 scm_class_protected_opaque
= scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
1660 scm_class_protected_hidden
= scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
1661 scm_class_protected_read_only
= scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
1662 scm_class_scm
= scm_variable_ref (scm_c_lookup ("<scm-slot>"));
1663 scm_class_int
= scm_variable_ref (scm_c_lookup ("<int-slot>"));
1664 scm_class_float
= scm_variable_ref (scm_c_lookup ("<float-slot>"));
1665 scm_class_double
= scm_variable_ref (scm_c_lookup ("<double-slot>"));
1667 /* scm_class_generic functions classes */
1668 scm_class_procedure_class
= scm_variable_ref (scm_c_lookup ("<procedure-class>"));
1669 scm_class_applicable_struct_class
= scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
1670 scm_class_applicable_struct_with_setter_class
=
1671 scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
1673 scm_class_method
= scm_variable_ref (scm_c_lookup ("<method>"));
1674 scm_class_accessor_method
= scm_variable_ref (scm_c_lookup ("<accessor-method>"));
1675 scm_class_applicable
= scm_variable_ref (scm_c_lookup ("<applicable>"));
1676 scm_class_applicable_struct
= scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
1677 scm_class_applicable_struct_with_setter
= scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
1678 scm_class_generic
= scm_variable_ref (scm_c_lookup ("<generic>"));
1679 scm_class_extended_generic
= scm_variable_ref (scm_c_lookup ("<extended-generic>"));
1680 scm_class_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
1681 scm_class_accessor
= scm_variable_ref (scm_c_lookup ("<accessor>"));
1682 scm_class_extended_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
1683 scm_class_extended_accessor
= scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
1685 /* Primitive types classes */
1686 scm_class_boolean
= scm_variable_ref (scm_c_lookup ("<boolean>"));
1687 scm_class_char
= scm_variable_ref (scm_c_lookup ("<char>"));
1688 scm_class_list
= scm_variable_ref (scm_c_lookup ("<list>"));
1689 scm_class_pair
= scm_variable_ref (scm_c_lookup ("<pair>"));
1690 scm_class_null
= scm_variable_ref (scm_c_lookup ("<null>"));
1691 scm_class_string
= scm_variable_ref (scm_c_lookup ("<string>"));
1692 scm_class_symbol
= scm_variable_ref (scm_c_lookup ("<symbol>"));
1693 scm_class_vector
= scm_variable_ref (scm_c_lookup ("<vector>"));
1694 class_foreign
= scm_variable_ref (scm_c_lookup ("<foreign>"));
1695 class_hashtable
= scm_variable_ref (scm_c_lookup ("<hashtable>"));
1696 class_fluid
= scm_variable_ref (scm_c_lookup ("<fluid>"));
1697 class_dynamic_state
= scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
1698 class_frame
= scm_variable_ref (scm_c_lookup ("<frame>"));
1699 class_vm_cont
= scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
1700 class_bytevector
= scm_variable_ref (scm_c_lookup ("<bytevector>"));
1701 class_uvec
= scm_variable_ref (scm_c_lookup ("<uvec>"));
1702 class_array
= scm_variable_ref (scm_c_lookup ("<array>"));
1703 class_bitvector
= scm_variable_ref (scm_c_lookup ("<bitvector>"));
1704 scm_class_number
= scm_variable_ref (scm_c_lookup ("<number>"));
1705 scm_class_complex
= scm_variable_ref (scm_c_lookup ("<complex>"));
1706 scm_class_real
= scm_variable_ref (scm_c_lookup ("<real>"));
1707 scm_class_integer
= scm_variable_ref (scm_c_lookup ("<integer>"));
1708 scm_class_fraction
= scm_variable_ref (scm_c_lookup ("<fraction>"));
1709 scm_class_keyword
= scm_variable_ref (scm_c_lookup ("<keyword>"));
1710 scm_class_unknown
= scm_variable_ref (scm_c_lookup ("<unknown>"));
1711 scm_class_procedure
= scm_variable_ref (scm_c_lookup ("<procedure>"));
1712 scm_class_primitive_generic
= scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1713 scm_class_port
= scm_variable_ref (scm_c_lookup ("<port>"));
1714 scm_class_input_port
= scm_variable_ref (scm_c_lookup ("<input-port>"));
1715 scm_class_output_port
= scm_variable_ref (scm_c_lookup ("<output-port>"));
1716 scm_class_input_output_port
= scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1718 create_smob_classes ();
1719 create_struct_classes ();
1720 create_port_classes ();
1722 return SCM_UNSPECIFIED
;
1726 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
1728 "Announce that GOOPS is loaded and perform initialization\n"
1729 "on the C level which depends on the loaded GOOPS modules.")
1730 #define FUNC_NAME s_scm_sys_goops_loaded
1734 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
1736 scm_module_variable (scm_module_goops
, sym_slot_missing
);
1737 var_no_applicable_method
=
1738 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
1740 scm_module_variable (scm_module_goops
, sym_change_class
);
1741 setup_extended_primitive_generics ();
1743 #if (SCM_ENABLE_DEPRECATED == 1)
1744 scm_init_deprecated_goops ();
1747 return SCM_UNSPECIFIED
;
1751 SCM scm_module_goops
;
1754 scm_init_goops_builtins (void *unused
)
1756 scm_module_goops
= scm_current_module ();
1758 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
1760 hell
= scm_calloc (hell_size
* sizeof (*hell
));
1761 hell_mutex
= scm_make_mutex ();
1763 #include "libguile/goops.x"
1769 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1770 "scm_init_goops_builtins", scm_init_goops_builtins
,