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_change_class
= SCM_BOOL_F
;
79 static SCM var_make
= SCM_BOOL_F
;
81 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
82 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
83 SCM_SYMBOL (sym_change_class
, "change-class");
85 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
88 /* Class redefinition protocol:
90 A class is represented by a heap header h1 which points to a
91 malloc:ed memory block m1.
93 When a new version of a class is created, a new header h2 and
94 memory block m2 are allocated. The headers h1 and h2 then switch
95 pointers so that h1 refers to m2 and h2 to m1. In this way, names
96 bound to h1 will point to the new class at the same time as h2 will
97 be a handle which the GC will use to free m1.
99 The `redefined' slot of m1 will be set to point to h1. An old
100 instance will have its class pointer (the CAR of the heap header)
101 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
102 the class modification and the new class pointer can be found via
106 #define TEST_CHANGE_CLASS(obj, class) \
108 class = SCM_CLASS_OF (obj); \
109 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
111 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
112 class = SCM_CLASS_OF (obj); \
116 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
117 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
119 static int goops_loaded_p
= 0;
120 static scm_t_rstate
*goops_rstate
;
122 /* These variables are filled in by the object system when loaded. */
123 static SCM class_boolean
, class_char
, class_pair
;
124 static SCM class_procedure
, class_string
, class_symbol
;
125 static SCM class_primitive_generic
;
126 static SCM class_vector
, class_null
;
127 static SCM class_integer
, class_real
, class_complex
, class_fraction
;
128 static SCM class_unknown
;
129 static SCM class_top
, class_object
, class_class
;
130 static SCM class_applicable
;
131 static SCM class_applicable_struct
, class_applicable_struct_with_setter
;
132 static SCM class_generic
, class_generic_with_setter
;
133 static SCM class_accessor
;
134 static SCM class_extended_generic
, class_extended_generic_with_setter
;
135 static SCM class_extended_accessor
;
136 static SCM class_method
;
137 static SCM class_accessor_method
;
138 static SCM class_procedure_class
;
139 static SCM class_applicable_struct_class
;
140 static SCM class_applicable_struct_with_setter_class
;
141 static SCM class_number
, class_list
;
142 static SCM class_keyword
;
143 static SCM class_port
, class_input_output_port
;
144 static SCM class_input_port
, class_output_port
;
145 static SCM class_foreign_slot
;
146 static SCM class_self
, class_protected
;
147 static SCM class_hidden
, class_opaque
, class_read_only
;
148 static SCM class_protected_hidden
, class_protected_opaque
, class_protected_read_only
;
149 static SCM class_scm
;
150 static SCM class_int
, class_float
, class_double
;
152 static SCM class_foreign
;
153 static SCM class_hashtable
;
154 static SCM class_fluid
;
155 static SCM class_dynamic_state
;
156 static SCM class_frame
;
157 static SCM class_vm_cont
;
158 static SCM class_bytevector
;
159 static SCM class_uvec
;
160 static SCM class_array
;
161 static SCM class_bitvector
;
163 static SCM vtable_class_map
= SCM_BOOL_F
;
165 /* Port classes. Allocate 3 times the maximum number of port types so that
166 input ports, output ports, and in/out ports can be stored at different
167 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
168 SCM scm_i_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
171 SCM scm_i_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
173 static SCM
scm_make_unbound (void);
174 static SCM
scm_unbound_p (SCM obj
);
175 static SCM
scm_sys_bless_applicable_struct_vtables_x (SCM applicable
,
177 static SCM
scm_sys_bless_pure_generic_vtable_x (SCM vtable
);
178 static SCM
scm_sys_make_root_class (SCM name
, SCM dslots
,
179 SCM getters_n_setters
);
180 static SCM
scm_sys_init_layout_x (SCM
class, SCM layout
);
181 static SCM
scm_sys_goops_early_init (void);
182 static SCM
scm_sys_goops_loaded (void);
185 /* This function is used for efficient type dispatch. */
186 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
188 "Return the class of @var{x}.")
189 #define FUNC_NAME s_scm_class_of
191 switch (SCM_ITAG3 (x
))
195 return class_integer
;
200 else if (scm_is_bool (x
))
201 return class_boolean
;
202 else if (scm_is_null (x
))
205 return class_unknown
;
208 switch (SCM_TYP7 (x
))
210 case scm_tcs_cons_nimcar
:
217 case scm_tc7_pointer
:
218 return class_foreign
;
219 case scm_tc7_hashtable
:
220 return class_hashtable
;
223 case scm_tc7_dynamic_state
:
224 return class_dynamic_state
;
227 case scm_tc7_keyword
:
228 return class_keyword
;
229 case scm_tc7_vm_cont
:
230 return class_vm_cont
;
231 case scm_tc7_bytevector
:
232 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
233 return class_bytevector
;
238 case scm_tc7_bitvector
:
239 return class_bitvector
;
243 switch SCM_TYP16 (x
) {
245 return class_integer
;
248 case scm_tc16_complex
:
249 return class_complex
;
250 case scm_tc16_fraction
:
251 return class_fraction
;
253 case scm_tc7_program
:
254 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
255 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
256 return class_primitive_generic
;
258 return class_procedure
;
262 scm_t_bits type
= SCM_TYP16 (x
);
263 if (type
!= scm_tc16_port_with_ps
)
264 return scm_i_smob_class
[SCM_TC2SMOBNUM (type
)];
265 x
= SCM_PORT_WITH_PS_PORT (x
);
266 /* fall through to ports */
269 return scm_i_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
270 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
271 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
272 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
273 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
275 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
276 return SCM_CLASS_OF (x
);
277 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
280 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
281 scm_change_object_class (x
,
282 SCM_CLASS_OF (x
), /* old */
283 SCM_OBJ_CLASS_REDEF (x
)); /* new */
284 return SCM_CLASS_OF (x
);
287 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
292 return class_unknown
;
298 /* case scm_tc3_unused: */
302 return class_unknown
;
306 /******************************************************************************
310 ******************************************************************************/
312 /*fixme* Manufacture keywords in advance */
314 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
318 for (i
= 0; i
!= len
; i
+= 2)
320 SCM obj
= SCM_CAR (l
);
322 if (!scm_is_keyword (obj
))
323 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
324 else if (scm_is_eq (obj
, key
))
330 return default_value
;
334 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
335 (SCM key
, SCM l
, SCM default_value
),
336 "Determine an associated value for the keyword @var{key} from\n"
337 "the list @var{l}. The list @var{l} has to consist of an even\n"
338 "number of elements, where, starting with the first, every\n"
339 "second element is a keyword, followed by its associated value.\n"
340 "If @var{l} does not hold a value for @var{key}, the value\n"
341 "@var{default_value} is returned.")
342 #define FUNC_NAME s_scm_get_keyword
346 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
347 len
= scm_ilength (l
);
348 if (len
< 0 || len
% 2 == 1)
349 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
351 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
356 SCM_KEYWORD (k_init_keyword
, "init-keyword");
358 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
359 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
361 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
362 (SCM obj
, SCM initargs
),
363 "Initialize the object @var{obj} with the given arguments\n"
365 #define FUNC_NAME s_scm_sys_initialize_object
367 SCM tmp
, get_n_set
, slots
;
368 SCM
class = SCM_CLASS_OF (obj
);
371 SCM_VALIDATE_INSTANCE (1, obj
);
372 n_initargs
= scm_ilength (initargs
);
373 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
375 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
376 slots
= SCM_SLOT (class, scm_si_slots
);
378 /* See for each slot how it must be initialized */
380 !scm_is_null (slots
);
381 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
383 SCM slot_name
= SCM_CAR (slots
);
384 SCM slot_value
= SCM_GOOPS_UNBOUND
;
386 if (!scm_is_null (SCM_CDR (slot_name
)))
388 /* This slot admits (perhaps) to be initialized at creation time */
389 long n
= scm_ilength (SCM_CDR (slot_name
));
390 if (n
& 1) /* odd or -1 */
391 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
392 scm_list_1 (slot_name
));
393 tmp
= scm_i_get_keyword (k_init_keyword
,
398 slot_name
= SCM_CAR (slot_name
);
399 if (SCM_UNPACK (tmp
))
401 /* an initarg was provided for this slot */
402 if (!scm_is_keyword (tmp
))
403 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
405 slot_value
= scm_i_get_keyword (tmp
,
413 if (!SCM_GOOPS_UNBOUNDP (slot_value
))
414 /* set slot to provided value */
415 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
418 /* set slot to its :init-form if it exists */
419 tmp
= SCM_CADAR (get_n_set
);
420 if (scm_is_true (tmp
))
421 set_slot_value (class,
432 SCM_DEFINE (scm_sys_init_layout_x
, "%init-layout!", 2, 0, 0,
433 (SCM
class, SCM layout
),
435 #define FUNC_NAME s_scm_sys_init_layout_x
437 SCM_VALIDATE_INSTANCE (1, class);
438 SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME
);
439 SCM_VALIDATE_STRING (2, layout
);
441 SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout
));
442 return SCM_UNSPECIFIED
;
446 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
447 (SCM
class, SCM dsupers
),
449 #define FUNC_NAME s_scm_sys_inherit_magic_x
451 SCM_VALIDATE_INSTANCE (1, class);
452 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
453 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
455 return SCM_UNSPECIFIED
;
459 /******************************************************************************/
462 scm_make_standard_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
464 return scm_call_4 (scm_variable_ref (var_make_standard_class
),
465 meta
, name
, dsupers
, dslots
);
468 /******************************************************************************/
470 SCM_DEFINE (scm_sys_make_root_class
, "%make-root-class", 3, 0, 0,
471 (SCM name
, SCM dslots
, SCM getters_n_setters
),
473 #define FUNC_NAME s_scm_sys_make_root_class
477 cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
478 z
= scm_i_make_vtable_vtable (cs
);
479 SCM_SET_CLASS_FLAGS (z
, (SCM_CLASSF_GOOPS_OR_VALID
480 | SCM_CLASSF_METACLASS
));
482 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
483 SCM_SET_SLOT (z
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
484 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
); /* will be changed */
485 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
486 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
487 SCM_SET_SLOT (z
, scm_si_cpl
, SCM_EOL
); /* will be changed */
488 SCM_SET_SLOT (z
, scm_si_slots
, dslots
); /* will be changed */
489 SCM_SET_SLOT (z
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
490 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, getters_n_setters
); /* will be changed */
491 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
497 /******************************************************************************/
499 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
501 "Return @code{#t} if @var{obj} is an instance.")
502 #define FUNC_NAME s_scm_instance_p
504 return scm_from_bool (SCM_INSTANCEP (obj
));
509 scm_is_generic (SCM x
)
511 return SCM_INSTANCEP (x
) && SCM_SUBCLASSP (SCM_CLASS_OF (x
), class_generic
);
515 scm_is_method (SCM x
)
517 return SCM_INSTANCEP (x
) && SCM_SUBCLASSP (SCM_CLASS_OF (x
), class_method
);
520 /******************************************************************************
522 * Meta object accessors
524 ******************************************************************************/
526 SCM_SYMBOL (sym_procedure
, "procedure");
527 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
528 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
529 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
530 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
531 SCM_SYMBOL (sym_cpl
, "cpl");
532 SCM_SYMBOL (sym_slots
, "slots");
534 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
536 "Return the class name of @var{obj}.")
537 #define FUNC_NAME s_scm_class_name
539 SCM_VALIDATE_CLASS (1, obj
);
540 return scm_slot_ref (obj
, scm_sym_name
);
544 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
546 "Return the direct superclasses of the class @var{obj}.")
547 #define FUNC_NAME s_scm_class_direct_supers
549 SCM_VALIDATE_CLASS (1, obj
);
550 return scm_slot_ref (obj
, sym_direct_supers
);
554 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
556 "Return the direct slots of the class @var{obj}.")
557 #define FUNC_NAME s_scm_class_direct_slots
559 SCM_VALIDATE_CLASS (1, obj
);
560 return scm_slot_ref (obj
, sym_direct_slots
);
564 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
566 "Return the direct subclasses of the class @var{obj}.")
567 #define FUNC_NAME s_scm_class_direct_subclasses
569 SCM_VALIDATE_CLASS (1, obj
);
570 return scm_slot_ref(obj
, sym_direct_subclasses
);
574 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
576 "Return the direct methods of the class @var{obj}")
577 #define FUNC_NAME s_scm_class_direct_methods
579 SCM_VALIDATE_CLASS (1, obj
);
580 return scm_slot_ref (obj
, sym_direct_methods
);
584 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
586 "Return the class precedence list of the class @var{obj}.")
587 #define FUNC_NAME s_scm_class_precedence_list
589 SCM_VALIDATE_CLASS (1, obj
);
590 return scm_slot_ref (obj
, sym_cpl
);
594 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
596 "Return the slot list of the class @var{obj}.")
597 #define FUNC_NAME s_scm_class_slots
599 SCM_VALIDATE_CLASS (1, obj
);
600 return scm_slot_ref (obj
, sym_slots
);
604 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
606 "Return the name of the generic function @var{obj}.")
607 #define FUNC_NAME s_scm_generic_function_name
609 SCM_VALIDATE_GENERIC (1, obj
);
610 return scm_procedure_property (obj
, scm_sym_name
);
614 SCM_SYMBOL (sym_methods
, "methods");
615 SCM_SYMBOL (sym_extended_by
, "extended-by");
616 SCM_SYMBOL (sym_extends
, "extends");
619 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
621 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
622 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
623 while (!scm_is_null (gfs
))
625 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
632 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
634 if (SCM_IS_A_P (gf
, class_extended_generic
))
636 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
637 while (!scm_is_null (gfs
))
639 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
640 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
649 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
651 "Return the methods of the generic function @var{obj}.")
652 #define FUNC_NAME s_scm_generic_function_methods
655 SCM_VALIDATE_GENERIC (1, obj
);
656 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
657 methods
= fold_downward_gf_methods (methods
, obj
);
658 return scm_append (methods
);
662 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
664 "Return the generic function for the method @var{obj}.")
665 #define FUNC_NAME s_scm_method_generic_function
667 SCM_VALIDATE_METHOD (1, obj
);
668 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
672 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
674 "Return specializers of the method @var{obj}.")
675 #define FUNC_NAME s_scm_method_specializers
677 SCM_VALIDATE_METHOD (1, obj
);
678 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
682 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
684 "Return the procedure of the method @var{obj}.")
685 #define FUNC_NAME s_scm_method_procedure
687 SCM_VALIDATE_METHOD (1, obj
);
688 return scm_slot_ref (obj
, sym_procedure
);
692 /******************************************************************************
694 * S l o t a c c e s s
696 ******************************************************************************/
698 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
700 "Return the unbound value.")
701 #define FUNC_NAME s_scm_make_unbound
703 return SCM_GOOPS_UNBOUND
;
707 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
709 "Return @code{#t} if @var{obj} is unbound.")
710 #define FUNC_NAME s_scm_unbound_p
712 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
720 /* In the future, this function will return the effective slot
721 * definition associated with SLOT_NAME. Now it just returns some of
722 * the information which will be stored in the effective slot
727 slot_definition_using_name (SCM
class, SCM slot_name
)
729 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
730 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
731 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
732 return SCM_CAR (slots
);
737 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
738 #define FUNC_NAME "%get-slot-value"
740 SCM access
= SCM_CDDR (slotdef
);
742 * - access is an integer (the offset of this slot in the slots vector)
743 * - otherwise (car access) is the getter function to apply
745 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
746 * we can just assume fixnums here.
748 if (SCM_I_INUMP (access
))
749 /* Don't poke at the slots directly, because scm_struct_ref handles the
750 access bits for us. */
751 return scm_struct_ref (obj
, access
);
753 return scm_call_1 (SCM_CAR (access
), obj
);
758 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
760 SCM slotdef
= slot_definition_using_name (class, slot_name
);
761 if (scm_is_true (slotdef
))
762 return get_slot_value (class, obj
, slotdef
);
764 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
768 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
769 #define FUNC_NAME "%set-slot-value"
771 SCM access
= SCM_CDDR (slotdef
);
773 * - access is an integer (the offset of this slot in the slots vector)
774 * - otherwise (cadr access) is the setter function to apply
776 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
777 * we can just assume fixnums here.
779 if (SCM_I_INUMP (access
))
780 /* obey permissions bits via going through struct-set! */
781 scm_struct_set_x (obj
, access
, value
);
783 /* ((cadr l) obj value) */
784 scm_call_2 (SCM_CADR (access
), obj
, value
);
785 return SCM_UNSPECIFIED
;
790 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
792 SCM slotdef
= slot_definition_using_name (class, slot_name
);
793 if (scm_is_true (slotdef
))
794 return set_slot_value (class, obj
, slotdef
, value
);
796 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
800 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
804 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
805 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
811 /* ======================================== */
813 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
814 (SCM
class, SCM obj
, SCM slot_name
),
816 #define FUNC_NAME s_scm_slot_ref_using_class
820 SCM_VALIDATE_CLASS (1, class);
821 SCM_VALIDATE_INSTANCE (2, obj
);
822 SCM_VALIDATE_SYMBOL (3, slot_name
);
824 res
= get_slot_value_using_name (class, obj
, slot_name
);
825 if (SCM_GOOPS_UNBOUNDP (res
))
826 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
832 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
833 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
835 #define FUNC_NAME s_scm_slot_set_using_class_x
837 SCM_VALIDATE_CLASS (1, class);
838 SCM_VALIDATE_INSTANCE (2, obj
);
839 SCM_VALIDATE_SYMBOL (3, slot_name
);
841 return set_slot_value_using_name (class, obj
, slot_name
, value
);
846 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
847 (SCM
class, SCM obj
, SCM slot_name
),
849 #define FUNC_NAME s_scm_slot_bound_using_class_p
851 SCM_VALIDATE_CLASS (1, class);
852 SCM_VALIDATE_INSTANCE (2, obj
);
853 SCM_VALIDATE_SYMBOL (3, slot_name
);
855 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
861 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
862 (SCM
class, SCM obj
, SCM slot_name
),
864 #define FUNC_NAME s_scm_slot_exists_using_class_p
866 SCM_VALIDATE_CLASS (1, class);
867 SCM_VALIDATE_INSTANCE (2, obj
);
868 SCM_VALIDATE_SYMBOL (3, slot_name
);
869 return test_slot_existence (class, obj
, slot_name
);
874 /* ======================================== */
876 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
877 (SCM obj
, SCM slot_name
),
878 "Return the value from @var{obj}'s slot with the name\n"
880 #define FUNC_NAME s_scm_slot_ref
884 SCM_VALIDATE_INSTANCE (1, obj
);
885 TEST_CHANGE_CLASS (obj
, class);
887 res
= get_slot_value_using_name (class, obj
, slot_name
);
888 if (SCM_GOOPS_UNBOUNDP (res
))
889 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
894 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
895 (SCM obj
, SCM slot_name
, SCM value
),
896 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
897 #define FUNC_NAME s_scm_slot_set_x
901 SCM_VALIDATE_INSTANCE (1, obj
);
902 TEST_CHANGE_CLASS(obj
, class);
904 return set_slot_value_using_name (class, obj
, slot_name
, value
);
908 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
909 (SCM obj
, SCM slot_name
),
910 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
912 #define FUNC_NAME s_scm_slot_bound_p
916 SCM_VALIDATE_INSTANCE (1, obj
);
917 TEST_CHANGE_CLASS(obj
, class);
919 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
927 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
928 (SCM obj
, SCM slot_name
),
929 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
930 #define FUNC_NAME s_scm_slot_exists_p
934 SCM_VALIDATE_INSTANCE (1, obj
);
935 SCM_VALIDATE_SYMBOL (2, slot_name
);
936 TEST_CHANGE_CLASS (obj
, class);
938 return test_slot_existence (class, obj
, slot_name
);
943 /******************************************************************************
945 * %allocate-instance (the low level instance allocation primitive)
947 ******************************************************************************/
949 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
950 (SCM
class, SCM initargs
),
951 "Create a new instance of class @var{class} and initialize it\n"
952 "from the arguments @var{initargs}.")
953 #define FUNC_NAME s_scm_sys_allocate_instance
956 scm_t_signed_bits n
, i
;
959 SCM_VALIDATE_CLASS (1, class);
961 /* FIXME: duplicates some of scm_make_struct. */
963 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
964 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
966 layout
= SCM_VTABLE_LAYOUT (class);
968 /* Set all SCM-holding slots to unbound */
969 for (i
= 0; i
< n
; i
++)
971 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
973 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
975 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
977 SCM_STRUCT_DATA (obj
)[i
] = 0;
984 /******************************************************************************
986 * %modify-instance (used by change-class to modify in place)
988 ******************************************************************************/
990 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
993 #define FUNC_NAME s_scm_sys_modify_instance
995 SCM_VALIDATE_INSTANCE (1, old
);
996 SCM_VALIDATE_INSTANCE (2, new);
998 /* Exchange the data contained in old and new. We exchange rather than
999 * scratch the old value with new to be correct with GC.
1000 * See "Class redefinition protocol above".
1002 SCM_CRITICAL_SECTION_START
;
1004 scm_t_bits word0
, word1
;
1005 word0
= SCM_CELL_WORD_0 (old
);
1006 word1
= SCM_CELL_WORD_1 (old
);
1007 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1008 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1009 SCM_SET_CELL_WORD_0 (new, word0
);
1010 SCM_SET_CELL_WORD_1 (new, word1
);
1012 SCM_CRITICAL_SECTION_END
;
1013 return SCM_UNSPECIFIED
;
1017 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1020 #define FUNC_NAME s_scm_sys_modify_class
1022 SCM_VALIDATE_CLASS (1, old
);
1023 SCM_VALIDATE_CLASS (2, new);
1025 SCM_CRITICAL_SECTION_START
;
1027 scm_t_bits word0
, word1
;
1028 word0
= SCM_CELL_WORD_0 (old
);
1029 word1
= SCM_CELL_WORD_1 (old
);
1030 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1031 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1032 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1033 SCM_SET_CELL_WORD_0 (new, word0
);
1034 SCM_SET_CELL_WORD_1 (new, word1
);
1035 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1037 SCM_CRITICAL_SECTION_END
;
1038 return SCM_UNSPECIFIED
;
1042 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1045 #define FUNC_NAME s_scm_sys_invalidate_class
1047 SCM_VALIDATE_CLASS (1, class);
1048 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1049 return SCM_UNSPECIFIED
;
1053 /* When instances change class, they finally get a new body, but
1054 * before that, they go through purgatory in hell. Odd as it may
1055 * seem, this data structure saves us from eternal suffering in
1056 * infinite recursions.
1059 static scm_t_bits
**hell
;
1060 static long n_hell
= 1; /* one place for the evil one himself */
1061 static long hell_size
= 4;
1062 static SCM hell_mutex
;
1068 for (i
= 1; i
< n_hell
; ++i
)
1069 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1075 go_to_hell (void *o
)
1078 scm_lock_mutex (hell_mutex
);
1079 if (n_hell
>= hell_size
)
1082 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1084 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1085 scm_unlock_mutex (hell_mutex
);
1089 go_to_heaven (void *o
)
1092 scm_lock_mutex (hell_mutex
);
1093 hell
[burnin (obj
)] = hell
[--n_hell
];
1094 scm_unlock_mutex (hell_mutex
);
1098 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1101 purgatory (SCM obj
, SCM new_class
)
1103 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1106 /* This function calls the generic function change-class for all
1107 * instances which aren't currently undergoing class change.
1111 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1115 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1116 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1117 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1118 purgatory (obj
, new_class
);
1123 /******************************************************************************
1129 * GGG E N E R I C F U N C T I O N S
1131 * This implementation provides
1132 * - generic functions (with class specializers)
1135 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1137 ******************************************************************************/
1139 SCM_KEYWORD (k_name
, "name");
1140 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1142 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1145 #define FUNC_NAME s_scm_generic_capability_p
1147 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1148 proc
, SCM_ARG1
, FUNC_NAME
);
1149 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1153 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1156 #define FUNC_NAME s_scm_enable_primitive_generic_x
1158 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1159 while (!scm_is_null (subrs
))
1161 SCM subr
= SCM_CAR (subrs
);
1162 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1163 SCM_SET_SUBR_GENERIC (subr
,
1164 scm_make (scm_list_3 (class_generic
,
1166 SCM_SUBR_NAME (subr
))));
1167 subrs
= SCM_CDR (subrs
);
1169 return SCM_UNSPECIFIED
;
1173 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1174 (SCM subr
, SCM generic
),
1176 #define FUNC_NAME s_scm_set_primitive_generic_x
1178 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1179 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1180 SCM_SET_SUBR_GENERIC (subr
, generic
);
1181 return SCM_UNSPECIFIED
;
1185 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1188 #define FUNC_NAME s_scm_primitive_generic_generic
1190 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1192 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1193 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1194 return *SCM_SUBR_GENERIC (subr
);
1196 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1200 typedef struct t_extension
{
1201 struct t_extension
*next
;
1207 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1209 static const char extension_gc_hint
[] = "GOOPS extension";
1211 static t_extension
*extensions
= 0;
1214 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1219 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1220 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1221 gf
= *SCM_SUBR_GENERIC (extended
);
1222 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1224 SCM_SUBR_NAME (extension
));
1225 SCM_SET_SUBR_GENERIC (extension
, gext
);
1229 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1231 t_extension
**loc
= &extensions
;
1232 /* Make sure that extensions are placed before their own
1233 * extensions in the extensions list. O(N^2) algorithm, but
1234 * extensions of primitive generics are rare.
1236 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1237 loc
= &(*loc
)->next
;
1239 e
->extended
= extended
;
1240 e
->extension
= extension
;
1246 setup_extended_primitive_generics ()
1250 t_extension
*e
= extensions
;
1251 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1252 extensions
= e
->next
;
1256 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1257 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1258 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1262 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1264 if (!SCM_UNPACK (gf
))
1265 scm_error_num_args_subr (subr
);
1267 return scm_call_0 (gf
);
1271 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1273 if (!SCM_UNPACK (gf
))
1274 scm_wrong_type_arg (subr
, pos
, a1
);
1276 return scm_call_1 (gf
, a1
);
1280 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1282 if (!SCM_UNPACK (gf
))
1283 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1285 return scm_call_2 (gf
, a1
, a2
);
1289 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1291 if (!SCM_UNPACK (gf
))
1292 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1294 return scm_apply_0 (gf
, args
);
1297 /******************************************************************************
1299 * Protocol for calling a generic fumction
1300 * This protocol is roughly equivalent to (parameter are a little bit different
1301 * for efficiency reasons):
1303 * + apply-generic (gf args)
1304 * + compute-applicable-methods (gf args ...)
1305 * + sort-applicable-methods (methods args)
1306 * + apply-methods (gf methods args)
1308 * apply-methods calls make-next-method to build the "continuation" of a a
1309 * method. Applying a next-method will call apply-next-method which in
1310 * turn will call apply again to call effectively the following method.
1312 ******************************************************************************/
1314 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
1316 "Make a new object. @var{args} must contain the class and\n"
1317 "all necessary initialization information.")
1318 #define FUNC_NAME s_scm_make
1320 return scm_apply_0 (scm_variable_ref (var_make
), args
);
1325 /**********************************************************************
1329 **********************************************************************/
1332 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
1339 sprintf (buffer
, template, type_name
);
1340 name
= scm_from_utf8_symbol (buffer
);
1343 name
= SCM_GOOPS_UNBOUND
;
1345 meta
= applicablep
? class_procedure_class
: class_class
;
1347 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
1351 scm_make_extended_class (char const *type_name
, int applicablep
)
1353 return make_class_from_template ("<%s>",
1355 scm_list_1 (applicablep
1362 scm_i_inherit_applicable (SCM c
)
1364 if (!SCM_SUBCLASSP (c
, class_applicable
))
1366 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
1367 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
1368 /* patch class_applicable into direct-supers */
1369 SCM top
= scm_c_memq (class_top
, dsupers
);
1370 if (scm_is_false (top
))
1371 dsupers
= scm_append (scm_list_2 (dsupers
,
1372 scm_list_1 (class_applicable
)));
1375 SCM_SETCAR (top
, class_applicable
);
1376 SCM_SETCDR (top
, scm_cons (class_top
, SCM_CDR (top
)));
1378 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
1379 /* patch class_applicable into cpl */
1380 top
= scm_c_memq (class_top
, cpl
);
1381 if (scm_is_false (top
))
1385 SCM_SETCAR (top
, class_applicable
);
1386 SCM_SETCDR (top
, scm_cons (class_top
, SCM_CDR (top
)));
1388 /* add class to direct-subclasses of class_applicable */
1389 SCM_SET_SLOT (class_applicable
,
1390 scm_si_direct_subclasses
,
1391 scm_cons (c
, SCM_SLOT (class_applicable
,
1392 scm_si_direct_subclasses
)));
1397 create_smob_classes (void)
1401 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
1402 scm_i_smob_class
[i
] = SCM_BOOL_F
;
1404 for (i
= 0; i
< scm_numsmob
; ++i
)
1405 if (scm_is_false (scm_i_smob_class
[i
]))
1406 scm_i_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
1407 scm_smobs
[i
].apply
!= 0);
1411 scm_make_port_classes (long ptobnum
, char *type_name
)
1413 SCM c
, class = make_class_from_template ("<%s-port>",
1415 scm_list_1 (class_port
),
1417 scm_i_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
1418 = make_class_from_template ("<%s-input-port>",
1420 scm_list_2 (class, class_input_port
),
1422 scm_i_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
1423 = make_class_from_template ("<%s-output-port>",
1425 scm_list_2 (class, class_output_port
),
1427 scm_i_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
1429 = make_class_from_template ("<%s-input-output-port>",
1431 scm_list_2 (class, class_input_output_port
),
1433 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
1434 SCM_SET_SLOT (c
, scm_si_cpl
,
1435 scm_cons2 (c
, class, SCM_SLOT (class_input_output_port
, scm_si_cpl
)));
1439 create_port_classes (void)
1443 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
1444 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
1448 scm_i_define_class_for_vtable (SCM vtable
)
1452 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
1453 if (scm_is_false (vtable_class_map
))
1454 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
1455 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
1457 if (scm_is_false (scm_struct_vtable_p (vtable
)))
1460 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
1462 if (scm_is_false (class))
1464 if (SCM_UNPACK (class_class
))
1466 SCM name
, meta
, supers
;
1468 name
= SCM_VTABLE_NAME (vtable
);
1469 if (scm_is_symbol (name
))
1470 name
= scm_string_to_symbol
1472 (scm_list_3 (scm_from_latin1_string ("<"),
1473 scm_symbol_to_string (name
),
1474 scm_from_latin1_string (">"))));
1476 name
= scm_from_latin1_symbol ("<>");
1478 if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SETTER
))
1480 meta
= class_applicable_struct_with_setter_class
;
1481 supers
= scm_list_1 (class_applicable_struct_with_setter
);
1483 else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable
,
1484 SCM_VTABLE_FLAG_APPLICABLE
))
1486 meta
= class_applicable_struct_class
;
1487 supers
= scm_list_1 (class_applicable_struct
);
1492 supers
= scm_list_1 (class_top
);
1495 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
1498 /* `create_struct_classes' will fill this in later. */
1501 /* Don't worry about races. This only happens when creating a
1502 vtable, which happens by definition in one thread. */
1503 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
1510 make_struct_class (void *closure SCM_UNUSED
,
1511 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
1513 if (scm_is_false (data
))
1514 scm_i_define_class_for_vtable (vtable
);
1515 return SCM_UNSPECIFIED
;
1519 create_struct_classes (void)
1521 /* FIXME: take the vtable_class_map while initializing goops? */
1522 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
1526 /**********************************************************************
1530 **********************************************************************/
1535 if (!goops_loaded_p
)
1536 scm_c_resolve_module ("oop goops");
1540 SCM_KEYWORD (k_setter
, "setter");
1543 scm_ensure_accessor (SCM name
)
1547 var
= scm_module_variable (scm_current_module (), name
);
1548 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
1549 gf
= SCM_VARIABLE_REF (var
);
1553 if (!SCM_IS_A_P (gf
, class_accessor
))
1555 gf
= scm_make (scm_list_3 (class_generic
, k_name
, name
));
1556 gf
= scm_make (scm_list_5 (class_accessor
,
1557 k_name
, name
, k_setter
, gf
));
1565 * Debugging utilities
1568 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
1570 "Return @code{#t} if @var{obj} is a pure generic.")
1571 #define FUNC_NAME s_scm_pure_generic_p
1573 return scm_from_bool (SCM_PUREGENERICP (obj
));
1577 #endif /* GUILE_DEBUG */
1583 SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x
, "%bless-applicable-struct-vtables!", 2, 0, 0,
1584 (SCM applicable
, SCM setter
),
1586 #define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x
1588 SCM_VALIDATE_CLASS (1, applicable
);
1589 SCM_VALIDATE_CLASS (2, setter
);
1590 SCM_SET_VTABLE_FLAGS (applicable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1591 SCM_SET_VTABLE_FLAGS (setter
, SCM_VTABLE_FLAG_SETTER_VTABLE
);
1592 return SCM_UNSPECIFIED
;
1596 SCM_DEFINE (scm_sys_bless_pure_generic_vtable_x
, "%bless-pure-generic-vtable!", 1, 0, 0,
1599 #define FUNC_NAME s_scm_sys_bless_pure_generic_vtable_x
1601 SCM_VALIDATE_CLASS (1, vtable
);
1602 SCM_SET_CLASS_FLAGS (vtable
, SCM_CLASSF_PURE_GENERIC
);
1603 return SCM_UNSPECIFIED
;
1607 SCM_DEFINE (scm_sys_goops_early_init
, "%goops-early-init", 0, 0, 0,
1610 #define FUNC_NAME s_scm_sys_goops_early_init
1612 var_make_standard_class
= scm_c_lookup ("make-standard-class");
1613 var_make
= scm_c_lookup ("make");
1615 class_class
= scm_variable_ref (scm_c_lookup ("<class>"));
1616 class_top
= scm_variable_ref (scm_c_lookup ("<top>"));
1617 class_object
= scm_variable_ref (scm_c_lookup ("<object>"));
1619 class_foreign_slot
= scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
1620 class_protected
= scm_variable_ref (scm_c_lookup ("<protected-slot>"));
1621 class_hidden
= scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
1622 class_opaque
= scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
1623 class_read_only
= scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
1624 class_self
= scm_variable_ref (scm_c_lookup ("<self-slot>"));
1625 class_protected_opaque
= scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
1626 class_protected_hidden
= scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
1627 class_protected_read_only
= scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
1628 class_scm
= scm_variable_ref (scm_c_lookup ("<scm-slot>"));
1629 class_int
= scm_variable_ref (scm_c_lookup ("<int-slot>"));
1630 class_float
= scm_variable_ref (scm_c_lookup ("<float-slot>"));
1631 class_double
= scm_variable_ref (scm_c_lookup ("<double-slot>"));
1634 class_procedure_class
= scm_variable_ref (scm_c_lookup ("<procedure-class>"));
1635 class_applicable_struct_class
= scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
1636 class_applicable_struct_with_setter_class
=
1637 scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
1639 class_method
= scm_variable_ref (scm_c_lookup ("<method>"));
1640 class_accessor_method
= scm_variable_ref (scm_c_lookup ("<accessor-method>"));
1641 class_applicable
= scm_variable_ref (scm_c_lookup ("<applicable>"));
1642 class_applicable_struct
= scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
1643 class_applicable_struct_with_setter
= scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
1644 class_generic
= scm_variable_ref (scm_c_lookup ("<generic>"));
1645 class_extended_generic
= scm_variable_ref (scm_c_lookup ("<extended-generic>"));
1646 class_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
1647 class_accessor
= scm_variable_ref (scm_c_lookup ("<accessor>"));
1648 class_extended_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
1649 class_extended_accessor
= scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
1651 /* Primitive types classes */
1652 class_boolean
= scm_variable_ref (scm_c_lookup ("<boolean>"));
1653 class_char
= scm_variable_ref (scm_c_lookup ("<char>"));
1654 class_list
= scm_variable_ref (scm_c_lookup ("<list>"));
1655 class_pair
= scm_variable_ref (scm_c_lookup ("<pair>"));
1656 class_null
= scm_variable_ref (scm_c_lookup ("<null>"));
1657 class_string
= scm_variable_ref (scm_c_lookup ("<string>"));
1658 class_symbol
= scm_variable_ref (scm_c_lookup ("<symbol>"));
1659 class_vector
= scm_variable_ref (scm_c_lookup ("<vector>"));
1660 class_foreign
= scm_variable_ref (scm_c_lookup ("<foreign>"));
1661 class_hashtable
= scm_variable_ref (scm_c_lookup ("<hashtable>"));
1662 class_fluid
= scm_variable_ref (scm_c_lookup ("<fluid>"));
1663 class_dynamic_state
= scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
1664 class_frame
= scm_variable_ref (scm_c_lookup ("<frame>"));
1665 class_vm_cont
= scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
1666 class_bytevector
= scm_variable_ref (scm_c_lookup ("<bytevector>"));
1667 class_uvec
= scm_variable_ref (scm_c_lookup ("<uvec>"));
1668 class_array
= scm_variable_ref (scm_c_lookup ("<array>"));
1669 class_bitvector
= scm_variable_ref (scm_c_lookup ("<bitvector>"));
1670 class_number
= scm_variable_ref (scm_c_lookup ("<number>"));
1671 class_complex
= scm_variable_ref (scm_c_lookup ("<complex>"));
1672 class_real
= scm_variable_ref (scm_c_lookup ("<real>"));
1673 class_integer
= scm_variable_ref (scm_c_lookup ("<integer>"));
1674 class_fraction
= scm_variable_ref (scm_c_lookup ("<fraction>"));
1675 class_keyword
= scm_variable_ref (scm_c_lookup ("<keyword>"));
1676 class_unknown
= scm_variable_ref (scm_c_lookup ("<unknown>"));
1677 class_procedure
= scm_variable_ref (scm_c_lookup ("<procedure>"));
1678 class_primitive_generic
= scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1679 class_port
= scm_variable_ref (scm_c_lookup ("<port>"));
1680 class_input_port
= scm_variable_ref (scm_c_lookup ("<input-port>"));
1681 class_output_port
= scm_variable_ref (scm_c_lookup ("<output-port>"));
1682 class_input_output_port
= scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1684 create_smob_classes ();
1685 create_struct_classes ();
1686 create_port_classes ();
1688 return SCM_UNSPECIFIED
;
1692 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
1694 "Announce that GOOPS is loaded and perform initialization\n"
1695 "on the C level which depends on the loaded GOOPS modules.")
1696 #define FUNC_NAME s_scm_sys_goops_loaded
1700 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
1702 scm_module_variable (scm_module_goops
, sym_slot_missing
);
1704 scm_module_variable (scm_module_goops
, sym_change_class
);
1705 setup_extended_primitive_generics ();
1707 #if (SCM_ENABLE_DEPRECATED == 1)
1708 scm_init_deprecated_goops ();
1711 return SCM_UNSPECIFIED
;
1715 SCM scm_module_goops
;
1718 scm_init_goops_builtins (void *unused
)
1720 scm_module_goops
= scm_current_module ();
1722 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
1724 hell
= scm_calloc (hell_size
* sizeof (*hell
));
1725 hell_mutex
= scm_make_mutex ();
1727 #include "libguile/goops.x"
1733 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1734 "scm_init_goops_builtins", scm_init_goops_builtins
,