summaryrefslogtreecommitdiff
path: root/libguile/goops.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/goops.c')
-rw-r--r--libguile/goops.c139
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;