diff options
Diffstat (limited to 'libguile/goops.c')
-rw-r--r-- | libguile/goops.c | 139 |
1 files changed, 62 insertions, 77 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 2f9cf30b9..5e846eeae 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -53,7 +53,6 @@ #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/vectors.h" -#include "libguile/weaks.h" #include "libguile/vm.h" #include "libguile/validate.h" @@ -85,13 +84,6 @@ SCM_SYMBOL (sym_change_class, "change-class"); SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); -/* FIXME, exports should come from the scm file only */ -#define DEFVAR(v, val) \ - { scm_module_define (scm_module_goops, (v), (val)); \ - scm_module_export (scm_module_goops, scm_list_1 ((v))); \ - } - - /* Class redefinition protocol: A class is represented by a heap header h1 which points to a @@ -172,7 +164,6 @@ static SCM class_array; static SCM class_bitvector; static SCM vtable_class_map = SCM_BOOL_F; -static scm_i_pthread_mutex_t vtable_class_map_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; /* Port classes. Allocate 3 times the maximum number of port types so that input ports, output ports, and in/out ports can be stored at different @@ -200,17 +191,15 @@ scm_i_define_class_for_vtable (SCM vtable) { SCM class; - scm_i_pthread_mutex_lock (&vtable_class_map_lock); - + scm_i_pthread_mutex_lock (&scm_i_misc_mutex); if (scm_is_false (vtable_class_map)) - vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED); + vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); if (scm_is_false (scm_struct_vtable_p (vtable))) abort (); - class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F); - - scm_i_pthread_mutex_unlock (&vtable_class_map_lock); + class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F); if (scm_is_false (class)) { @@ -229,9 +218,7 @@ scm_i_define_class_for_vtable (SCM vtable) /* Don't worry about races. This only happens when creating a vtable, which happens by definition in one thread. */ - scm_i_pthread_mutex_lock (&vtable_class_map_lock); - scm_hashq_set_x (vtable_class_map, vtable, class); - scm_i_pthread_mutex_unlock (&vtable_class_map_lock); + scm_weak_table_putq_x (vtable_class_map, vtable, class); } return class; @@ -934,7 +921,6 @@ SCM_SYMBOL (sym_cpl, "cpl"); SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class"); SCM_SYMBOL (sym_slots, "slots"); SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters"); -SCM_SYMBOL (sym_keyword_access, "keyword-access"); SCM_SYMBOL (sym_nfields, "nfields"); @@ -969,7 +955,6 @@ build_class_class_slots (void) scm_list_1 (sym_default_slot_definition_class), scm_list_1 (sym_slots), scm_list_1 (sym_getters_n_setters), - scm_list_1 (sym_keyword_access), scm_list_1 (sym_nfields), SCM_UNDEFINED); } @@ -982,7 +967,7 @@ create_basic_classes (void) /**** <class> ****/ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT); SCM name = scm_from_latin1_symbol ("<class>"); - scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL); + scm_class_class = scm_i_make_vtable_vtable (cs); SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_METACLASS)); @@ -1000,21 +985,21 @@ create_basic_classes (void) prep_hashsets (scm_class_class); - DEFVAR(name, scm_class_class); + scm_module_define (scm_module_goops, name, scm_class_class); /**** <top> ****/ name = scm_from_latin1_symbol ("<top>"); scm_class_top = scm_basic_make_class (scm_class_class, name, SCM_EOL, SCM_EOL); - DEFVAR(name, scm_class_top); + scm_module_define (scm_module_goops, name, scm_class_top); /**** <object> ****/ name = scm_from_latin1_symbol ("<object>"); scm_class_object = scm_basic_make_class (scm_class_class, name, scm_list_1 (scm_class_top), SCM_EOL); - DEFVAR (name, scm_class_object); + scm_module_define (scm_module_goops, name, scm_class_object); /* <top> <object> and <class> were partially initialized. Correct them here */ SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class)); @@ -1733,36 +1718,6 @@ SCM_KEYWORD (k_name, "name"); SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); -SCM -scm_apply_generic (SCM gf, SCM args) -{ - return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL); -} - -SCM -scm_call_generic_0 (SCM gf) -{ - return scm_call_0 (SCM_STRUCT_PROCEDURE (gf)); -} - -SCM -scm_call_generic_1 (SCM gf, SCM a1) -{ - return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1); -} - -SCM -scm_call_generic_2 (SCM gf, SCM a1, SCM a2) -{ - return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2); -} - -SCM -scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) -{ - return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3); -} - SCM_SYMBOL (sym_delayed_compile, "delayed-compile"); static SCM make_dispatch_procedure (SCM gf) @@ -1906,6 +1861,47 @@ setup_extended_primitive_generics () } } +/* 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) +{ + if (!SCM_UNPACK (gf)) + scm_error_num_args_subr (subr); + + return scm_call_0 (gf); +} + +SCM +scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_wrong_type_arg (subr, pos, a1); + + return scm_call_1 (gf, a1); +} + +SCM +scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2); + + return scm_call_2 (gf, a1, a2); +} + +SCM +scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos))); + + return scm_apply_0 (gf, args); +} + /****************************************************************************** * * Protocol for calling a generic fumction @@ -2367,12 +2363,12 @@ fix_cpl (SCM c, SCM before, SCM after) static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { - SCM tmp = scm_from_locale_symbol (name); + SCM tmp = scm_from_utf8_symbol (name); *var = scm_basic_make_class (meta, tmp, scm_is_pair (super) ? super : scm_list_1 (super), slots); - DEFVAR(tmp, *var); + scm_module_define (scm_module_goops, tmp, *var); } @@ -2572,30 +2568,25 @@ create_standard_classes (void) static SCM make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep) { - SCM class, name; + SCM name; if (type_name) { char buffer[100]; sprintf (buffer, template, type_name); - name = scm_from_locale_symbol (buffer); + name = scm_from_utf8_symbol (buffer); } else name = SCM_GOOPS_UNBOUND; - class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, - name, supers, SCM_EOL); - - /* Only define name if doesn't already exist. */ - if (!SCM_GOOPS_UNBOUNDP (name) - && scm_is_false (scm_module_variable (scm_module_goops, name))) - DEFVAR (name, class); - return class; + return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, + name, supers, SCM_EOL); } static SCM make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) { - SCM class, name; + SCM name; + if (scm_is_true (type_name_sym)) { name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"), @@ -2606,14 +2597,8 @@ make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) else name = SCM_GOOPS_UNBOUND; - class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, - name, supers, SCM_EOL); - - /* Only define name if doesn't already exist. */ - if (!SCM_GOOPS_UNBOUNDP (name) - && scm_is_false (scm_module_variable (scm_module_goops, name))) - DEFVAR (name, class); - return class; + return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, + name, supers, SCM_EOL); } SCM @@ -2721,7 +2706,7 @@ create_port_classes (void) { long i; - for (i = 0; i < scm_numptob; ++i) + for (i = scm_c_num_port_types () - 1; i >= 0; i--) scm_make_port_classes (i, SCM_PTOBNAME (i)); } @@ -2843,7 +2828,7 @@ scm_init_goops_builtins (void) SCM name = scm_from_latin1_symbol ("no-applicable-method"); scm_no_applicable_method = scm_make (scm_list_3 (scm_class_generic, k_name, name)); - DEFVAR (name, scm_no_applicable_method); + scm_module_define (scm_module_goops, name, scm_no_applicable_method); } return SCM_UNSPECIFIED; |