diff options
Diffstat (limited to 'libguile/goops.c')
-rw-r--r-- | libguile/goops.c | 309 |
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: -*/ |