summaryrefslogtreecommitdiff
path: root/libguile/goops.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/goops.c')
-rw-r--r--libguile/goops.c309
1 files changed, 122 insertions, 187 deletions
diff --git a/libguile/goops.c b/libguile/goops.c
index 77316cfce..fd312a8f1 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,21 +1,21 @@
-/* Copyright (C) 1998-2004,2008-2015,2017
- * Free Software Foundation, Inc.
- *
- * This library 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.
- *
- * This library 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 this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
+/* 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
@@ -29,27 +29,35 @@
# include <config.h>
#endif
-#include "libguile/_scm.h"
-#include "libguile/async.h"
-#include "libguile/chars.h"
-#include "libguile/dynwind.h"
-#include "libguile/eval.h"
-#include "libguile/gsubr.h"
-#include "libguile/hashtab.h"
-#include "libguile/keywords.h"
-#include "libguile/macros.h"
-#include "libguile/modules.h"
-#include "libguile/ports.h"
-#include "libguile/ports-internal.h"
-#include "libguile/procprop.h"
-#include "libguile/programs.h"
-#include "libguile/smob.h"
-#include "libguile/strings.h"
-#include "libguile/strports.h"
-#include "libguile/vectors.h"
-
-#include "libguile/validate.h"
-#include "libguile/goops.h"
+#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
@@ -68,7 +76,7 @@ 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_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;
@@ -168,8 +176,8 @@ SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
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);
+ scm_i_struct_inherit_vtable_magic (scm_class_of (class), class);
+ SCM_SET_CLASS_FLAGS (class, SCM_VTABLE_FLAG_GOOPS_CLASS);
return SCM_UNSPECIFIED;
}
@@ -178,6 +186,17 @@ SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
+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),
@@ -277,21 +296,34 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return ptob->output_class;
}
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. */
- {
- 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
- return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
+ {
+ 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;
@@ -325,13 +357,13 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
int
scm_is_generic (SCM x)
{
- return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic);
+ 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);
+ return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_method);
}
@@ -452,17 +484,13 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0,
#define FUNC_NAME s_scm_sys_clear_fields_x
{
scm_t_signed_bits n, i;
- SCM vtable, layout;
SCM_VALIDATE_STRUCT (1, obj);
- vtable = SCM_STRUCT_VTABLE (obj);
-
- n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
- layout = SCM_VTABLE_LAYOUT (vtable);
+ n = SCM_STRUCT_SIZE (obj);
/* Set all SCM-holding slots to the GOOPS unbound value. */
for (i = 0; i < n; i++)
- if (scm_i_symbol_ref (layout, i*2) == 'p')
+ if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, i))
SCM_STRUCT_SLOT_SET (obj, i, unbound);
return SCM_UNSPECIFIED;
@@ -479,122 +507,39 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
"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);
- /* 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 above".
- */
- scm_i_pthread_mutex_lock (&goops_lock);
- {
- scm_t_bits word0, word1;
- word0 = SCM_CELL_WORD_0 (old);
- word1 = SCM_CELL_WORD_1 (old);
- SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
- SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
- SCM_SET_CELL_WORD_0 (new, word0);
- SCM_SET_CELL_WORD_1 (new, word1);
- }
- scm_i_pthread_mutex_unlock (&goops_lock);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
- (SCM old, SCM new),
- "")
-#define FUNC_NAME s_scm_sys_modify_class
-{
- SCM_VALIDATE_CLASS (1, old);
- SCM_VALIDATE_CLASS (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 word0, word1;
- word0 = SCM_CELL_WORD_0 (old);
- word1 = SCM_CELL_WORD_1 (old);
+ scm_t_bits tmp = SCM_CELL_WORD_0 (old);
SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
- SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
- SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
- SCM_SET_CELL_WORD_0 (new, word0);
- SCM_SET_CELL_WORD_1 (new, word1);
- SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (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
-/* 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
- * infinite recursions.
- */
-
-static scm_t_bits **hell;
-static long n_hell = 1; /* one place for the evil one himself */
-static long hell_size = 4;
-static SCM hell_mutex;
-
-static long
-burnin (SCM o)
-{
- long i;
- for (i = 1; i < n_hell; ++i)
- if (SCM_STRUCT_DATA (o) == hell[i])
- return i;
- return 0;
-}
-
-static void
-go_to_hell (void *o)
-{
- SCM obj = *(SCM*)o;
- scm_lock_mutex (hell_mutex);
- if (n_hell >= hell_size)
- {
- hell_size *= 2;
- hell = scm_realloc (hell, hell_size * sizeof(*hell));
- }
- hell[n_hell++] = SCM_STRUCT_DATA (obj);
- scm_unlock_mutex (hell_mutex);
-}
-
-static void
-go_to_heaven (void *o)
-{
- SCM obj = *(SCM*)o;
- scm_lock_mutex (hell_mutex);
- hell[burnin (obj)] = hell[--n_hell];
- scm_unlock_mutex (hell_mutex);
-}
-
-
-static SCM
-purgatory (SCM obj, SCM new_class)
-{
- return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
-}
-
-/* This function calls the generic function change-class for all
- * instances which aren't currently undergoing class change.
- */
-
-void
-scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
-{
- if (!burnin (obj))
- {
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
- purgatory (obj, new_class);
- scm_dynwind_end ();
- }
-}
-
-
/* Primitive generics: primitives that can dispatch to generics if their
@@ -1031,11 +976,8 @@ 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_c_lookup ("change-class");
-
-#if (SCM_ENABLE_DEPRECATED == 1)
- scm_init_deprecated_goops ();
-#endif
+ var_class_of_obsolete_indirect_instance =
+ scm_c_lookup ("class-of-obsolete-indirect-instance");
return SCM_UNSPECIFIED;
}
@@ -1046,10 +988,7 @@ scm_init_goops_builtins (void *unused)
{
scm_module_goops = scm_current_module ();
- hell = scm_calloc (hell_size * sizeof (*hell));
- hell_mutex = scm_make_mutex ();
-
-#include "libguile/goops.x"
+#include "goops.x"
scm_c_define ("vtable-flag-vtable",
scm_from_int (SCM_VTABLE_FLAG_VTABLE));
@@ -1061,12 +1000,14 @@ scm_init_goops_builtins (void *unused)
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));
scm_c_define ("vtable-flag-goops-slot",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
- scm_c_define ("vtable-flag-goops-static",
- scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC));
+ 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
@@ -1076,9 +1017,3 @@ scm_init_goops ()
"scm_init_goops_builtins", scm_init_goops_builtins,
NULL);
}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/