X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/2b7692bcc4f13b0778280df9420dde7d14c95a4a..567a6d1ee7efc3982748d3bd894057a76f076706:/libguile/goops.c diff --git a/libguile/goops.c b/libguile/goops.c index 34d12cde4..286f3c7dc 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -64,9 +64,17 @@ References to ordinary procedures is by reference (by variable), though, as in the rest of Guile. */ +SCM_KEYWORD (k_name, "name"); +SCM_KEYWORD (k_setter, "setter"); +SCM_SYMBOL (sym_redefined, "redefined"); +SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); + +static int goops_loaded_p = 0; + static SCM var_make_standard_class = SCM_BOOL_F; static SCM var_change_class = SCM_BOOL_F; static SCM var_make = SCM_BOOL_F; +static SCM var_inherit_applicable = SCM_BOOL_F; static SCM var_class_name = SCM_BOOL_F; static SCM var_class_direct_supers = SCM_BOOL_F; static SCM var_class_direct_slots = SCM_BOOL_F; @@ -80,27 +88,11 @@ static SCM var_method_generic_function = SCM_BOOL_F; static SCM var_method_specializers = SCM_BOOL_F; static SCM var_method_procedure = SCM_BOOL_F; -static SCM var_slot_ref_using_class = SCM_BOOL_F; -static SCM var_slot_set_using_class_x = SCM_BOOL_F; -static SCM var_slot_bound_using_class_p = SCM_BOOL_F; -static SCM var_slot_exists_using_class_p = SCM_BOOL_F; - static SCM var_slot_ref = SCM_BOOL_F; static SCM var_slot_set_x = SCM_BOOL_F; static SCM var_slot_bound_p = SCM_BOOL_F; static SCM var_slot_exists_p = SCM_BOOL_F; - -SCM_SYMBOL (sym_change_class, "change-class"); - -SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); - - -#define SCM_GOOPS_UNBOUND SCM_UNBOUND -#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND)) - -static int goops_loaded_p = 0; - /* These variables are filled in by the object system when loaded. */ static SCM class_boolean, class_char, class_pair; static SCM class_procedure, class_string, class_symbol; @@ -152,18 +144,53 @@ SCM scm_i_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT]; /* SMOB classes. */ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT]; -static SCM scm_make_unbound (void); -static SCM scm_unbound_p (SCM obj); -static SCM scm_class_p (SCM obj); -static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable, - SCM setter); -static SCM scm_sys_make_root_class (SCM name, SCM dslots, - SCM getters_n_setters); +SCM scm_module_goops; + +static SCM scm_sys_make_vtable_vtable (SCM layout); static SCM scm_sys_init_layout_x (SCM class, SCM layout); +static SCM scm_sys_clear_fields_x (SCM obj, SCM unbound); static SCM scm_sys_goops_early_init (void); static SCM scm_sys_goops_loaded (void); + + +SCM_DEFINE (scm_sys_make_vtable_vtable, "%make-vtable-vtable", 1, 0, 0, + (SCM layout), + "") +#define FUNC_NAME s_scm_sys_make_vtable_vtable +{ + return scm_i_make_vtable_vtable (layout); +} +#undef FUNC_NAME + +SCM +scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots) +{ + return scm_call_4 (scm_variable_ref (var_make_standard_class), + meta, name, dsupers, dslots); +} + +SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0, + (SCM class, SCM layout), + "") +#define FUNC_NAME s_scm_sys_init_layout_x +{ + SCM_VALIDATE_INSTANCE (1, class); + SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME); + SCM_VALIDATE_STRING (2, layout); + + SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout)); + scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class); + SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + + /* This function is used for efficient type dispatch. */ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, (SCM x), @@ -255,14 +282,16 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) + /* A GOOPS object with a valid class. */ return SCM_CLASS_OF (x); else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) + /* A GOOPS object whose class might have been redefined. */ { - /* Goops object */ - if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x))) - scm_change_object_class (x, - SCM_CLASS_OF (x), /* old */ - SCM_OBJ_CLASS_REDEF (x)); /* new */ + SCM class = SCM_CLASS_OF (x); + SCM new_class = scm_slot_ref (class, sym_redefined); + if (!scm_is_false (new_class)) + scm_change_object_class (x, class, new_class); + /* Re-load class from instance. */ return SCM_CLASS_OF (x); } else @@ -285,193 +314,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, } #undef FUNC_NAME -/****************************************************************************** - * - * initialize-object - * - ******************************************************************************/ - -/*fixme* Manufacture keywords in advance */ -SCM -scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr) -{ - long i; - - for (i = 0; i != len; i += 2) - { - SCM obj = SCM_CAR (l); - - if (!scm_is_keyword (obj)) - scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj)); - else if (scm_is_eq (obj, key)) - return SCM_CADR (l); - else - l = SCM_CDDR (l); - } - - return default_value; -} - - -SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, - (SCM key, SCM l, SCM default_value), - "Determine an associated value for the keyword @var{key} from\n" - "the list @var{l}. The list @var{l} has to consist of an even\n" - "number of elements, where, starting with the first, every\n" - "second element is a keyword, followed by its associated value.\n" - "If @var{l} does not hold a value for @var{key}, the value\n" - "@var{default_value} is returned.") -#define FUNC_NAME s_scm_get_keyword -{ - long len; - - SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME); - len = scm_ilength (l); - if (len < 0 || len % 2 == 1) - scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l)); - - return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME); -} -#undef FUNC_NAME - - -SCM_KEYWORD (k_init_keyword, "init-keyword"); - - -SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, - (SCM obj, SCM initargs), - "Initialize the object @var{obj} with the given arguments\n" - "@var{initargs}.") -#define FUNC_NAME s_scm_sys_initialize_object -{ - SCM tmp, get_n_set, slots; - SCM class = SCM_CLASS_OF (obj); - long n_initargs; - - SCM_VALIDATE_INSTANCE (1, obj); - n_initargs = scm_ilength (initargs); - SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME); - - get_n_set = SCM_SLOT (class, scm_si_getters_n_setters); - slots = SCM_SLOT (class, scm_si_slots); - - /* See for each slot how it must be initialized */ - for (; - !scm_is_null (slots); - get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots)) - { - SCM slot_name = SCM_CAR (slots); - SCM slot_value = SCM_GOOPS_UNBOUND; - - if (!scm_is_null (SCM_CDR (slot_name))) - { - /* This slot admits (perhaps) to be initialized at creation time */ - long n = scm_ilength (SCM_CDR (slot_name)); - if (n & 1) /* odd or -1 */ - SCM_MISC_ERROR ("class contains bogus slot definition: ~S", - scm_list_1 (slot_name)); - tmp = scm_i_get_keyword (k_init_keyword, - SCM_CDR (slot_name), - n, - SCM_PACK (0), - FUNC_NAME); - slot_name = SCM_CAR (slot_name); - if (SCM_UNPACK (tmp)) - { - /* an initarg was provided for this slot */ - if (!scm_is_keyword (tmp)) - SCM_MISC_ERROR ("initarg must be a keyword. It was ~S", - scm_list_1 (tmp)); - slot_value = scm_i_get_keyword (tmp, - initargs, - n_initargs, - SCM_GOOPS_UNBOUND, - FUNC_NAME); - } - } - - if (!SCM_GOOPS_UNBOUNDP (slot_value)) - /* set slot to provided value */ - scm_slot_set_x (obj, slot_name, slot_value); - else - { - /* set slot to its :init-form if it exists */ - tmp = SCM_CADAR (get_n_set); - if (scm_is_true (tmp)) - scm_slot_set_x (obj, slot_name, scm_call_0 (tmp)); - } - } - - return obj; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0, - (SCM class, SCM layout), - "") -#define FUNC_NAME s_scm_sys_init_layout_x -{ - SCM_VALIDATE_INSTANCE (1, class); - SCM_ASSERT (!scm_is_symbol (SCM_VTABLE_LAYOUT (class)), class, 1, FUNC_NAME); - SCM_VALIDATE_STRING (2, layout); - - SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout)); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, - (SCM class, SCM dsupers), - "") -#define FUNC_NAME s_scm_sys_inherit_magic_x -{ - SCM_VALIDATE_INSTANCE (1, class); - scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class); - SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -/******************************************************************************/ - -SCM -scm_make_standard_class (SCM meta, SCM name, SCM dsupers, SCM dslots) -{ - return scm_call_4 (scm_variable_ref (var_make_standard_class), - meta, name, dsupers, dslots); -} - -/******************************************************************************/ - -SCM_DEFINE (scm_sys_make_root_class, "%make-root-class", 3, 0, 0, - (SCM name, SCM dslots, SCM getters_n_setters), - "") -#define FUNC_NAME s_scm_sys_make_root_class -{ - SCM cs, z; - - cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT); - z = scm_i_make_vtable_vtable (cs); - SCM_SET_CLASS_FLAGS (z, (SCM_CLASSF_GOOPS_OR_VALID - | SCM_CLASSF_METACLASS)); - - SCM_SET_SLOT (z, scm_vtable_index_name, name); - SCM_SET_SLOT (z, scm_si_direct_supers, SCM_EOL); /* will be changed */ - SCM_SET_SLOT (z, scm_si_direct_slots, dslots); /* will be changed */ - SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL); - SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL); - SCM_SET_SLOT (z, scm_si_cpl, SCM_EOL); /* will be changed */ - SCM_SET_SLOT (z, scm_si_slots, dslots); /* will be changed */ - SCM_SET_SLOT (z, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS)); - SCM_SET_SLOT (z, scm_si_getters_n_setters, getters_n_setters); /* will be changed */ - SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F); - - return z; -} -#undef FUNC_NAME -/******************************************************************************/ + SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, (SCM obj), @@ -482,15 +326,6 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_class_p, "class?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a class.") -#define FUNC_NAME s_scm_class_p -{ - return scm_from_bool (SCM_CLASSP (obj)); -} -#undef FUNC_NAME - int scm_is_generic (SCM x) { @@ -503,13 +338,8 @@ scm_is_method (SCM x) return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method); } -/****************************************************************************** - * - * Meta object accessors - * - ******************************************************************************/ -SCM_SYMBOL (sym_procedure, "procedure"); + SCM scm_class_name (SCM obj) @@ -553,6 +383,9 @@ scm_class_slots (SCM obj) return scm_call_1 (scm_variable_ref (var_class_slots), obj); } + + + SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, (SCM obj), "Return the name of the generic function @var{obj}.") @@ -587,61 +420,9 @@ scm_method_procedure (SCM obj) return scm_call_1 (scm_variable_ref (var_method_procedure), obj); } -/****************************************************************************** - * - * S l o t a c c e s s - * - ******************************************************************************/ - -SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0, - (), - "Return the unbound value.") -#define FUNC_NAME s_scm_make_unbound -{ - return SCM_GOOPS_UNBOUND; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is unbound.") -#define FUNC_NAME s_scm_unbound_p -{ - return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM -scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name) -{ - return scm_call_3 (scm_variable_ref (var_slot_ref_using_class), - class, obj, slot_name); -} - -SCM -scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value) -{ - return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x), - class, obj, slot_name, value); -} - -SCM -scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name) -{ - return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p), - class, obj, slot_name); -} - -SCM -scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name) -{ - return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p), - class, obj, slot_name); -} - SCM scm_slot_ref (SCM obj, SCM slot_name) { @@ -667,56 +448,37 @@ scm_slot_exists_p (SCM obj, SCM slot_name) } -/****************************************************************************** - * - * %allocate-instance (the low level instance allocation primitive) - * - ******************************************************************************/ + -SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, - (SCM class, SCM initargs), - "Create a new instance of class @var{class} and initialize it\n" - "from the arguments @var{initargs}.") -#define FUNC_NAME s_scm_sys_allocate_instance +SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0, + (SCM obj, SCM unbound), + "") +#define FUNC_NAME s_scm_sys_clear_fields_x { - SCM obj; scm_t_signed_bits n, i; - SCM layout; - - SCM_VALIDATE_CLASS (1, class); + SCM vtable, layout; - /* FIXME: duplicates some of scm_make_struct. */ + SCM_VALIDATE_STRUCT (1, obj); + vtable = SCM_STRUCT_VTABLE (obj); - n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); - obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n); + n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); + layout = SCM_VTABLE_LAYOUT (vtable); - layout = SCM_VTABLE_LAYOUT (class); - - /* Set all SCM-holding slots to unbound */ + /* Set all SCM-holding slots to the GOOPS unbound value. */ for (i = 0; i < n; i++) - { - scm_t_wchar c = scm_i_symbol_ref (layout, i*2); - if (c == 'p') - SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND); - else if (c == 's') - SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj); - else - SCM_STRUCT_DATA (obj)[i] = 0; - } + if (scm_i_symbol_ref (layout, i*2) == 'p') + SCM_STRUCT_SLOT_SET (obj, i, unbound); - return obj; + return SCM_UNSPECIFIED; } #undef FUNC_NAME -/****************************************************************************** - * - * %modify-instance (used by change-class to modify in place) - * - ******************************************************************************/ + + SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, (SCM old, SCM new), - "") + "Used by change-class to modify objects in place.") #define FUNC_NAME s_scm_sys_modify_instance { SCM_VALIDATE_INSTANCE (1, old); @@ -766,17 +528,6 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0, - (SCM class), - "") -#define FUNC_NAME s_scm_sys_invalidate_class -{ - SCM_VALIDATE_CLASS (1, class); - SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - /* When instances change class, they finally get a new body, but * before that, they go through purgatory in hell. Odd as it may * seem, this data structure saves us from eternal suffering in @@ -822,8 +573,6 @@ go_to_heaven (void *o) } -SCM_SYMBOL (scm_sym_change_class, "change-class"); - static SCM purgatory (SCM obj, SCM new_class) { @@ -847,24 +596,11 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) } } -/****************************************************************************** - * - * GGGG FFFFF - * G F - * G GG FFF - * G G F - * GGG E N E R I C F U N C T I O N S - * - * This implementation provides - * - generic functions (with class specializers) - * - multi-methods - * - next-method - * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf - * - ******************************************************************************/ -SCM_KEYWORD (k_name, "name"); -SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); + + +/* Primitive generics: primitives that can dispatch to generics if their + arguments fail to apply. */ SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0, (SCM proc), @@ -924,67 +660,6 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, } #undef FUNC_NAME -typedef struct t_extension { - struct t_extension *next; - SCM extended; - SCM extension; -} t_extension; - - -/* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension' - objects. */ -static const char extension_gc_hint[] = "GOOPS extension"; - -static t_extension *extensions = 0; - -void -scm_c_extend_primitive_generic (SCM extended, SCM extension) -{ - if (goops_loaded_p) - { - SCM gf, gext; - if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended))) - scm_enable_primitive_generic_x (scm_list_1 (extended)); - gf = *SCM_SUBR_GENERIC (extended); - gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), - gf, - SCM_SUBR_NAME (extension)); - SCM_SET_SUBR_GENERIC (extension, gext); - } - else - { - t_extension *e = scm_gc_malloc (sizeof (t_extension), - extension_gc_hint); - t_extension **loc = &extensions; - /* Make sure that extensions are placed before their own - * extensions in the extensions list. O(N^2) algorithm, but - * extensions of primitive generics are rare. - */ - while (*loc && !scm_is_eq (extension, (*loc)->extended)) - loc = &(*loc)->next; - e->next = *loc; - e->extended = extended; - e->extension = extension; - *loc = e; - } -} - -static void -setup_extended_primitive_generics () -{ - while (extensions) - { - t_extension *e = extensions; - scm_c_extend_primitive_generic (e->extended, e->extension); - extensions = e->next; - } -} - -/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is - * assumed that 'gf' is zero if uninitialized. It would be cleaner if - * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen. - */ - SCM scm_wta_dispatch_0 (SCM gf, const char *subr) { @@ -1021,39 +696,19 @@ scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr) return scm_apply_0 (gf, args); } -/****************************************************************************** - * - * Protocol for calling a generic fumction - * This protocol is roughly equivalent to (parameter are a little bit different - * for efficiency reasons): - * - * + apply-generic (gf args) - * + compute-applicable-methods (gf args ...) - * + sort-applicable-methods (methods args) - * + apply-methods (gf methods args) - * - * apply-methods calls make-next-method to build the "continuation" of a a - * method. Applying a next-method will call apply-next-method which in - * turn will call apply again to call effectively the following method. - * - ******************************************************************************/ -SCM_DEFINE (scm_make, "make", 0, 0, 1, - (SCM args), - "Make a new object. @var{args} must contain the class and\n" - "all necessary initialization information.") -#define FUNC_NAME s_scm_make + + +SCM +scm_make (SCM args) { return scm_apply_0 (scm_variable_ref (var_make), args); } -#undef FUNC_NAME -/********************************************************************** - * - * Smob classes - * - **********************************************************************/ + + +/* SMOB, struct, and port classes. */ static SCM make_class_name (const char *prefix, const char *type_name, const char *suffix) @@ -1085,36 +740,7 @@ scm_make_extended_class (char const *type_name, int applicablep) void scm_i_inherit_applicable (SCM c) { - if (!SCM_SUBCLASSP (c, class_applicable)) - { - SCM dsupers = SCM_SLOT (c, scm_si_direct_supers); - SCM cpl = SCM_SLOT (c, scm_si_cpl); - /* patch class_applicable into direct-supers */ - SCM top = scm_c_memq (class_top, dsupers); - if (scm_is_false (top)) - dsupers = scm_append (scm_list_2 (dsupers, - scm_list_1 (class_applicable))); - else - { - SCM_SETCAR (top, class_applicable); - SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top))); - } - SCM_SET_SLOT (c, scm_si_direct_supers, dsupers); - /* patch class_applicable into cpl */ - top = scm_c_memq (class_top, cpl); - if (scm_is_false (top)) - abort (); - else - { - SCM_SETCAR (top, class_applicable); - SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top))); - } - /* add class to direct-subclasses of class_applicable */ - SCM_SET_SLOT (class_applicable, - scm_si_direct_subclasses, - scm_cons (c, SCM_SLOT (class_applicable, - scm_si_direct_subclasses))); - } + scm_call_1 (scm_variable_ref (var_inherit_applicable), c); } static void @@ -1246,11 +872,8 @@ create_struct_classes (void) vtable_class_map); } -/********************************************************************** - * - * C interface - * - **********************************************************************/ + + void scm_load_goops () @@ -1259,9 +882,6 @@ scm_load_goops () scm_c_resolve_module ("oop goops"); } - -SCM_KEYWORD (k_setter, "setter"); - SCM scm_ensure_accessor (SCM name) { @@ -1283,22 +903,8 @@ scm_ensure_accessor (SCM name) return gf; } -/* - * Initialization - */ -SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0, - (SCM applicable, SCM setter), - "") -#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x -{ - SCM_VALIDATE_CLASS (1, applicable); - SCM_VALIDATE_CLASS (2, setter); - SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); - SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME + SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, (), @@ -1307,11 +913,10 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, { var_make_standard_class = scm_c_lookup ("make-standard-class"); var_make = scm_c_lookup ("make"); + var_inherit_applicable = scm_c_lookup ("inherit-applicable!"); - var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class"); - var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!"); - var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?"); - var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?"); + /* For SCM_SUBCLASSP. */ + var_class_precedence_list = scm_c_lookup ("class-precedence-list"); var_slot_ref = scm_c_lookup ("slot-ref"); var_slot_set_x = scm_c_lookup ("slot-set!"); @@ -1407,7 +1012,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, var_class_direct_slots = scm_c_lookup ("class-direct-slots"); var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses"); var_class_direct_methods = scm_c_lookup ("class-direct-methods"); - var_class_precedence_list = scm_c_lookup ("class-precedence-list"); var_class_slots = scm_c_lookup ("class-slots"); var_generic_function_methods = scm_c_lookup ("generic-function-methods"); @@ -1415,9 +1019,7 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, var_method_specializers = scm_c_lookup ("method-specializers"); var_method_procedure = scm_c_lookup ("method-procedure"); - var_change_class = - scm_module_variable (scm_module_goops, sym_change_class); - setup_extended_primitive_generics (); + var_change_class = scm_c_lookup ("change-class"); #if (SCM_ENABLE_DEPRECATED == 1) scm_init_deprecated_goops (); @@ -1427,8 +1029,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, } #undef FUNC_NAME -SCM scm_module_goops; - static void scm_init_goops_builtins (void *unused) { @@ -1438,6 +1038,19 @@ scm_init_goops_builtins (void *unused) hell_mutex = scm_make_mutex (); #include "libguile/goops.x" + + scm_c_define ("vtable-flag-vtable", + scm_from_int (SCM_VTABLE_FLAG_VTABLE)); + scm_c_define ("vtable-flag-applicable-vtable", + scm_from_int (SCM_VTABLE_FLAG_APPLICABLE_VTABLE)); + scm_c_define ("vtable-flag-setter-vtable", + scm_from_int (SCM_VTABLE_FLAG_SETTER_VTABLE)); + scm_c_define ("vtable-flag-validated", + scm_from_int (SCM_VTABLE_FLAG_VALIDATED)); + scm_c_define ("vtable-flag-goops-class", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS)); + scm_c_define ("vtable-flag-goops-valid", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID)); } void