summaryrefslogtreecommitdiff
path: root/libguile/goops.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/goops.c')
-rw-r--r--libguile/goops.c1019
1 files changed, 1019 insertions, 0 deletions
diff --git a/libguile/goops.c b/libguile/goops.c
new file mode 100644
index 000000000..fd312a8f1
--- /dev/null
+++ b/libguile/goops.c
@@ -0,0 +1,1019 @@
+/* Copyright 1998-2004,2008-2015,2017-2018
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile is free software: you can redistribute it and/or modify it
+ under the terms of the GNU Lesser General Public License as published
+ by the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ Guile is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
+
+
+/* This software is a derivative work of other copyrighted softwares; the
+ * copyright notices of these softwares are placed in the file COPYRIGHTS
+ *
+ * This file is based upon stklos.c from the STk distribution by
+ * Erick Gallesio <eg@unice.fr>.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "async.h"
+#include "boolean.h"
+#include "chars.h"
+#include "dynwind.h"
+#include "eval.h"
+#include "extensions.h"
+#include "foreign.h"
+#include "gsubr.h"
+#include "hashtab.h"
+#include "keywords.h"
+#include "macros.h"
+#include "modules.h"
+#include "numbers.h"
+#include "pairs.h"
+#include "ports-internal.h"
+#include "ports.h"
+#include "procprop.h"
+#include "programs.h"
+#include "smob.h"
+#include "strings.h"
+#include "strports.h"
+#include "symbols.h"
+#include "variable.h"
+#include "vectors.h"
+#include "version.h"
+#include "weak-table.h"
+
+#include "goops.h"
+
+
+/* Objects have identity, so references to classes and instances are by
+ value, not by reference. Redefinition of a class or modification of
+ an instance causes in-place update; you can think of GOOPS as
+ building in its own indirection, and for that reason referring to
+ GOOPS values by variable reference is unnecessary.
+
+ 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_class_of_obsolete_indirect_instance = 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;
+static SCM var_class_direct_subclasses = SCM_BOOL_F;
+static SCM var_class_direct_methods = SCM_BOOL_F;
+static SCM var_class_precedence_list = SCM_BOOL_F;
+static SCM var_class_slots = SCM_BOOL_F;
+
+static SCM var_generic_function_methods = SCM_BOOL_F;
+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 = 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;
+
+/* 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;
+static SCM class_primitive_generic;
+static SCM class_vector, class_null;
+static SCM class_integer, class_real, class_complex, class_fraction;
+static SCM class_unknown;
+static SCM class_top, class_class;
+static SCM class_applicable;
+static SCM class_applicable_struct, class_applicable_struct_with_setter;
+static SCM class_generic, class_generic_with_setter;
+static SCM class_accessor;
+static SCM class_extended_generic, class_extended_generic_with_setter;
+static SCM class_extended_accessor;
+static SCM class_method;
+static SCM class_accessor_method;
+static SCM class_procedure_class;
+static SCM class_applicable_struct_class;
+static SCM class_applicable_struct_with_setter_class;
+static SCM class_number, class_list;
+static SCM class_keyword;
+static SCM class_syntax;
+static SCM class_atomic_box;
+static SCM class_port, class_input_output_port;
+static SCM class_input_port, class_output_port;
+
+static SCM class_foreign;
+static SCM class_hashtable;
+static SCM class_fluid;
+static SCM class_dynamic_state;
+static SCM class_frame;
+static SCM class_vm_cont;
+static SCM class_bytevector;
+static SCM class_uvec;
+static SCM class_array;
+static SCM class_bitvector;
+
+static SCM vtable_class_map = SCM_BOOL_F;
+
+/* SMOB classes. */
+SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
+
+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_VTABLE_FLAG_GOOPS_CLASS);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+
+static SCM
+get_indirect_slots (SCM x)
+{
+ /* Precondition: X is an indirect instance. The indirect slots are in
+ the last field. */
+ scm_t_bits nfields =
+ SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (x), scm_vtable_index_size);
+
+ return SCM_STRUCT_SLOT_REF (x, nfields - 1);
+}
+
+/* This function is used for efficient type dispatch. */
+SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
+ (SCM x),
+ "Return the class of @var{x}.")
+#define FUNC_NAME s_scm_class_of
+{
+ switch (SCM_ITAG3 (x))
+ {
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ return class_integer;
+
+ case scm_tc3_imm24:
+ if (SCM_CHARP (x))
+ return class_char;
+ else if (scm_is_bool (x))
+ return class_boolean;
+ else if (scm_is_null (x))
+ return class_null;
+ else
+ return class_unknown;
+
+ case scm_tc3_cons:
+ switch (SCM_TYP7 (x))
+ {
+ case scm_tcs_cons_nimcar:
+ return class_pair;
+ case scm_tc7_symbol:
+ return class_symbol;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ return class_vector;
+ case scm_tc7_pointer:
+ return class_foreign;
+ case scm_tc7_hashtable:
+ return class_hashtable;
+ case scm_tc7_fluid:
+ return class_fluid;
+ case scm_tc7_dynamic_state:
+ return class_dynamic_state;
+ case scm_tc7_frame:
+ return class_frame;
+ case scm_tc7_keyword:
+ return class_keyword;
+ case scm_tc7_syntax:
+ return class_syntax;
+ case scm_tc7_atomic_box:
+ return class_atomic_box;
+ case scm_tc7_vm_cont:
+ return class_vm_cont;
+ case scm_tc7_bytevector:
+ if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
+ return class_bytevector;
+ else
+ return class_uvec;
+ case scm_tc7_array:
+ return class_array;
+ case scm_tc7_bitvector:
+ return class_bitvector;
+ case scm_tc7_string:
+ return class_string;
+ case scm_tc7_number:
+ switch SCM_TYP16 (x) {
+ case scm_tc16_big:
+ return class_integer;
+ case scm_tc16_real:
+ return class_real;
+ case scm_tc16_complex:
+ return class_complex;
+ case scm_tc16_fraction:
+ return class_fraction;
+ }
+ case scm_tc7_program:
+ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
+ && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
+ return class_primitive_generic;
+ else
+ return class_procedure;
+
+ case scm_tc7_smob:
+ {
+ scm_t_bits type = SCM_TYP16 (x);
+ if (type != scm_tc16_port_with_ps)
+ return scm_i_smob_class[SCM_TC2SMOBNUM (type)];
+ x = SCM_PORT_WITH_PS_PORT (x);
+ /* fall through to ports */
+ }
+ case scm_tc7_port:
+ {
+ scm_t_port_type *ptob = SCM_PORT_TYPE (x);
+ if (SCM_INPUT_PORT_P (x))
+ {
+ if (SCM_OUTPUT_PORT_P (x))
+ return ptob->input_output_class;
+ return ptob->input_class;
+ }
+ return ptob->output_class;
+ }
+ case scm_tcs_struct:
+ {
+ SCM vtable = SCM_STRUCT_VTABLE (x);
+ scm_t_bits flags = SCM_VTABLE_FLAGS (vtable);
+ scm_t_bits direct = SCM_VTABLE_FLAG_GOOPS_CLASS;
+ scm_t_bits indirect = direct | SCM_VTABLE_FLAG_GOOPS_INDIRECT;
+ scm_t_bits mask = indirect;
+ if ((flags & mask) == direct)
+ /* A direct GOOPS object. */
+ return vtable;
+ else if ((flags & mask) == indirect)
+ /* An indirect GOOPS object. If the vtable of the slots
+ object is flagged to indicate that there's a new class
+ definition available, migrate the instance before
+ returning the class. */
+ {
+ SCM slots = get_indirect_slots (x);
+ scm_t_bits slot_flags = SCM_OBJ_CLASS_FLAGS (slots);
+ if (slot_flags & SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION)
+ return scm_call_1
+ (scm_variable_ref (var_class_of_obsolete_indirect_instance),
+ x);
+ else
+ return vtable;
+ }
+ else
+ /* A non-GOOPS struct. */
+ return scm_i_define_class_for_vtable (vtable);
+ }
+ default:
+ if (scm_is_pair (x))
+ return class_pair;
+ else
+ return class_unknown;
+ }
+
+ case scm_tc3_struct:
+ case scm_tc3_tc7_1:
+ case scm_tc3_tc7_2:
+ /* case scm_tc3_unused: */
+ /* Never reached */
+ break;
+ }
+ return class_unknown;
+}
+#undef FUNC_NAME
+
+
+
+
+SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an instance.")
+#define FUNC_NAME s_scm_instance_p
+{
+ return scm_from_bool (SCM_INSTANCEP (obj));
+}
+#undef FUNC_NAME
+
+int
+scm_is_generic (SCM x)
+{
+ return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_generic);
+}
+
+int
+scm_is_method (SCM x)
+{
+ return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_method);
+}
+
+
+
+
+SCM
+scm_class_name (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_class_name), obj);
+}
+
+SCM
+scm_class_direct_supers (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
+}
+
+SCM
+scm_class_direct_slots (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
+}
+
+SCM
+scm_class_direct_subclasses (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
+}
+
+SCM
+scm_class_direct_methods (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
+}
+
+SCM
+scm_class_precedence_list (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
+}
+
+SCM
+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}.")
+#define FUNC_NAME s_scm_generic_function_name
+{
+ SCM_VALIDATE_GENERIC (1, obj);
+ return scm_procedure_property (obj, scm_sym_name);
+}
+#undef FUNC_NAME
+
+SCM
+scm_generic_function_methods (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_generic_function_methods), obj);
+}
+
+SCM
+scm_method_generic_function (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_method_generic_function), obj);
+}
+
+SCM
+scm_method_specializers (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_method_specializers), obj);
+}
+
+SCM
+scm_method_procedure (SCM obj)
+{
+ return scm_call_1 (scm_variable_ref (var_method_procedure), obj);
+}
+
+
+
+
+SCM
+scm_slot_ref (SCM obj, SCM slot_name)
+{
+ return scm_call_2 (scm_variable_ref (var_slot_ref), obj, slot_name);
+}
+
+SCM
+scm_slot_set_x (SCM obj, SCM slot_name, SCM value)
+{
+ return scm_call_3 (scm_variable_ref (var_slot_set_x), obj, slot_name, value);
+}
+
+SCM
+scm_slot_bound_p (SCM obj, SCM slot_name)
+{
+ return scm_call_2 (scm_variable_ref (var_slot_bound_p), obj, slot_name);
+}
+
+SCM
+scm_slot_exists_p (SCM obj, SCM slot_name)
+{
+ return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
+}
+
+
+
+
+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_t_signed_bits n, i;
+
+ SCM_VALIDATE_STRUCT (1, obj);
+ n = SCM_STRUCT_SIZE (obj);
+
+ /* Set all SCM-holding slots to the GOOPS unbound value. */
+ for (i = 0; i < n; i++)
+ if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, i))
+ SCM_STRUCT_SLOT_SET (obj, i, unbound);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+
+static scm_i_pthread_mutex_t goops_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+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_t_bits i, old_nfields, new_nfields;
+
+ SCM_VALIDATE_INSTANCE (1, old);
+ SCM_VALIDATE_INSTANCE (2, new);
+
+ old_nfields = SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (old),
+ scm_vtable_index_size);
+ new_nfields = SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (new),
+ scm_vtable_index_size);
+ SCM_ASSERT (old_nfields == new_nfields, new, SCM_ARG2, FUNC_NAME);
+
+ /* Exchange the data contained in old and new. We exchange rather than
+ scratch the old value with new to be correct with GC. See "Class
+ redefinition protocol" in goops.scm. */
+ scm_i_pthread_mutex_lock (&goops_lock);
+ /* Swap vtables. */
+ {
+ scm_t_bits tmp = SCM_CELL_WORD_0 (old);
+ SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
+ SCM_SET_CELL_WORD_0 (new, tmp);
+ }
+ /* Swap data. */
+ for (i = 0; i < old_nfields; i++)
+ {
+ scm_t_bits tmp = SCM_STRUCT_DATA_REF (old, i);
+ SCM_STRUCT_DATA_SET (old, i, SCM_STRUCT_DATA_REF (new, i));
+ SCM_STRUCT_DATA_SET (new, i, tmp);
+ }
+ scm_i_pthread_mutex_unlock (&goops_lock);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* 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),
+ "")
+#define FUNC_NAME s_scm_generic_capability_p
+{
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
+ return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
+ (SCM subrs),
+ "")
+#define FUNC_NAME s_scm_enable_primitive_generic_x
+{
+ SCM_VALIDATE_REST_ARGUMENT (subrs);
+ while (!scm_is_null (subrs))
+ {
+ SCM subr = SCM_CAR (subrs);
+ SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
+ SCM_SET_SUBR_GENERIC (subr,
+ scm_make (scm_list_3 (class_generic,
+ k_name,
+ SCM_SUBR_NAME (subr))));
+ subrs = SCM_CDR (subrs);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
+ (SCM subr, SCM generic),
+ "")
+#define FUNC_NAME s_scm_set_primitive_generic_x
+{
+ SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
+ SCM_SET_SUBR_GENERIC (subr, generic);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
+ (SCM subr),
+ "")
+#define FUNC_NAME s_scm_primitive_generic_generic
+{
+ if (SCM_PRIMITIVE_GENERIC_P (subr))
+ {
+ if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
+ scm_enable_primitive_generic_x (scm_list_1 (subr));
+ return *SCM_SUBR_GENERIC (subr);
+ }
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
+}
+#undef FUNC_NAME
+
+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);
+}
+
+
+
+
+SCM
+scm_make (SCM args)
+{
+ return scm_apply_0 (scm_variable_ref (var_make), args);
+}
+
+
+
+
+/* SMOB, struct, and port classes. */
+
+static SCM
+make_class_name (const char *prefix, const char *type_name, const char *suffix)
+{
+ if (!type_name)
+ type_name = "";
+ return scm_string_to_symbol (scm_string_append
+ (scm_list_3 (scm_from_utf8_string (prefix),
+ scm_from_utf8_string (type_name),
+ scm_from_utf8_string (suffix))));
+}
+
+SCM
+scm_make_extended_class (char const *type_name, int applicablep)
+{
+ SCM name, meta, supers;
+
+ name = make_class_name ("<", type_name, ">");
+ meta = class_class;
+
+ if (applicablep)
+ supers = scm_list_1 (class_applicable);
+ else
+ supers = scm_list_1 (class_top);
+
+ return scm_make_standard_class (meta, name, supers, SCM_EOL);
+}
+
+void
+scm_i_inherit_applicable (SCM c)
+{
+ scm_call_1 (scm_variable_ref (var_inherit_applicable), c);
+}
+
+static void
+create_smob_classes (void)
+{
+ long i;
+
+ for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
+ scm_i_smob_class[i] = SCM_BOOL_F;
+
+ for (i = 0; i < scm_numsmob; ++i)
+ if (scm_is_false (scm_i_smob_class[i]))
+ scm_i_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
+ scm_smobs[i].apply != 0);
+}
+
+struct pre_goops_port_type
+{
+ scm_t_port_type *ptob;
+ struct pre_goops_port_type *prev;
+};
+struct pre_goops_port_type *pre_goops_port_types;
+
+static void
+make_port_classes (scm_t_port_type *ptob)
+{
+ SCM name, meta, super, supers;
+
+ meta = class_class;
+
+ name = make_class_name ("<", ptob->name, "-port>");
+ supers = scm_list_1 (class_port);
+ super = scm_make_standard_class (meta, name, supers, SCM_EOL);
+
+ name = make_class_name ("<", ptob->name, "-input-port>");
+ supers = scm_list_2 (super, class_input_port);
+ ptob->input_class = scm_make_standard_class (meta, name, supers, SCM_EOL);
+
+ name = make_class_name ("<", ptob->name, "-output-port>");
+ supers = scm_list_2 (super, class_output_port);
+ ptob->output_class = scm_make_standard_class (meta, name, supers, SCM_EOL);
+
+ name = make_class_name ("<", ptob->name, "-input-output-port>");
+ supers = scm_list_2 (super, class_input_output_port);
+ ptob->input_output_class =
+ scm_make_standard_class (meta, name, supers, SCM_EOL);
+}
+
+void
+scm_make_port_classes (scm_t_port_type *ptob)
+{
+ ptob->input_class = SCM_BOOL_F;
+ ptob->output_class = SCM_BOOL_F;
+ ptob->input_output_class = SCM_BOOL_F;
+
+ if (!goops_loaded_p)
+ {
+ /* Not really a pair. */
+ struct pre_goops_port_type *link;
+ link = scm_gc_typed_calloc (struct pre_goops_port_type);
+ link->ptob = ptob;
+ link->prev = pre_goops_port_types;
+ pre_goops_port_types = link;
+ return;
+ }
+
+ make_port_classes (ptob);
+}
+
+static void
+create_port_classes (void)
+{
+ while (pre_goops_port_types)
+ {
+ make_port_classes (pre_goops_port_types->ptob);
+ pre_goops_port_types = pre_goops_port_types->prev;
+ }
+}
+
+SCM
+scm_i_define_class_for_vtable (SCM vtable)
+{
+ SCM class;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ if (scm_is_false (vtable_class_map))
+ 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_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
+
+ if (scm_is_false (class))
+ {
+ if (SCM_UNPACK (class_class))
+ {
+ SCM name, meta, supers;
+
+ name = SCM_VTABLE_NAME (vtable);
+ if (scm_is_symbol (name))
+ name = scm_string_to_symbol
+ (scm_string_append
+ (scm_list_3 (scm_from_latin1_string ("<"),
+ scm_symbol_to_string (name),
+ scm_from_latin1_string (">"))));
+ else
+ name = scm_from_latin1_symbol ("<>");
+
+ if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER))
+ {
+ meta = class_applicable_struct_with_setter_class;
+ supers = scm_list_1 (class_applicable_struct_with_setter);
+ }
+ else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable,
+ SCM_VTABLE_FLAG_APPLICABLE))
+ {
+ meta = class_applicable_struct_class;
+ supers = scm_list_1 (class_applicable_struct);
+ }
+ else
+ {
+ meta = class_class;
+ supers = scm_list_1 (class_top);
+ }
+
+ class = scm_make_standard_class (meta, name, supers, SCM_EOL);
+ }
+ else
+ /* `create_struct_classes' will fill this in later. */
+ class = SCM_BOOL_F;
+
+ /* Don't worry about races. This only happens when creating a
+ vtable, which happens by definition in one thread. */
+ scm_weak_table_putq_x (vtable_class_map, vtable, class);
+ }
+
+ return class;
+}
+
+static SCM
+make_struct_class (void *closure SCM_UNUSED,
+ SCM vtable, SCM data, SCM prev SCM_UNUSED)
+{
+ if (scm_is_false (data))
+ scm_i_define_class_for_vtable (vtable);
+ return SCM_UNSPECIFIED;
+}
+
+static void
+create_struct_classes (void)
+{
+ /* FIXME: take the vtable_class_map while initializing goops? */
+ scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F,
+ vtable_class_map);
+}
+
+
+
+
+void
+scm_load_goops ()
+{
+ if (!goops_loaded_p)
+ scm_c_resolve_module ("oop goops");
+}
+
+SCM
+scm_ensure_accessor (SCM name)
+{
+ SCM var, gf;
+
+ var = scm_module_variable (scm_current_module (), name);
+ if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
+ gf = SCM_VARIABLE_REF (var);
+ else
+ gf = SCM_BOOL_F;
+
+ if (!SCM_IS_A_P (gf, class_accessor))
+ {
+ gf = scm_make (scm_list_3 (class_generic, k_name, name));
+ gf = scm_make (scm_list_5 (class_accessor,
+ k_name, name, k_setter, gf));
+ }
+
+ return gf;
+}
+
+
+
+
+SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_sys_goops_early_init
+{
+ var_make_standard_class = scm_c_lookup ("make-standard-class");
+ var_make = scm_c_lookup ("make");
+ var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
+
+ /* 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!");
+ var_slot_bound_p = scm_c_lookup ("slot-bound?");
+ var_slot_exists_p = scm_c_lookup ("slot-exists?");
+
+ class_class = scm_variable_ref (scm_c_lookup ("<class>"));
+ class_top = scm_variable_ref (scm_c_lookup ("<top>"));
+
+ /* Applicables */
+ class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
+ class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
+ class_applicable_struct_with_setter_class =
+ scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>"));
+
+ class_method = scm_variable_ref (scm_c_lookup ("<method>"));
+ class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
+ class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
+ class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
+ class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
+ class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
+ class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
+ class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
+ class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
+ class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
+ class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
+
+ /* Primitive types classes */
+ class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
+ class_char = scm_variable_ref (scm_c_lookup ("<char>"));
+ class_list = scm_variable_ref (scm_c_lookup ("<list>"));
+ class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
+ class_null = scm_variable_ref (scm_c_lookup ("<null>"));
+ class_string = scm_variable_ref (scm_c_lookup ("<string>"));
+ class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
+ class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
+ class_foreign = scm_variable_ref (scm_c_lookup ("<foreign>"));
+ class_hashtable = scm_variable_ref (scm_c_lookup ("<hashtable>"));
+ class_fluid = scm_variable_ref (scm_c_lookup ("<fluid>"));
+ class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
+ class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
+ class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
+ class_syntax = scm_variable_ref (scm_c_lookup ("<syntax>"));
+ class_atomic_box = scm_variable_ref (scm_c_lookup ("<atomic-box>"));
+ class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
+ class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
+ class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
+ class_array = scm_variable_ref (scm_c_lookup ("<array>"));
+ class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
+ class_number = scm_variable_ref (scm_c_lookup ("<number>"));
+ class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
+ class_real = scm_variable_ref (scm_c_lookup ("<real>"));
+ class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
+ class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
+ class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
+ class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
+ class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
+ class_port = scm_variable_ref (scm_c_lookup ("<port>"));
+ class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
+ class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
+ class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
+
+ create_smob_classes ();
+ create_struct_classes ();
+ create_port_classes ();
+
+ 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"
+ "on the C level which depends on the loaded GOOPS modules.")
+#define FUNC_NAME s_scm_sys_goops_loaded
+{
+ goops_loaded_p = 1;
+ var_class_name = scm_c_lookup ("class-name");
+ var_class_direct_supers = scm_c_lookup ("class-direct-supers");
+ 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_slots = scm_c_lookup ("class-slots");
+
+ var_generic_function_methods = scm_c_lookup ("generic-function-methods");
+ var_method_generic_function = scm_c_lookup ("method-generic-function");
+ var_method_specializers = scm_c_lookup ("method-specializers");
+ var_method_procedure = scm_c_lookup ("method-procedure");
+
+ var_class_of_obsolete_indirect_instance =
+ scm_c_lookup ("class-of-obsolete-indirect-instance");
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+scm_init_goops_builtins (void *unused)
+{
+ scm_module_goops = scm_current_module ();
+
+#include "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-slot",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
+ scm_c_define ("vtable-flag-goops-static-slot-allocation",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION));
+ scm_c_define ("vtable-flag-goops-indirect",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_INDIRECT));
+ scm_c_define ("vtable-flag-goops-needs-migration",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION));
+}
+
+void
+scm_init_goops ()
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_goops_builtins", scm_init_goops_builtins,
+ NULL);
+}