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
;
81 SCM_SYMBOL (sym_slot_unbound
, "slot-unbound");
82 SCM_SYMBOL (sym_slot_missing
, "slot-missing");
83 SCM_SYMBOL (sym_no_applicable_method
, "no-applicable-method");
84 SCM_SYMBOL (sym_memoize_method_x
, "memoize-method!");
85 SCM_SYMBOL (sym_change_class
, "change-class");
87 SCM_VARIABLE (scm_var_make_extended_generic
, "make-extended-generic");
90 /* Class redefinition protocol:
92 A class is represented by a heap header h1 which points to a
93 malloc:ed memory block m1.
95 When a new version of a class is created, a new header h2 and
96 memory block m2 are allocated. The headers h1 and h2 then switch
97 pointers so that h1 refers to m2 and h2 to m1. In this way, names
98 bound to h1 will point to the new class at the same time as h2 will
99 be a handle which the GC will use to free m1.
101 The `redefined' slot of m1 will be set to point to h1. An old
102 instance will have its class pointer (the CAR of the heap header)
103 pointing to m1. The non-immediate `redefined'-slot in m1 indicates
104 the class modification and the new class pointer can be found via
108 #define TEST_CHANGE_CLASS(obj, class) \
110 class = SCM_CLASS_OF (obj); \
111 if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
113 scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
114 class = SCM_CLASS_OF (obj); \
118 #define SCM_GOOPS_UNBOUND SCM_UNBOUND
119 #define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
121 static int goops_loaded_p
= 0;
122 static scm_t_rstate
*goops_rstate
;
124 /* These variables are filled in by the object system when loaded. */
125 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
126 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
127 SCM scm_class_primitive_generic
;
128 SCM scm_class_vector
, scm_class_null
;
129 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
130 SCM scm_class_unknown
;
131 SCM scm_class_top
, scm_class_object
, scm_class_class
;
132 SCM scm_class_applicable
;
133 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
134 SCM scm_class_generic
, scm_class_generic_with_setter
;
135 SCM scm_class_accessor
;
136 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
137 SCM scm_class_extended_accessor
;
138 SCM scm_class_method
;
139 SCM scm_class_accessor_method
;
140 SCM scm_class_procedure_class
;
141 SCM scm_class_applicable_struct_class
;
142 SCM scm_class_number
, scm_class_list
;
143 SCM scm_class_keyword
;
144 SCM scm_class_port
, scm_class_input_output_port
;
145 SCM scm_class_input_port
, scm_class_output_port
;
146 SCM scm_class_foreign_slot
;
147 SCM scm_class_self
, scm_class_protected
;
148 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
149 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
151 SCM scm_class_int
, scm_class_float
, scm_class_double
;
153 static SCM class_foreign
;
154 static SCM class_hashtable
;
155 static SCM class_fluid
;
156 static SCM class_dynamic_state
;
157 static SCM class_frame
;
158 static SCM class_vm_cont
;
159 static SCM class_bytevector
;
160 static SCM class_uvec
;
161 static SCM class_array
;
162 static SCM class_bitvector
;
164 static SCM vtable_class_map
= SCM_BOOL_F
;
166 /* Port classes. Allocate 3 times the maximum number of port types so that
167 input ports, output ports, and in/out ports can be stored at different
168 offsets. See `SCM_IN_PCLASS_INDEX' et al. */
169 SCM scm_port_class
[3 * SCM_I_MAX_PORT_TYPE_COUNT
];
172 SCM scm_smob_class
[SCM_I_MAX_SMOB_TYPE_COUNT
];
174 SCM scm_no_applicable_method
;
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_vtable_x (SCM vtable
);
181 static SCM
scm_sys_bless_pure_generic_vtable_x (SCM vtable
);
182 static SCM
scm_sys_make_root_class (SCM name
, SCM dslots
,
183 SCM getters_n_setters
);
184 static SCM
scm_sys_init_layout_x (SCM
class, SCM layout
);
185 static SCM
scm_sys_goops_early_init (void);
186 static SCM
scm_sys_goops_loaded (void);
187 static SCM
scm_make_extended_class_from_symbol (SCM type_name_sym
,
192 scm_i_define_class_for_vtable (SCM vtable
)
196 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
197 if (scm_is_false (vtable_class_map
))
198 vtable_class_map
= scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY
);
199 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
201 if (scm_is_false (scm_struct_vtable_p (vtable
)))
204 class = scm_weak_table_refq (vtable_class_map
, vtable
, SCM_BOOL_F
);
206 if (scm_is_false (class))
208 if (SCM_UNPACK (scm_class_class
))
210 SCM name
= SCM_VTABLE_NAME (vtable
);
211 if (!scm_is_symbol (name
))
212 name
= scm_string_to_symbol (scm_nullstr
);
214 class = scm_make_extended_class_from_symbol
215 (name
, SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_APPLICABLE
));
218 /* `create_struct_classes' will fill this in later. */
221 /* Don't worry about races. This only happens when creating a
222 vtable, which happens by definition in one thread. */
223 scm_weak_table_putq_x (vtable_class_map
, vtable
, class);
229 /* This function is used for efficient type dispatch. */
230 SCM_DEFINE (scm_class_of
, "class-of", 1, 0, 0,
232 "Return the class of @var{x}.")
233 #define FUNC_NAME s_scm_class_of
235 switch (SCM_ITAG3 (x
))
239 return scm_class_integer
;
243 return scm_class_char
;
244 else if (scm_is_bool (x
))
245 return scm_class_boolean
;
246 else if (scm_is_null (x
))
247 return scm_class_null
;
249 return scm_class_unknown
;
252 switch (SCM_TYP7 (x
))
254 case scm_tcs_cons_nimcar
:
255 return scm_class_pair
;
257 return scm_class_symbol
;
260 return scm_class_vector
;
261 case scm_tc7_pointer
:
262 return class_foreign
;
263 case scm_tc7_hashtable
:
264 return class_hashtable
;
267 case scm_tc7_dynamic_state
:
268 return class_dynamic_state
;
271 case scm_tc7_keyword
:
272 return scm_class_keyword
;
273 case scm_tc7_vm_cont
:
274 return class_vm_cont
;
275 case scm_tc7_bytevector
:
276 if (SCM_BYTEVECTOR_ELEMENT_TYPE (x
) == SCM_ARRAY_ELEMENT_TYPE_VU8
)
277 return class_bytevector
;
282 case scm_tc7_bitvector
:
283 return class_bitvector
;
285 return scm_class_string
;
287 switch SCM_TYP16 (x
) {
289 return scm_class_integer
;
291 return scm_class_real
;
292 case scm_tc16_complex
:
293 return scm_class_complex
;
294 case scm_tc16_fraction
:
295 return scm_class_fraction
;
297 case scm_tc7_program
:
298 if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x
)
299 && SCM_UNPACK (*SCM_SUBR_GENERIC (x
)))
300 return scm_class_primitive_generic
;
302 return scm_class_procedure
;
306 scm_t_bits type
= SCM_TYP16 (x
);
307 if (type
!= scm_tc16_port_with_ps
)
308 return scm_smob_class
[SCM_TC2SMOBNUM (type
)];
309 x
= SCM_PORT_WITH_PS_PORT (x
);
310 /* fall through to ports */
313 return scm_port_class
[(SCM_WRTNG
& SCM_CELL_WORD_0 (x
)
314 ? (SCM_RDNG
& SCM_CELL_WORD_0 (x
)
315 ? SCM_INOUT_PCLASS_INDEX
| SCM_PTOBNUM (x
)
316 : SCM_OUT_PCLASS_INDEX
| SCM_PTOBNUM (x
))
317 : SCM_IN_PCLASS_INDEX
| SCM_PTOBNUM (x
))];
319 if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS_VALID
)
320 return SCM_CLASS_OF (x
);
321 else if (SCM_OBJ_CLASS_FLAGS (x
) & SCM_CLASSF_GOOPS
)
324 if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x
)))
325 scm_change_object_class (x
,
326 SCM_CLASS_OF (x
), /* old */
327 SCM_OBJ_CLASS_REDEF (x
)); /* new */
328 return SCM_CLASS_OF (x
);
331 return scm_i_define_class_for_vtable (SCM_CLASS_OF (x
));
334 return scm_class_pair
;
336 return scm_class_unknown
;
342 /* case scm_tc3_unused: */
346 return scm_class_unknown
;
350 /******************************************************************************
354 ******************************************************************************/
356 /*fixme* Manufacture keywords in advance */
358 scm_i_get_keyword (SCM key
, SCM l
, long len
, SCM default_value
, const char *subr
)
362 for (i
= 0; i
!= len
; i
+= 2)
364 SCM obj
= SCM_CAR (l
);
366 if (!scm_is_keyword (obj
))
367 scm_misc_error (subr
, "bad keyword: ~S", scm_list_1 (obj
));
368 else if (scm_is_eq (obj
, key
))
374 return default_value
;
378 SCM_DEFINE (scm_get_keyword
, "get-keyword", 3, 0, 0,
379 (SCM key
, SCM l
, SCM default_value
),
380 "Determine an associated value for the keyword @var{key} from\n"
381 "the list @var{l}. The list @var{l} has to consist of an even\n"
382 "number of elements, where, starting with the first, every\n"
383 "second element is a keyword, followed by its associated value.\n"
384 "If @var{l} does not hold a value for @var{key}, the value\n"
385 "@var{default_value} is returned.")
386 #define FUNC_NAME s_scm_get_keyword
390 SCM_ASSERT (scm_is_keyword (key
), key
, SCM_ARG1
, FUNC_NAME
);
391 len
= scm_ilength (l
);
392 if (len
< 0 || len
% 2 == 1)
393 scm_misc_error (FUNC_NAME
, "Bad keyword-value list: ~S", scm_list_1 (l
));
395 return scm_i_get_keyword (key
, l
, len
, default_value
, FUNC_NAME
);
400 SCM_KEYWORD (k_init_keyword
, "init-keyword");
402 static SCM
get_slot_value (SCM
class, SCM obj
, SCM slotdef
);
403 static SCM
set_slot_value (SCM
class, SCM obj
, SCM slotdef
, SCM value
);
405 SCM_DEFINE (scm_sys_initialize_object
, "%initialize-object", 2, 0, 0,
406 (SCM obj
, SCM initargs
),
407 "Initialize the object @var{obj} with the given arguments\n"
409 #define FUNC_NAME s_scm_sys_initialize_object
411 SCM tmp
, get_n_set
, slots
;
412 SCM
class = SCM_CLASS_OF (obj
);
415 SCM_VALIDATE_INSTANCE (1, obj
);
416 n_initargs
= scm_ilength (initargs
);
417 SCM_ASSERT ((n_initargs
& 1) == 0, initargs
, SCM_ARG2
, FUNC_NAME
);
419 get_n_set
= SCM_SLOT (class, scm_si_getters_n_setters
);
420 slots
= SCM_SLOT (class, scm_si_slots
);
422 /* See for each slot how it must be initialized */
424 !scm_is_null (slots
);
425 get_n_set
= SCM_CDR (get_n_set
), slots
= SCM_CDR (slots
))
427 SCM slot_name
= SCM_CAR (slots
);
428 SCM slot_value
= SCM_GOOPS_UNBOUND
;
430 if (!scm_is_null (SCM_CDR (slot_name
)))
432 /* This slot admits (perhaps) to be initialized at creation time */
433 long n
= scm_ilength (SCM_CDR (slot_name
));
434 if (n
& 1) /* odd or -1 */
435 SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
436 scm_list_1 (slot_name
));
437 tmp
= scm_i_get_keyword (k_init_keyword
,
442 slot_name
= SCM_CAR (slot_name
);
443 if (SCM_UNPACK (tmp
))
445 /* an initarg was provided for this slot */
446 if (!scm_is_keyword (tmp
))
447 SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
449 slot_value
= scm_i_get_keyword (tmp
,
457 if (!SCM_GOOPS_UNBOUNDP (slot_value
))
458 /* set slot to provided value */
459 set_slot_value (class, obj
, SCM_CAR (get_n_set
), slot_value
);
462 /* set slot to its :init-form if it exists */
463 tmp
= SCM_CADAR (get_n_set
);
464 if (scm_is_true (tmp
))
465 set_slot_value (class,
476 SCM_DEFINE (scm_sys_init_layout_x
, "%init-layout!", 2, 0, 0,
477 (SCM
class, SCM layout
),
479 #define FUNC_NAME s_scm_sys_init_layout_x
481 SCM_VALIDATE_INSTANCE (1, class);
482 SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME
);
483 SCM_VALIDATE_STRING (2, layout
);
485 SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout
));
486 return SCM_UNSPECIFIED
;
490 static void prep_hashsets (SCM
);
492 SCM_DEFINE (scm_sys_inherit_magic_x
, "%inherit-magic!", 2, 0, 0,
493 (SCM
class, SCM dsupers
),
495 #define FUNC_NAME s_scm_sys_inherit_magic_x
497 SCM_VALIDATE_INSTANCE (1, class);
498 scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
499 SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID
);
501 prep_hashsets (class);
503 return SCM_UNSPECIFIED
;
508 prep_hashsets (SCM
class)
512 for (i
= 0; i
< 8; ++i
)
513 SCM_SET_HASHSET (class, i
, scm_c_uniform32 (goops_rstate
));
516 /******************************************************************************/
519 scm_make_standard_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
521 return scm_call_4 (scm_variable_ref (var_make_standard_class
),
522 meta
, name
, dsupers
, dslots
);
525 /******************************************************************************/
527 SCM_DEFINE (scm_sys_make_root_class
, "%make-root-class", 3, 0, 0,
528 (SCM name
, SCM dslots
, SCM getters_n_setters
),
530 #define FUNC_NAME s_scm_sys_make_root_class
534 cs
= scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
);
535 z
= scm_i_make_vtable_vtable (cs
);
536 SCM_SET_CLASS_FLAGS (z
, (SCM_CLASSF_GOOPS_OR_VALID
537 | SCM_CLASSF_METACLASS
));
539 SCM_SET_SLOT (z
, scm_vtable_index_name
, name
);
540 SCM_SET_SLOT (z
, scm_si_direct_supers
, SCM_EOL
); /* will be changed */
541 SCM_SET_SLOT (z
, scm_si_direct_slots
, dslots
); /* will be changed */
542 SCM_SET_SLOT (z
, scm_si_direct_subclasses
, SCM_EOL
);
543 SCM_SET_SLOT (z
, scm_si_direct_methods
, SCM_EOL
);
544 SCM_SET_SLOT (z
, scm_si_cpl
, SCM_EOL
); /* will be changed */
545 SCM_SET_SLOT (z
, scm_si_slots
, dslots
); /* will be changed */
546 SCM_SET_SLOT (z
, scm_si_nfields
, scm_from_int (SCM_N_CLASS_SLOTS
));
547 SCM_SET_SLOT (z
, scm_si_getters_n_setters
, getters_n_setters
); /* will be changed */
548 SCM_SET_SLOT (z
, scm_si_redefined
, SCM_BOOL_F
);
556 /******************************************************************************/
558 SCM_DEFINE (scm_instance_p
, "instance?", 1, 0, 0,
560 "Return @code{#t} if @var{obj} is an instance.")
561 #define FUNC_NAME s_scm_instance_p
563 return scm_from_bool (SCM_INSTANCEP (obj
));
568 /******************************************************************************
570 * Meta object accessors
572 ******************************************************************************/
574 SCM_SYMBOL (sym_procedure
, "procedure");
575 SCM_SYMBOL (sym_direct_supers
, "direct-supers");
576 SCM_SYMBOL (sym_direct_slots
, "direct-slots");
577 SCM_SYMBOL (sym_direct_subclasses
, "direct-subclasses");
578 SCM_SYMBOL (sym_direct_methods
, "direct-methods");
579 SCM_SYMBOL (sym_cpl
, "cpl");
580 SCM_SYMBOL (sym_slots
, "slots");
582 SCM_DEFINE (scm_class_name
, "class-name", 1, 0, 0,
584 "Return the class name of @var{obj}.")
585 #define FUNC_NAME s_scm_class_name
587 SCM_VALIDATE_CLASS (1, obj
);
588 return scm_slot_ref (obj
, scm_sym_name
);
592 SCM_DEFINE (scm_class_direct_supers
, "class-direct-supers", 1, 0, 0,
594 "Return the direct superclasses of the class @var{obj}.")
595 #define FUNC_NAME s_scm_class_direct_supers
597 SCM_VALIDATE_CLASS (1, obj
);
598 return scm_slot_ref (obj
, sym_direct_supers
);
602 SCM_DEFINE (scm_class_direct_slots
, "class-direct-slots", 1, 0, 0,
604 "Return the direct slots of the class @var{obj}.")
605 #define FUNC_NAME s_scm_class_direct_slots
607 SCM_VALIDATE_CLASS (1, obj
);
608 return scm_slot_ref (obj
, sym_direct_slots
);
612 SCM_DEFINE (scm_class_direct_subclasses
, "class-direct-subclasses", 1, 0, 0,
614 "Return the direct subclasses of the class @var{obj}.")
615 #define FUNC_NAME s_scm_class_direct_subclasses
617 SCM_VALIDATE_CLASS (1, obj
);
618 return scm_slot_ref(obj
, sym_direct_subclasses
);
622 SCM_DEFINE (scm_class_direct_methods
, "class-direct-methods", 1, 0, 0,
624 "Return the direct methods of the class @var{obj}")
625 #define FUNC_NAME s_scm_class_direct_methods
627 SCM_VALIDATE_CLASS (1, obj
);
628 return scm_slot_ref (obj
, sym_direct_methods
);
632 SCM_DEFINE (scm_class_precedence_list
, "class-precedence-list", 1, 0, 0,
634 "Return the class precedence list of the class @var{obj}.")
635 #define FUNC_NAME s_scm_class_precedence_list
637 SCM_VALIDATE_CLASS (1, obj
);
638 return scm_slot_ref (obj
, sym_cpl
);
642 SCM_DEFINE (scm_class_slots
, "class-slots", 1, 0, 0,
644 "Return the slot list of the class @var{obj}.")
645 #define FUNC_NAME s_scm_class_slots
647 SCM_VALIDATE_CLASS (1, obj
);
648 return scm_slot_ref (obj
, sym_slots
);
652 SCM_DEFINE (scm_generic_function_name
, "generic-function-name", 1, 0, 0,
654 "Return the name of the generic function @var{obj}.")
655 #define FUNC_NAME s_scm_generic_function_name
657 SCM_VALIDATE_GENERIC (1, obj
);
658 return scm_procedure_property (obj
, scm_sym_name
);
662 SCM_SYMBOL (sym_methods
, "methods");
663 SCM_SYMBOL (sym_extended_by
, "extended-by");
664 SCM_SYMBOL (sym_extends
, "extends");
667 SCM
fold_downward_gf_methods (SCM method_lists
, SCM gf
)
669 SCM gfs
= scm_slot_ref (gf
, sym_extended_by
);
670 method_lists
= scm_cons (scm_slot_ref (gf
, sym_methods
), method_lists
);
671 while (!scm_is_null (gfs
))
673 method_lists
= fold_downward_gf_methods (method_lists
, SCM_CAR (gfs
));
680 SCM
fold_upward_gf_methods (SCM method_lists
, SCM gf
)
682 if (SCM_IS_A_P (gf
, scm_class_extended_generic
))
684 SCM gfs
= scm_slot_ref (gf
, sym_extends
);
685 while (!scm_is_null (gfs
))
687 SCM methods
= scm_slot_ref (SCM_CAR (gfs
), sym_methods
);
688 method_lists
= fold_upward_gf_methods (scm_cons (methods
,
697 SCM_DEFINE (scm_generic_function_methods
, "generic-function-methods", 1, 0, 0,
699 "Return the methods of the generic function @var{obj}.")
700 #define FUNC_NAME s_scm_generic_function_methods
703 SCM_VALIDATE_GENERIC (1, obj
);
704 methods
= fold_upward_gf_methods (SCM_EOL
, obj
);
705 methods
= fold_downward_gf_methods (methods
, obj
);
706 return scm_append (methods
);
710 SCM_DEFINE (scm_method_generic_function
, "method-generic-function", 1, 0, 0,
712 "Return the generic function for the method @var{obj}.")
713 #define FUNC_NAME s_scm_method_generic_function
715 SCM_VALIDATE_METHOD (1, obj
);
716 return scm_slot_ref (obj
, scm_from_latin1_symbol ("generic-function"));
720 SCM_DEFINE (scm_method_specializers
, "method-specializers", 1, 0, 0,
722 "Return specializers of the method @var{obj}.")
723 #define FUNC_NAME s_scm_method_specializers
725 SCM_VALIDATE_METHOD (1, obj
);
726 return scm_slot_ref (obj
, scm_from_latin1_symbol ("specializers"));
730 SCM_DEFINE (scm_method_procedure
, "method-procedure", 1, 0, 0,
732 "Return the procedure of the method @var{obj}.")
733 #define FUNC_NAME s_scm_method_procedure
735 SCM_VALIDATE_METHOD (1, obj
);
736 return scm_slot_ref (obj
, sym_procedure
);
740 /******************************************************************************
742 * S l o t a c c e s s
744 ******************************************************************************/
746 SCM_DEFINE (scm_make_unbound
, "make-unbound", 0, 0, 0,
748 "Return the unbound value.")
749 #define FUNC_NAME s_scm_make_unbound
751 return SCM_GOOPS_UNBOUND
;
755 SCM_DEFINE (scm_unbound_p
, "unbound?", 1, 0, 0,
757 "Return @code{#t} if @var{obj} is unbound.")
758 #define FUNC_NAME s_scm_unbound_p
760 return SCM_GOOPS_UNBOUNDP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
764 SCM_DEFINE (scm_assert_bound
, "assert-bound", 2, 0, 0,
765 (SCM value
, SCM obj
),
766 "Return @var{value} if it is bound, and invoke the\n"
767 "@var{slot-unbound} method of @var{obj} if it is not.")
768 #define FUNC_NAME s_scm_assert_bound
770 if (SCM_GOOPS_UNBOUNDP (value
))
771 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
776 SCM_DEFINE (scm_at_assert_bound_ref
, "@assert-bound-ref", 2, 0, 0,
777 (SCM obj
, SCM index
),
778 "Like @code{assert-bound}, but use @var{index} for accessing\n"
779 "the value from @var{obj}.")
780 #define FUNC_NAME s_scm_at_assert_bound_ref
782 SCM value
= SCM_SLOT (obj
, scm_to_int (index
));
783 if (SCM_GOOPS_UNBOUNDP (value
))
784 return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound
), obj
);
793 /* In the future, this function will return the effective slot
794 * definition associated with SLOT_NAME. Now it just returns some of
795 * the information which will be stored in the effective slot
800 slot_definition_using_name (SCM
class, SCM slot_name
)
802 register SCM slots
= SCM_SLOT (class, scm_si_getters_n_setters
);
803 for (; !scm_is_null (slots
); slots
= SCM_CDR (slots
))
804 if (scm_is_eq (SCM_CAAR (slots
), slot_name
))
805 return SCM_CAR (slots
);
810 get_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
)
811 #define FUNC_NAME "%get-slot-value"
813 SCM access
= SCM_CDDR (slotdef
);
815 * - access is an integer (the offset of this slot in the slots vector)
816 * - otherwise (car access) is the getter function to apply
818 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
819 * we can just assume fixnums here.
821 if (SCM_I_INUMP (access
))
822 /* Don't poke at the slots directly, because scm_struct_ref handles the
823 access bits for us. */
824 return scm_struct_ref (obj
, access
);
826 return scm_call_1 (SCM_CAR (access
), obj
);
831 get_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
)
833 SCM slotdef
= slot_definition_using_name (class, slot_name
);
834 if (scm_is_true (slotdef
))
835 return get_slot_value (class, obj
, slotdef
);
837 return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
);
841 set_slot_value (SCM
class SCM_UNUSED
, SCM obj
, SCM slotdef
, SCM value
)
842 #define FUNC_NAME "%set-slot-value"
844 SCM access
= SCM_CDDR (slotdef
);
846 * - access is an integer (the offset of this slot in the slots vector)
847 * - otherwise (cadr access) is the setter function to apply
849 * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
850 * we can just assume fixnums here.
852 if (SCM_I_INUMP (access
))
853 /* obey permissions bits via going through struct-set! */
854 scm_struct_set_x (obj
, access
, value
);
856 /* ((cadr l) obj value) */
857 scm_call_2 (SCM_CADR (access
), obj
, value
);
858 return SCM_UNSPECIFIED
;
863 set_slot_value_using_name (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
865 SCM slotdef
= slot_definition_using_name (class, slot_name
);
866 if (scm_is_true (slotdef
))
867 return set_slot_value (class, obj
, slotdef
, value
);
869 return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing
), class, obj
, slot_name
, value
);
873 test_slot_existence (SCM
class SCM_UNUSED
, SCM obj
, SCM slot_name
)
877 for (l
= SCM_ACCESSORS_OF (obj
); !scm_is_null (l
); l
= SCM_CDR (l
))
878 if (scm_is_eq (SCM_CAAR (l
), slot_name
))
884 /* ======================================== */
886 SCM_DEFINE (scm_slot_ref_using_class
, "slot-ref-using-class", 3, 0, 0,
887 (SCM
class, SCM obj
, SCM slot_name
),
889 #define FUNC_NAME s_scm_slot_ref_using_class
893 SCM_VALIDATE_CLASS (1, class);
894 SCM_VALIDATE_INSTANCE (2, obj
);
895 SCM_VALIDATE_SYMBOL (3, slot_name
);
897 res
= get_slot_value_using_name (class, obj
, slot_name
);
898 if (SCM_GOOPS_UNBOUNDP (res
))
899 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
905 SCM_DEFINE (scm_slot_set_using_class_x
, "slot-set-using-class!", 4, 0, 0,
906 (SCM
class, SCM obj
, SCM slot_name
, SCM value
),
908 #define FUNC_NAME s_scm_slot_set_using_class_x
910 SCM_VALIDATE_CLASS (1, class);
911 SCM_VALIDATE_INSTANCE (2, obj
);
912 SCM_VALIDATE_SYMBOL (3, slot_name
);
914 return set_slot_value_using_name (class, obj
, slot_name
, value
);
919 SCM_DEFINE (scm_slot_bound_using_class_p
, "slot-bound-using-class?", 3, 0, 0,
920 (SCM
class, SCM obj
, SCM slot_name
),
922 #define FUNC_NAME s_scm_slot_bound_using_class_p
924 SCM_VALIDATE_CLASS (1, class);
925 SCM_VALIDATE_INSTANCE (2, obj
);
926 SCM_VALIDATE_SYMBOL (3, slot_name
);
928 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj
, slot_name
))
934 SCM_DEFINE (scm_slot_exists_using_class_p
, "slot-exists-using-class?", 3, 0, 0,
935 (SCM
class, SCM obj
, SCM slot_name
),
937 #define FUNC_NAME s_scm_slot_exists_using_class_p
939 SCM_VALIDATE_CLASS (1, class);
940 SCM_VALIDATE_INSTANCE (2, obj
);
941 SCM_VALIDATE_SYMBOL (3, slot_name
);
942 return test_slot_existence (class, obj
, slot_name
);
947 /* ======================================== */
949 SCM_DEFINE (scm_slot_ref
, "slot-ref", 2, 0, 0,
950 (SCM obj
, SCM slot_name
),
951 "Return the value from @var{obj}'s slot with the name\n"
953 #define FUNC_NAME s_scm_slot_ref
957 SCM_VALIDATE_INSTANCE (1, obj
);
958 TEST_CHANGE_CLASS (obj
, class);
960 res
= get_slot_value_using_name (class, obj
, slot_name
);
961 if (SCM_GOOPS_UNBOUNDP (res
))
962 return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound
), class, obj
, slot_name
);
967 SCM_DEFINE (scm_slot_set_x
, "slot-set!", 3, 0, 0,
968 (SCM obj
, SCM slot_name
, SCM value
),
969 "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
970 #define FUNC_NAME s_scm_slot_set_x
974 SCM_VALIDATE_INSTANCE (1, obj
);
975 TEST_CHANGE_CLASS(obj
, class);
977 return set_slot_value_using_name (class, obj
, slot_name
, value
);
981 const char *scm_s_slot_set_x
= s_scm_slot_set_x
;
983 SCM_DEFINE (scm_slot_bound_p
, "slot-bound?", 2, 0, 0,
984 (SCM obj
, SCM slot_name
),
985 "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
987 #define FUNC_NAME s_scm_slot_bound_p
991 SCM_VALIDATE_INSTANCE (1, obj
);
992 TEST_CHANGE_CLASS(obj
, class);
994 return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
1002 SCM_DEFINE (scm_slot_exists_p
, "slot-exists?", 2, 0, 0,
1003 (SCM obj
, SCM slot_name
),
1004 "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
1005 #define FUNC_NAME s_scm_slot_exists_p
1009 SCM_VALIDATE_INSTANCE (1, obj
);
1010 SCM_VALIDATE_SYMBOL (2, slot_name
);
1011 TEST_CHANGE_CLASS (obj
, class);
1013 return test_slot_existence (class, obj
, slot_name
);
1018 /******************************************************************************
1020 * %allocate-instance (the low level instance allocation primitive)
1022 ******************************************************************************/
1024 static void clear_method_cache (SCM
);
1026 SCM_DEFINE (scm_sys_allocate_instance
, "%allocate-instance", 2, 0, 0,
1027 (SCM
class, SCM initargs
),
1028 "Create a new instance of class @var{class} and initialize it\n"
1029 "from the arguments @var{initargs}.")
1030 #define FUNC_NAME s_scm_sys_allocate_instance
1033 scm_t_signed_bits n
, i
;
1036 SCM_VALIDATE_CLASS (1, class);
1038 /* FIXME: duplicates some of scm_make_struct. */
1040 n
= SCM_I_INUM (SCM_SLOT (class, scm_si_nfields
));
1041 obj
= scm_i_alloc_struct (SCM_STRUCT_DATA (class), n
);
1043 layout
= SCM_VTABLE_LAYOUT (class);
1045 /* Set all SCM-holding slots to unbound */
1046 for (i
= 0; i
< n
; i
++)
1048 scm_t_wchar c
= scm_i_symbol_ref (layout
, i
*2);
1050 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (SCM_GOOPS_UNBOUND
);
1052 SCM_STRUCT_DATA (obj
)[i
] = SCM_UNPACK (obj
);
1054 SCM_STRUCT_DATA (obj
)[i
] = 0;
1057 if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC
)
1058 clear_method_cache (obj
);
1064 SCM_DEFINE (scm_sys_set_object_setter_x
, "%set-object-setter!", 2, 0, 0,
1065 (SCM obj
, SCM setter
),
1067 #define FUNC_NAME s_scm_sys_set_object_setter_x
1069 SCM_ASSERT (SCM_STRUCTP (obj
)
1070 && (SCM_OBJ_CLASS_FLAGS (obj
) & SCM_CLASSF_PURE_GENERIC
),
1074 SCM_SET_GENERIC_SETTER (obj
, setter
);
1075 return SCM_UNSPECIFIED
;
1079 /******************************************************************************
1081 * %modify-instance (used by change-class to modify in place)
1083 ******************************************************************************/
1085 SCM_DEFINE (scm_sys_modify_instance
, "%modify-instance", 2, 0, 0,
1088 #define FUNC_NAME s_scm_sys_modify_instance
1090 SCM_VALIDATE_INSTANCE (1, old
);
1091 SCM_VALIDATE_INSTANCE (2, new);
1093 /* Exchange the data contained in old and new. We exchange rather than
1094 * scratch the old value with new to be correct with GC.
1095 * See "Class redefinition protocol above".
1097 SCM_CRITICAL_SECTION_START
;
1099 scm_t_bits word0
, word1
;
1100 word0
= SCM_CELL_WORD_0 (old
);
1101 word1
= SCM_CELL_WORD_1 (old
);
1102 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1103 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1104 SCM_SET_CELL_WORD_0 (new, word0
);
1105 SCM_SET_CELL_WORD_1 (new, word1
);
1107 SCM_CRITICAL_SECTION_END
;
1108 return SCM_UNSPECIFIED
;
1112 SCM_DEFINE (scm_sys_modify_class
, "%modify-class", 2, 0, 0,
1115 #define FUNC_NAME s_scm_sys_modify_class
1117 SCM_VALIDATE_CLASS (1, old
);
1118 SCM_VALIDATE_CLASS (2, new);
1120 SCM_CRITICAL_SECTION_START
;
1122 scm_t_bits word0
, word1
;
1123 word0
= SCM_CELL_WORD_0 (old
);
1124 word1
= SCM_CELL_WORD_1 (old
);
1125 SCM_SET_CELL_WORD_0 (old
, SCM_CELL_WORD_0 (new));
1126 SCM_SET_CELL_WORD_1 (old
, SCM_CELL_WORD_1 (new));
1127 SCM_STRUCT_DATA (old
)[scm_vtable_index_self
] = SCM_UNPACK (old
);
1128 SCM_SET_CELL_WORD_0 (new, word0
);
1129 SCM_SET_CELL_WORD_1 (new, word1
);
1130 SCM_STRUCT_DATA (new)[scm_vtable_index_self
] = SCM_UNPACK (new);
1132 SCM_CRITICAL_SECTION_END
;
1133 return SCM_UNSPECIFIED
;
1137 SCM_DEFINE (scm_sys_invalidate_class
, "%invalidate-class", 1, 0, 0,
1140 #define FUNC_NAME s_scm_sys_invalidate_class
1142 SCM_VALIDATE_CLASS (1, class);
1143 SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID
);
1144 return SCM_UNSPECIFIED
;
1148 /* When instances change class, they finally get a new body, but
1149 * before that, they go through purgatory in hell. Odd as it may
1150 * seem, this data structure saves us from eternal suffering in
1151 * infinite recursions.
1154 static scm_t_bits
**hell
;
1155 static long n_hell
= 1; /* one place for the evil one himself */
1156 static long hell_size
= 4;
1157 static SCM hell_mutex
;
1163 for (i
= 1; i
< n_hell
; ++i
)
1164 if (SCM_STRUCT_DATA (o
) == hell
[i
])
1170 go_to_hell (void *o
)
1173 scm_lock_mutex (hell_mutex
);
1174 if (n_hell
>= hell_size
)
1177 hell
= scm_realloc (hell
, hell_size
* sizeof(*hell
));
1179 hell
[n_hell
++] = SCM_STRUCT_DATA (obj
);
1180 scm_unlock_mutex (hell_mutex
);
1184 go_to_heaven (void *o
)
1187 scm_lock_mutex (hell_mutex
);
1188 hell
[burnin (obj
)] = hell
[--n_hell
];
1189 scm_unlock_mutex (hell_mutex
);
1193 SCM_SYMBOL (scm_sym_change_class
, "change-class");
1196 purgatory (SCM obj
, SCM new_class
)
1198 return scm_call_2 (SCM_VARIABLE_REF (var_change_class
), obj
, new_class
);
1201 /* This function calls the generic function change-class for all
1202 * instances which aren't currently undergoing class change.
1206 scm_change_object_class (SCM obj
, SCM old_class SCM_UNUSED
, SCM new_class
)
1210 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
1211 scm_dynwind_rewind_handler (go_to_hell
, &obj
, SCM_F_WIND_EXPLICITLY
);
1212 scm_dynwind_unwind_handler (go_to_heaven
, &obj
, SCM_F_WIND_EXPLICITLY
);
1213 purgatory (obj
, new_class
);
1218 /******************************************************************************
1224 * GGG E N E R I C F U N C T I O N S
1226 * This implementation provides
1227 * - generic functions (with class specializers)
1230 * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
1232 ******************************************************************************/
1234 SCM_KEYWORD (k_name
, "name");
1236 SCM_GLOBAL_SYMBOL (scm_sym_args
, "args");
1238 SCM_SYMBOL (sym_delayed_compile
, "delayed-compile");
1240 static SCM delayed_compile_var
;
1243 init_delayed_compile_var (void)
1246 = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
1250 make_dispatch_procedure (SCM gf
)
1252 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
1253 scm_i_pthread_once (&once
, init_delayed_compile_var
);
1255 return scm_call_1 (scm_variable_ref (delayed_compile_var
), gf
);
1259 clear_method_cache (SCM gf
)
1261 SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf
, make_dispatch_procedure (gf
));
1262 SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf
);
1265 SCM_DEFINE (scm_sys_invalidate_method_cache_x
, "%invalidate-method-cache!", 1, 0, 0,
1268 #define FUNC_NAME s_scm_sys_invalidate_method_cache_x
1270 SCM_ASSERT (SCM_PUREGENERICP (gf
), gf
, SCM_ARG1
, FUNC_NAME
);
1271 clear_method_cache (gf
);
1272 return SCM_UNSPECIFIED
;
1276 SCM_DEFINE (scm_generic_capability_p
, "generic-capability?", 1, 0, 0,
1279 #define FUNC_NAME s_scm_generic_capability_p
1281 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
1282 proc
, SCM_ARG1
, FUNC_NAME
);
1283 return (SCM_PRIMITIVE_GENERIC_P (proc
) ? SCM_BOOL_T
: SCM_BOOL_F
);
1287 SCM_DEFINE (scm_enable_primitive_generic_x
, "enable-primitive-generic!", 0, 0, 1,
1290 #define FUNC_NAME s_scm_enable_primitive_generic_x
1292 SCM_VALIDATE_REST_ARGUMENT (subrs
);
1293 while (!scm_is_null (subrs
))
1295 SCM subr
= SCM_CAR (subrs
);
1296 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARGn
, FUNC_NAME
);
1297 SCM_SET_SUBR_GENERIC (subr
,
1298 scm_make (scm_list_3 (scm_class_generic
,
1300 SCM_SUBR_NAME (subr
))));
1301 subrs
= SCM_CDR (subrs
);
1303 return SCM_UNSPECIFIED
;
1307 SCM_DEFINE (scm_set_primitive_generic_x
, "set-primitive-generic!", 2, 0, 0,
1308 (SCM subr
, SCM generic
),
1310 #define FUNC_NAME s_scm_set_primitive_generic_x
1312 SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr
), subr
, SCM_ARG1
, FUNC_NAME
);
1313 SCM_ASSERT (SCM_PUREGENERICP (generic
), generic
, SCM_ARG2
, FUNC_NAME
);
1314 SCM_SET_SUBR_GENERIC (subr
, generic
);
1315 return SCM_UNSPECIFIED
;
1319 SCM_DEFINE (scm_primitive_generic_generic
, "primitive-generic-generic", 1, 0, 0,
1322 #define FUNC_NAME s_scm_primitive_generic_generic
1324 if (SCM_PRIMITIVE_GENERIC_P (subr
))
1326 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr
)))
1327 scm_enable_primitive_generic_x (scm_list_1 (subr
));
1328 return *SCM_SUBR_GENERIC (subr
);
1330 SCM_WRONG_TYPE_ARG (SCM_ARG1
, subr
);
1334 typedef struct t_extension
{
1335 struct t_extension
*next
;
1341 /* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
1343 static const char extension_gc_hint
[] = "GOOPS extension";
1345 static t_extension
*extensions
= 0;
1348 scm_c_extend_primitive_generic (SCM extended
, SCM extension
)
1353 if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended
)))
1354 scm_enable_primitive_generic_x (scm_list_1 (extended
));
1355 gf
= *SCM_SUBR_GENERIC (extended
);
1356 gext
= scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic
),
1358 SCM_SUBR_NAME (extension
));
1359 SCM_SET_SUBR_GENERIC (extension
, gext
);
1363 t_extension
*e
= scm_gc_malloc (sizeof (t_extension
),
1365 t_extension
**loc
= &extensions
;
1366 /* Make sure that extensions are placed before their own
1367 * extensions in the extensions list. O(N^2) algorithm, but
1368 * extensions of primitive generics are rare.
1370 while (*loc
&& !scm_is_eq (extension
, (*loc
)->extended
))
1371 loc
= &(*loc
)->next
;
1373 e
->extended
= extended
;
1374 e
->extension
= extension
;
1380 setup_extended_primitive_generics ()
1384 t_extension
*e
= extensions
;
1385 scm_c_extend_primitive_generic (e
->extended
, e
->extension
);
1386 extensions
= e
->next
;
1390 /* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
1391 * assumed that 'gf' is zero if uninitialized. It would be cleaner if
1392 * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
1396 scm_wta_dispatch_0 (SCM gf
, const char *subr
)
1398 if (!SCM_UNPACK (gf
))
1399 scm_error_num_args_subr (subr
);
1401 return scm_call_0 (gf
);
1405 scm_wta_dispatch_1 (SCM gf
, SCM a1
, int pos
, const char *subr
)
1407 if (!SCM_UNPACK (gf
))
1408 scm_wrong_type_arg (subr
, pos
, a1
);
1410 return scm_call_1 (gf
, a1
);
1414 scm_wta_dispatch_2 (SCM gf
, SCM a1
, SCM a2
, int pos
, const char *subr
)
1416 if (!SCM_UNPACK (gf
))
1417 scm_wrong_type_arg (subr
, pos
, (pos
== SCM_ARG1
) ? a1
: a2
);
1419 return scm_call_2 (gf
, a1
, a2
);
1423 scm_wta_dispatch_n (SCM gf
, SCM args
, int pos
, const char *subr
)
1425 if (!SCM_UNPACK (gf
))
1426 scm_wrong_type_arg (subr
, pos
, scm_list_ref (args
, scm_from_int (pos
)));
1428 return scm_apply_0 (gf
, args
);
1431 /******************************************************************************
1433 * Protocol for calling a generic fumction
1434 * This protocol is roughly equivalent to (parameter are a little bit different
1435 * for efficiency reasons):
1437 * + apply-generic (gf args)
1438 * + compute-applicable-methods (gf args ...)
1439 * + sort-applicable-methods (methods args)
1440 * + apply-methods (gf methods args)
1442 * apply-methods calls make-next-method to build the "continuation" of a a
1443 * method. Applying a next-method will call apply-next-method which in
1444 * turn will call apply again to call effectively the following method.
1446 ******************************************************************************/
1448 /******************************************************************************
1450 * A simple make (which will be redefined later in Scheme)
1451 * This version handles only creation of gf, methods and classes (no instances)
1453 * Since this code will disappear when Goops will be fully booted,
1454 * no precaution is taken to be efficient.
1456 ******************************************************************************/
1458 SCM_KEYWORD (k_setter
, "setter");
1459 SCM_KEYWORD (k_specializers
, "specializers");
1460 SCM_KEYWORD (k_procedure
, "procedure");
1461 SCM_KEYWORD (k_formals
, "formals");
1462 SCM_KEYWORD (k_body
, "body");
1463 SCM_KEYWORD (k_make_procedure
, "make-procedure");
1464 SCM_KEYWORD (k_dsupers
, "dsupers");
1465 SCM_KEYWORD (k_slots
, "slots");
1466 SCM_KEYWORD (k_gf
, "generic-function");
1468 SCM_DEFINE (scm_make
, "make", 0, 0, 1,
1470 "Make a new object. @var{args} must contain the class and\n"
1471 "all necessary initialization information.")
1472 #define FUNC_NAME s_scm_make
1475 long len
= scm_ilength (args
);
1477 if (len
<= 0 || (len
& 1) == 0)
1478 SCM_WRONG_NUM_ARGS ();
1480 class = SCM_CAR(args
);
1481 args
= SCM_CDR(args
);
1483 if (scm_is_eq (class, scm_class_generic
)
1484 || scm_is_eq (class, scm_class_accessor
))
1486 z
= scm_make_struct (class, SCM_INUM0
,
1487 scm_list_4 (SCM_BOOL_F
,
1491 scm_set_procedure_property_x (z
, scm_sym_name
,
1492 scm_get_keyword (k_name
,
1495 clear_method_cache (z
);
1496 if (scm_is_eq (class, scm_class_accessor
))
1498 SCM setter
= scm_get_keyword (k_setter
, args
, SCM_BOOL_F
);
1499 if (scm_is_true (setter
))
1500 scm_sys_set_object_setter_x (z
, setter
);
1505 z
= scm_sys_allocate_instance (class, args
);
1507 if (scm_is_eq (class, scm_class_method
)
1508 || scm_is_eq (class, scm_class_accessor_method
))
1510 SCM_SET_SLOT (z
, scm_si_generic_function
,
1511 scm_i_get_keyword (k_gf
,
1516 SCM_SET_SLOT (z
, scm_si_specializers
,
1517 scm_i_get_keyword (k_specializers
,
1522 SCM_SET_SLOT (z
, scm_si_procedure
,
1523 scm_i_get_keyword (k_procedure
,
1528 SCM_SET_SLOT (z
, scm_si_formals
,
1529 scm_i_get_keyword (k_formals
,
1534 SCM_SET_SLOT (z
, scm_si_body
,
1535 scm_i_get_keyword (k_body
,
1540 SCM_SET_SLOT (z
, scm_si_make_procedure
,
1541 scm_i_get_keyword (k_make_procedure
,
1549 /* In all the others case, make a new class .... No instance here */
1550 SCM_SET_SLOT (z
, scm_vtable_index_name
,
1551 scm_i_get_keyword (k_name
,
1554 scm_from_latin1_symbol ("???"),
1556 SCM_SET_SLOT (z
, scm_si_direct_supers
,
1557 scm_i_get_keyword (k_dsupers
,
1562 SCM_SET_SLOT (z
, scm_si_direct_slots
,
1563 scm_i_get_keyword (k_slots
,
1575 /**********************************************************************
1579 **********************************************************************/
1582 make_class_from_template (char const *template, char const *type_name
, SCM supers
, int applicablep
)
1589 sprintf (buffer
, template, type_name
);
1590 name
= scm_from_utf8_symbol (buffer
);
1593 name
= SCM_GOOPS_UNBOUND
;
1595 meta
= applicablep
? scm_class_procedure_class
: scm_class_class
;
1597 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
1601 make_class_from_symbol (SCM type_name_sym
, SCM supers
, int applicablep
)
1605 if (scm_is_true (type_name_sym
))
1607 name
= scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
1608 scm_symbol_to_string (type_name_sym
),
1609 scm_from_locale_string (">")));
1610 name
= scm_string_to_symbol (name
);
1613 name
= SCM_GOOPS_UNBOUND
;
1615 meta
= applicablep
? scm_class_procedure_class
: scm_class_class
;
1617 return scm_make_standard_class (meta
, name
, supers
, SCM_EOL
);
1621 scm_make_extended_class (char const *type_name
, int applicablep
)
1623 return make_class_from_template ("<%s>",
1625 scm_list_1 (applicablep
1626 ? scm_class_applicable
1632 scm_make_extended_class_from_symbol (SCM type_name_sym
, int applicablep
)
1634 return make_class_from_symbol (type_name_sym
,
1635 scm_list_1 (applicablep
1636 ? scm_class_applicable
1642 scm_i_inherit_applicable (SCM c
)
1644 if (!SCM_SUBCLASSP (c
, scm_class_applicable
))
1646 SCM dsupers
= SCM_SLOT (c
, scm_si_direct_supers
);
1647 SCM cpl
= SCM_SLOT (c
, scm_si_cpl
);
1648 /* patch scm_class_applicable into direct-supers */
1649 SCM top
= scm_c_memq (scm_class_top
, dsupers
);
1650 if (scm_is_false (top
))
1651 dsupers
= scm_append (scm_list_2 (dsupers
,
1652 scm_list_1 (scm_class_applicable
)));
1655 SCM_SETCAR (top
, scm_class_applicable
);
1656 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
1658 SCM_SET_SLOT (c
, scm_si_direct_supers
, dsupers
);
1659 /* patch scm_class_applicable into cpl */
1660 top
= scm_c_memq (scm_class_top
, cpl
);
1661 if (scm_is_false (top
))
1665 SCM_SETCAR (top
, scm_class_applicable
);
1666 SCM_SETCDR (top
, scm_cons (scm_class_top
, SCM_CDR (top
)));
1668 /* add class to direct-subclasses of scm_class_applicable */
1669 SCM_SET_SLOT (scm_class_applicable
,
1670 scm_si_direct_subclasses
,
1671 scm_cons (c
, SCM_SLOT (scm_class_applicable
,
1672 scm_si_direct_subclasses
)));
1677 create_smob_classes (void)
1681 for (i
= 0; i
< SCM_I_MAX_SMOB_TYPE_COUNT
; ++i
)
1682 scm_smob_class
[i
] = SCM_BOOL_F
;
1684 for (i
= 0; i
< scm_numsmob
; ++i
)
1685 if (scm_is_false (scm_smob_class
[i
]))
1686 scm_smob_class
[i
] = scm_make_extended_class (SCM_SMOBNAME (i
),
1687 scm_smobs
[i
].apply
!= 0);
1691 scm_make_port_classes (long ptobnum
, char *type_name
)
1693 SCM c
, class = make_class_from_template ("<%s-port>",
1695 scm_list_1 (scm_class_port
),
1697 scm_port_class
[SCM_IN_PCLASS_INDEX
+ ptobnum
]
1698 = make_class_from_template ("<%s-input-port>",
1700 scm_list_2 (class, scm_class_input_port
),
1702 scm_port_class
[SCM_OUT_PCLASS_INDEX
+ ptobnum
]
1703 = make_class_from_template ("<%s-output-port>",
1705 scm_list_2 (class, scm_class_output_port
),
1707 scm_port_class
[SCM_INOUT_PCLASS_INDEX
+ ptobnum
]
1709 = make_class_from_template ("<%s-input-output-port>",
1711 scm_list_2 (class, scm_class_input_output_port
),
1713 /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
1714 SCM_SET_SLOT (c
, scm_si_cpl
,
1715 scm_cons2 (c
, class, SCM_SLOT (scm_class_input_output_port
, scm_si_cpl
)));
1719 create_port_classes (void)
1723 for (i
= scm_c_num_port_types () - 1; i
>= 0; i
--)
1724 scm_make_port_classes (i
, SCM_PTOBNAME (i
));
1728 make_struct_class (void *closure SCM_UNUSED
,
1729 SCM vtable
, SCM data
, SCM prev SCM_UNUSED
)
1731 if (scm_is_false (data
))
1732 scm_i_define_class_for_vtable (vtable
);
1733 return SCM_UNSPECIFIED
;
1737 create_struct_classes (void)
1739 /* FIXME: take the vtable_class_map while initializing goops? */
1740 scm_internal_hash_fold (make_struct_class
, 0, SCM_BOOL_F
,
1744 /**********************************************************************
1748 **********************************************************************/
1753 if (!goops_loaded_p
)
1754 scm_c_resolve_module ("oop goops");
1759 scm_ensure_accessor (SCM name
)
1763 var
= scm_module_variable (scm_current_module (), name
);
1764 if (SCM_VARIABLEP (var
) && !SCM_UNBNDP (SCM_VARIABLE_REF (var
)))
1765 gf
= SCM_VARIABLE_REF (var
);
1769 if (!SCM_IS_A_P (gf
, scm_class_accessor
))
1771 gf
= scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
1772 gf
= scm_make (scm_list_5 (scm_class_accessor
,
1773 k_name
, name
, k_setter
, gf
));
1781 * Debugging utilities
1784 SCM_DEFINE (scm_pure_generic_p
, "pure-generic?", 1, 0, 0,
1786 "Return @code{#t} if @var{obj} is a pure generic.")
1787 #define FUNC_NAME s_scm_pure_generic_p
1789 return scm_from_bool (SCM_PUREGENERICP (obj
));
1793 #endif /* GUILE_DEBUG */
1799 SCM_DEFINE (scm_sys_bless_applicable_struct_vtable_x
, "%bless-applicable-struct-vtable!", 1, 0, 0,
1802 #define FUNC_NAME s_scm_sys_bless_applicable_struct_vtable_x
1804 SCM_VALIDATE_CLASS (1, vtable
);
1805 SCM_SET_VTABLE_FLAGS (vtable
, SCM_VTABLE_FLAG_APPLICABLE_VTABLE
);
1806 return SCM_UNSPECIFIED
;
1810 SCM_DEFINE (scm_sys_bless_pure_generic_vtable_x
, "%bless-pure-generic-vtable!", 1, 0, 0,
1813 #define FUNC_NAME s_scm_sys_bless_pure_generic_vtable_x
1815 SCM_VALIDATE_CLASS (1, vtable
);
1816 SCM_SET_CLASS_FLAGS (vtable
, SCM_CLASSF_PURE_GENERIC
);
1817 return SCM_UNSPECIFIED
;
1821 SCM_DEFINE (scm_sys_goops_early_init
, "%goops-early-init", 0, 0, 0,
1824 #define FUNC_NAME s_scm_sys_goops_early_init
1826 var_make_standard_class
= scm_c_lookup ("make-standard-class");
1828 scm_class_class
= scm_variable_ref (scm_c_lookup ("<class>"));
1829 scm_class_top
= scm_variable_ref (scm_c_lookup ("<top>"));
1830 scm_class_object
= scm_variable_ref (scm_c_lookup ("<object>"));
1832 scm_class_foreign_slot
= scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
1833 scm_class_protected
= scm_variable_ref (scm_c_lookup ("<protected-slot>"));
1834 scm_class_hidden
= scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
1835 scm_class_opaque
= scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
1836 scm_class_read_only
= scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
1837 scm_class_self
= scm_variable_ref (scm_c_lookup ("<self-slot>"));
1838 scm_class_protected_opaque
= scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
1839 scm_class_protected_hidden
= scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
1840 scm_class_protected_read_only
= scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
1841 scm_class_scm
= scm_variable_ref (scm_c_lookup ("<scm-slot>"));
1842 scm_class_int
= scm_variable_ref (scm_c_lookup ("<int-slot>"));
1843 scm_class_float
= scm_variable_ref (scm_c_lookup ("<float-slot>"));
1844 scm_class_double
= scm_variable_ref (scm_c_lookup ("<double-slot>"));
1846 /* scm_class_generic functions classes */
1847 scm_class_procedure_class
= scm_variable_ref (scm_c_lookup ("<procedure-class>"));
1848 scm_class_applicable_struct_class
= scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
1850 scm_class_method
= scm_variable_ref (scm_c_lookup ("<method>"));
1851 scm_class_accessor_method
= scm_variable_ref (scm_c_lookup ("<accessor-method>"));
1852 scm_class_applicable
= scm_variable_ref (scm_c_lookup ("<applicable>"));
1853 scm_class_applicable_struct
= scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
1854 scm_class_generic
= scm_variable_ref (scm_c_lookup ("<generic>"));
1855 scm_class_extended_generic
= scm_variable_ref (scm_c_lookup ("<extended-generic>"));
1856 scm_class_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
1857 scm_class_accessor
= scm_variable_ref (scm_c_lookup ("<accessor>"));
1858 scm_class_extended_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
1859 scm_class_extended_accessor
= scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
1861 /* Primitive types classes */
1862 scm_class_boolean
= scm_variable_ref (scm_c_lookup ("<boolean>"));
1863 scm_class_char
= scm_variable_ref (scm_c_lookup ("<char>"));
1864 scm_class_list
= scm_variable_ref (scm_c_lookup ("<list>"));
1865 scm_class_pair
= scm_variable_ref (scm_c_lookup ("<pair>"));
1866 scm_class_null
= scm_variable_ref (scm_c_lookup ("<null>"));
1867 scm_class_string
= scm_variable_ref (scm_c_lookup ("<string>"));
1868 scm_class_symbol
= scm_variable_ref (scm_c_lookup ("<symbol>"));
1869 scm_class_vector
= scm_variable_ref (scm_c_lookup ("<vector>"));
1870 class_foreign
= scm_variable_ref (scm_c_lookup ("<foreign>"));
1871 class_hashtable
= scm_variable_ref (scm_c_lookup ("<hashtable>"));
1872 class_fluid
= scm_variable_ref (scm_c_lookup ("<fluid>"));
1873 class_dynamic_state
= scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
1874 class_frame
= scm_variable_ref (scm_c_lookup ("<frame>"));
1875 class_vm_cont
= scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
1876 class_bytevector
= scm_variable_ref (scm_c_lookup ("<bytevector>"));
1877 class_uvec
= scm_variable_ref (scm_c_lookup ("<uvec>"));
1878 class_array
= scm_variable_ref (scm_c_lookup ("<array>"));
1879 class_bitvector
= scm_variable_ref (scm_c_lookup ("<bitvector>"));
1880 scm_class_number
= scm_variable_ref (scm_c_lookup ("<number>"));
1881 scm_class_complex
= scm_variable_ref (scm_c_lookup ("<complex>"));
1882 scm_class_real
= scm_variable_ref (scm_c_lookup ("<real>"));
1883 scm_class_integer
= scm_variable_ref (scm_c_lookup ("<integer>"));
1884 scm_class_fraction
= scm_variable_ref (scm_c_lookup ("<fraction>"));
1885 scm_class_keyword
= scm_variable_ref (scm_c_lookup ("<keyword>"));
1886 scm_class_unknown
= scm_variable_ref (scm_c_lookup ("<unknown>"));
1887 scm_class_procedure
= scm_variable_ref (scm_c_lookup ("<procedure>"));
1888 scm_class_primitive_generic
= scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
1889 scm_class_port
= scm_variable_ref (scm_c_lookup ("<port>"));
1890 scm_class_input_port
= scm_variable_ref (scm_c_lookup ("<input-port>"));
1891 scm_class_output_port
= scm_variable_ref (scm_c_lookup ("<output-port>"));
1892 scm_class_input_output_port
= scm_variable_ref (scm_c_lookup ("<input-output-port>"));
1894 create_smob_classes ();
1895 create_struct_classes ();
1896 create_port_classes ();
1899 SCM name
= scm_from_latin1_symbol ("no-applicable-method");
1900 scm_no_applicable_method
=
1901 scm_make (scm_list_3 (scm_class_generic
, k_name
, name
));
1902 scm_module_define (scm_module_goops
, name
, scm_no_applicable_method
);
1905 return SCM_UNSPECIFIED
;
1909 SCM_DEFINE (scm_sys_goops_loaded
, "%goops-loaded", 0, 0, 0,
1911 "Announce that GOOPS is loaded and perform initialization\n"
1912 "on the C level which depends on the loaded GOOPS modules.")
1913 #define FUNC_NAME s_scm_sys_goops_loaded
1917 scm_module_variable (scm_module_goops
, sym_slot_unbound
);
1919 scm_module_variable (scm_module_goops
, sym_slot_missing
);
1920 var_no_applicable_method
=
1921 scm_module_variable (scm_module_goops
, sym_no_applicable_method
);
1923 scm_module_variable (scm_module_goops
, sym_change_class
);
1924 setup_extended_primitive_generics ();
1925 return SCM_UNSPECIFIED
;
1929 SCM scm_module_goops
;
1932 scm_init_goops_builtins (void *unused
)
1934 scm_module_goops
= scm_current_module ();
1936 goops_rstate
= scm_c_make_rstate ("GOOPS", 5);
1938 hell
= scm_calloc (hell_size
* sizeof (*hell
));
1939 hell_mutex
= scm_make_mutex ();
1941 #include "libguile/goops.x"
1947 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1948 "scm_init_goops_builtins", scm_init_goops_builtins
,