#include "libguile/validate.h"
#include "libguile/goops.h"
-#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-
/* Port classes */
#define SCM_IN_PCLASS_INDEX 0
#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
} \
}
-#define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
-#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
-
#define SCM_GOOPS_UNBOUND SCM_UNBOUND
#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
SCM scm_no_applicable_method;
-SCM_SYMBOL (scm_sym_define_public, "define-public");
-
static SCM scm_make_unbound (void);
static SCM scm_unbound_p (SCM obj);
static SCM scm_assert_bound (SCM value, SCM obj);
static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
+static SCM scm_sys_goops_early_init (void);
static SCM scm_sys_goops_loaded (void);
static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
int applicablep);
}
#undef FUNC_NAME
-/******************************************************************************
- *
- * Compute-cpl
- *
- * This version doesn't fully handle multiple-inheritance. It serves
- * only for booting classes and will be overloaded in Scheme
- *
- ******************************************************************************/
-
-static SCM
-map (SCM (*proc) (SCM), SCM ls)
-{
- if (scm_is_null (ls))
- return ls;
- else
- {
- SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
- SCM h = res;
- ls = SCM_CDR (ls);
- while (scm_is_pair (ls))
- {
- SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
- h = SCM_CDR (h);
- ls = SCM_CDR (ls);
- }
- return res;
- }
-}
-
-static SCM
-filter_cpl (SCM ls)
-{
- SCM res = SCM_EOL;
- while (scm_is_pair (ls))
- {
- SCM el = SCM_CAR (ls);
- if (scm_is_false (scm_c_memq (el, res)))
- res = scm_cons (el, res);
- ls = SCM_CDR (ls);
- }
- return res;
-}
-
-static SCM
-compute_cpl (SCM class)
-{
- if (goops_loaded_p)
- return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
- else
- {
- SCM supers = SCM_SLOT (class, scm_si_direct_supers);
- SCM ls = scm_append (scm_acons (class, supers,
- map (compute_cpl, supers)));
- return scm_reverse_x (filter_cpl (ls), SCM_EOL);
- }
-}
-
/******************************************************************************
*
* compute-slots
"field cannot be redefined", SCM_EOL);
}
-static SCM
-build_class_class_slots (void);
+enum build_class_class_slots_mode { BOOT_SLOTS, FINAL_SLOTS };
+static SCM build_class_class_slots (enum build_class_class_slots_mode mode);
static SCM
build_slots_list (SCM dslots, SCM cpl)
if (classp)
{
- bslots = build_class_class_slots ();
+ bslots = build_class_class_slots (FINAL_SLOTS);
check_cpl (res, bslots);
}
else
/* Initialize its slots */
SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
- cpl = compute_cpl (z);
+ cpl = scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), z);
slots = build_slots_list (maplist (dslots), cpl);
nfields = scm_from_int (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
SCM_SYMBOL (sym_nfields, "nfields");
+static int specialized_slots_initialized = 0;
+
static SCM
-build_class_class_slots (void)
+build_class_class_slots (enum build_class_class_slots_mode mode)
{
+#define SPECIALIZED_SLOT(name, class) \
+ (mode == BOOT_SLOTS ? scm_list_1 (name) : scm_list_3 (name, k_class, class))
+
+ if (mode == FINAL_SLOTS && !specialized_slots_initialized)
+ abort ();
+
/* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
SCM_CLASS_CLASS_LAYOUT */
return scm_list_n (
- scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
- scm_list_3 (sym_flags, k_class, scm_class_hidden),
- scm_list_3 (sym_self, k_class, scm_class_self),
- scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden),
+ SPECIALIZED_SLOT (sym_layout, scm_class_protected_read_only),
+ SPECIALIZED_SLOT (sym_flags, scm_class_hidden),
+ SPECIALIZED_SLOT (sym_self, scm_class_self),
+ SPECIALIZED_SLOT (sym_instance_finalizer, scm_class_hidden),
scm_list_1 (sym_print),
- scm_list_3 (sym_name, k_class, scm_class_protected_hidden),
- scm_list_3 (sym_reserved_0, k_class, scm_class_hidden),
- scm_list_3 (sym_reserved_1, k_class, scm_class_hidden),
+ SPECIALIZED_SLOT (sym_name, scm_class_protected_hidden),
+ SPECIALIZED_SLOT (sym_reserved_0, scm_class_hidden),
+ SPECIALIZED_SLOT (sym_reserved_1, scm_class_hidden),
scm_list_1 (sym_redefined),
- scm_list_3 (sym_h0, k_class, scm_class_int),
- scm_list_3 (sym_h1, k_class, scm_class_int),
- scm_list_3 (sym_h2, k_class, scm_class_int),
- scm_list_3 (sym_h3, k_class, scm_class_int),
- scm_list_3 (sym_h4, k_class, scm_class_int),
- scm_list_3 (sym_h5, k_class, scm_class_int),
- scm_list_3 (sym_h6, k_class, scm_class_int),
- scm_list_3 (sym_h7, k_class, scm_class_int),
+ SPECIALIZED_SLOT (sym_h0, scm_class_int),
+ SPECIALIZED_SLOT (sym_h1, scm_class_int),
+ SPECIALIZED_SLOT (sym_h2, scm_class_int),
+ SPECIALIZED_SLOT (sym_h3, scm_class_int),
+ SPECIALIZED_SLOT (sym_h4, scm_class_int),
+ SPECIALIZED_SLOT (sym_h5, scm_class_int),
+ SPECIALIZED_SLOT (sym_h6, scm_class_int),
+ SPECIALIZED_SLOT (sym_h7, scm_class_int),
scm_list_1 (sym_direct_supers),
scm_list_1 (sym_direct_slots),
scm_list_1 (sym_direct_subclasses),
static void
create_basic_classes (void)
{
- /* SCM slots_of_class = build_class_class_slots (); */
+ SCM slots_of_class = build_class_class_slots (BOOT_SLOTS);
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
- /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); /* will be changed */
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
- /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
+ SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); /* will be changed */
SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
- /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
- compute_getters_n_setters (slots_of_class)); */
+ SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
+ compute_getters_n_setters (slots_of_class)); /* will be changed */
SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
prep_hashsets (scm_class_class);
*
******************************************************************************/
-static int
-applicablep (SCM actual, SCM formal)
-{
- /* We already know that the cpl is well formed. */
- return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
-}
-
-static int
-more_specificp (SCM m1, SCM m2, SCM const *targs)
-{
- register SCM s1, s2;
- register long i;
- /*
- * Note:
- * m1 and m2 can have != length (i.e. one can be one element longer than the
- * other when we have a dotted parameter list). For instance, with the call
- * (M 1)
- * with
- * (define-method M (a . l) ....)
- * (define-method M (a) ....)
- *
- * we consider that the second method is more specific.
- *
- * BTW, targs is an array of types. We don't need it's size since
- * we already know that m1 and m2 are applicable (no risk to go past
- * the end of this array).
- *
- */
- for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
- if (scm_is_null(s1)) return 1;
- if (scm_is_null(s2)) return 0;
- if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
- register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
-
- for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
- if (scm_is_eq (cs1, SCM_CAR (l)))
- return 1;
- if (scm_is_eq (cs2, SCM_CAR (l)))
- return 0;
- }
- return 0;/* should not occur! */
- }
- }
- return 0; /* should not occur! */
-}
-
-#define BUFFSIZE 32 /* big enough for most uses */
-
-static SCM
-scm_i_vector2list (SCM l, long len)
-{
- long j;
- SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
-
- for (j = 0; j < len; j++, l = SCM_CDR (l)) {
- SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
- }
- return z;
-}
-
-static SCM
-sort_applicable_methods (SCM method_list, long size, SCM const *targs)
-{
- long i, j, incr;
- SCM *v, vector = SCM_EOL;
- SCM buffer[BUFFSIZE];
- SCM save = method_list;
- scm_t_array_handle handle;
-
- /* For reasonably sized method_lists we can try to avoid all the
- * consing and reorder the list in place...
- * This idea is due to David McClain <Dave_McClain@msn.com>
- */
- if (size <= BUFFSIZE)
- {
- for (i = 0; i < size; i++)
- {
- buffer[i] = SCM_CAR (method_list);
- method_list = SCM_CDR (method_list);
- }
- v = buffer;
- }
- else
- {
- /* Too many elements in method_list to keep everything locally */
- vector = scm_i_vector2list (save, size);
- v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
- }
-
- /* Use a simple shell sort since it is generally faster than qsort on
- * small vectors (which is probably mostly the case when we have to
- * sort a list of applicable methods).
- */
- for (incr = size / 2; incr; incr /= 2)
- {
- for (i = incr; i < size; i++)
- {
- for (j = i - incr; j >= 0; j -= incr)
- {
- if (more_specificp (v[j], v[j+incr], targs))
- break;
- else
- {
- SCM tmp = v[j + incr];
- v[j + incr] = v[j];
- v[j] = tmp;
- }
- }
- }
- }
-
- if (size <= BUFFSIZE)
- {
- /* We did it in locally, so restore the original list (reordered) in-place */
- for (i = 0, method_list = save; i < size; i++, v++)
- {
- SCM_SETCAR (method_list, *v);
- method_list = SCM_CDR (method_list);
- }
- return save;
- }
-
- /* If we are here, that's that we did it the hard way... */
- scm_array_handle_release (&handle);
- return scm_vector_to_list (vector);
-}
-
-SCM
-scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
-{
- register long i;
- long count = 0;
- SCM l, fl, applicable = SCM_EOL;
- SCM save = args;
- SCM buffer[BUFFSIZE];
- SCM const *types;
- SCM *p;
- SCM tmp = SCM_EOL;
- scm_t_array_handle handle;
-
- /* Build the list of arguments types */
- if (len >= BUFFSIZE)
- {
- tmp = scm_c_make_vector (len, SCM_UNDEFINED);
- types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
-
- /*
- note that we don't have to work to reset the generation
- count. TMP is a new vector anyway, and it is found
- conservatively.
- */
- }
- else
- types = p = buffer;
-
- for ( ; !scm_is_null (args); args = SCM_CDR (args))
- *p++ = scm_class_of (SCM_CAR (args));
-
- /* Build a list of all applicable methods */
- for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
- {
- fl = SPEC_OF (SCM_CAR (l));
- for (i = 0; ; i++, fl = SCM_CDR (fl))
- {
- if (SCM_INSTANCEP (fl)
- /* We have a dotted argument list */
- || (i >= len && scm_is_null (fl)))
- { /* both list exhausted */
- applicable = scm_cons (SCM_CAR (l), applicable);
- count += 1;
- break;
- }
- if (i >= len
- || scm_is_null (fl)
- || !applicablep (types[i], SCM_CAR (fl)))
- break;
- }
- }
-
- if (len >= BUFFSIZE)
- scm_array_handle_release (&handle);
-
- if (count == 0)
- {
- if (find_method_p)
- return SCM_BOOL_F;
- scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save);
- /* if we are here, it's because no-applicable-method hasn't signaled an error */
- return SCM_BOOL_F;
- }
-
- return (count == 1
- ? applicable
- : sort_applicable_methods (applicable, count, types));
-}
-
-#if 0
-SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
-#endif
-
-static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
-
-SCM
-scm_sys_compute_applicable_methods (SCM gf, SCM args)
-#define FUNC_NAME s_sys_compute_applicable_methods
-{
- long n;
- SCM_VALIDATE_GENERIC (1, gf);
- n = scm_ilength (args);
- SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
- return scm_compute_applicable_methods (gf, args, n, 1);
-}
-#undef FUNC_NAME
-
-SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
-SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods",
- scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0,
- scm_sys_compute_applicable_methods));
-
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
- (SCM l),
- "")
-#define FUNC_NAME s_scm_find_method
-{
- SCM gf;
- long len = scm_ilength (l);
-
- if (len == 0)
- SCM_WRONG_NUM_ARGS ();
-
- gf = SCM_CAR(l); l = SCM_CDR(l);
- SCM_VALIDATE_GENERIC (1, gf);
- if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
- SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
-
- return scm_compute_applicable_methods (gf, l, len - 1, 1);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
- (SCM m1, SCM m2, SCM targs),
- "Return true if method @var{m1} is more specific than @var{m2} "
- "given the argument types (classes) listed in @var{targs}.")
-#define FUNC_NAME s_scm_sys_method_more_specific_p
-{
- SCM l, v, result;
- SCM *v_elts;
- long i, len, m1_specs, m2_specs;
- scm_t_array_handle handle;
-
- SCM_VALIDATE_METHOD (1, m1);
- SCM_VALIDATE_METHOD (2, m2);
-
- len = scm_ilength (targs);
- m1_specs = scm_ilength (SPEC_OF (m1));
- m2_specs = scm_ilength (SPEC_OF (m2));
- SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
- targs, SCM_ARG3, FUNC_NAME);
-
- /* Verify that all the arguments of TARGS are classes and place them
- in a vector. */
-
- v = scm_c_make_vector (len, SCM_EOL);
- v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
-
- for (i = 0, l = targs;
- i < len && scm_is_pair (l);
- i++, l = SCM_CDR (l))
- {
- SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
- v_elts[i] = SCM_CAR (l);
- }
- result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
-
- scm_array_handle_release (&handle);
-
- return result;
-}
-#undef FUNC_NAME
-
-
/******************************************************************************
*
*
******************************************************************************/
-/* Munge the CPL of C in place such that BEFORE appears before AFTER,
- assuming that currently the reverse is true. Recalculate slots and
- associated getters-n-setters. */
-static void
-fix_cpl (SCM c, SCM before, SCM after)
-{
- SCM cpl = SCM_SLOT (c, scm_si_cpl);
- SCM ls = scm_c_memq (after, cpl);
- SCM tail;
-
- if (scm_is_false (ls))
- /* if this condition occurs, fix_cpl should not be applied this way */
- abort ();
-
- tail = scm_delq1_x (before, SCM_CDR (ls));
- SCM_SETCAR (ls, before);
- SCM_SETCDR (ls, scm_cons (after, tail));
- {
- SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
- SCM slots = build_slots_list (maplist (dslots), cpl);
- SCM g_n_s = compute_getters_n_setters (slots);
- SCM_SET_SLOT (c, scm_si_slots, slots);
- SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
- }
-}
-
-
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
make_stdcls (&scm_class_double, "<double-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
- /* Continue initialization of class <class> */
+ specialized_slots_initialized = 1;
+
+ /* Finish initialization of class <class> */
- slots = build_class_class_slots ();
+ slots = build_class_class_slots (FINAL_SLOTS);
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);
- /* <extended-generic> is misplaced. */
- fix_cpl (scm_class_extended_accessor,
- scm_class_extended_generic, scm_class_generic_with_setter);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
* Initialization
*/
+SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_sys_goops_early_init
+{
+ create_basic_classes ();
+ create_standard_classes ();
+ create_smob_classes ();
+ create_struct_classes ();
+ create_port_classes ();
+
+ {
+ SCM name = scm_from_latin1_symbol ("no-applicable-method");
+ scm_no_applicable_method =
+ scm_make (scm_list_3 (scm_class_generic, k_name, name));
+ scm_module_define (scm_module_goops, name, scm_no_applicable_method);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
(),
"Announce that GOOPS is loaded and perform initialization\n"
#define FUNC_NAME s_scm_sys_goops_loaded
{
goops_loaded_p = 1;
- var_compute_applicable_methods =
- scm_module_variable (scm_module_goops, sym_compute_applicable_methods);
var_slot_unbound =
scm_module_variable (scm_module_goops, sym_slot_unbound);
var_slot_missing =
scm_module_variable (scm_module_goops, sym_slot_missing);
- var_compute_cpl =
- scm_module_variable (scm_module_goops, sym_compute_cpl);
var_no_applicable_method =
scm_module_variable (scm_module_goops, sym_no_applicable_method);
var_change_class =
SCM scm_module_goops;
-SCM
-scm_init_goops_builtins (void)
+static void
+scm_init_goops_builtins (void *unused)
{
scm_module_goops = scm_current_module ();
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
-#include "libguile/goops.x"
-
hell = scm_calloc (hell_size * sizeof (*hell));
hell_mutex = scm_make_mutex ();
- create_basic_classes ();
- create_standard_classes ();
- create_smob_classes ();
- create_struct_classes ();
- create_port_classes ();
-
- {
- SCM name = scm_from_latin1_symbol ("no-applicable-method");
- scm_no_applicable_method =
- scm_make (scm_list_3 (scm_class_generic, k_name, name));
- scm_module_define (scm_module_goops, name, scm_no_applicable_method);
- }
+#include "libguile/goops.x"
- return SCM_UNSPECIFIED;
+ var_compute_cpl =
+ scm_module_variable (scm_module_goops, sym_compute_cpl);
}
void
scm_init_goops ()
{
- scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
- scm_init_goops_builtins);
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_goops_builtins", scm_init_goops_builtins,
+ NULL);
}
/*
HCoop / bpt / guile.git / blobdiff