-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
* 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 2.1 of the License, or (at your option) any later version.
+ * 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
+ * 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
\f
#include "libguile/keywords.h"
#include "libguile/macros.h"
#include "libguile/modules.h"
-#include "libguile/objects.h"
#include "libguile/ports.h"
#include "libguile/procprop.h"
+#include "libguile/programs.h"
#include "libguile/random.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/goops.h"
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
+#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
+#define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
+#define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
+#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
+
+/* Port classes */
+#define SCM_IN_PCLASS_INDEX 0
+#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
+#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
+
/* this file is a mess. in theory, though, we shouldn't have many SCM references
-- most of the references should be to vars. */
h1.
*/
-/* The following definition is located in libguile/objects.h:
-#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
-*/
-
#define TEST_CHANGE_CLASS(obj, class) \
{ \
class = SCM_CLASS_OF (obj); \
SCM scm_class_method;
SCM scm_class_simple_method, scm_class_accessor_method;
SCM scm_class_procedure_class;
-SCM scm_class_operator_class, scm_class_operator_with_setter_class;
SCM scm_class_entity_class;
SCM scm_class_number, scm_class_list;
SCM scm_class_keyword;
static SCM scm_assert_bound (SCM value, SCM obj);
static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
static SCM scm_sys_goops_loaded (void);
+static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
+ int applicablep);
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_class_primitive_generic;
else
return scm_class_procedure;
- case scm_tc7_cclo:
+ case scm_tc7_gsubr:
+ case scm_tc7_program:
return scm_class_procedure;
case scm_tc7_pws:
return scm_class_procedure_with_setter;
return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
else
{
- SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- SCM class = scm_make_extended_class (scm_is_true (name)
- ? scm_i_symbol_chars (name)
- : 0,
- SCM_I_OPERATORP (x));
+ SCM class, name;
+
+ name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+ if (!scm_is_symbol (name))
+ name = scm_string_to_symbol (scm_nullstr);
+
+ /* FIXME APPLICABLE structs */
+ class =
+ scm_make_extended_class_from_symbol (name, 0);
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
ls = SCM_CDR (ls);
}
flags &= SCM_CLASSF_INHERIT;
- if (flags & SCM_CLASSF_ENTITY)
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
- else
+
+ if (! (flags & SCM_CLASSF_PURE_GENERIC))
{
long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
#if 0
#endif
if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
{
- /* NOTE: The following depends on scm_struct_i_size. */
- flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
+ flags |= SCM_STRUCTF_LIGHT; /* use light representation */
}
}
SCM_SET_CLASS_FLAGS (class, flags);
}
/* Support for the underlying structs: */
- SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
- ? (SCM_CLASSF_GOOPS_OR_VALID
- | SCM_CLASSF_OPERATOR
- | SCM_CLASSF_ENTITY)
- : class == scm_class_operator_class
- ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR
- : SCM_CLASSF_GOOPS_OR_VALID));
+ /* FIXME: set entity flag on z if class == entity_class ? */
+ SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
return z;
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0,
- (SCM body),
- "Internal GOOPS magic---don't use this function!")
-#define FUNC_NAME s_scm_sys_tag_body
-{
- return scm_cons (SCM_IM_LAMBDA, body);
-}
-#undef FUNC_NAME
-
/******************************************************************************
*
* S l o t a c c e s s
#undef FUNC_NAME
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
-
-
+\f
/** Utilities **/
/* In the future, this function will return the effective slot
{
long i;
scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
- const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
+ SCM layout = SCM_PACK (slayout);
/* Set all SCM-holding slots to unbound */
for (i = 0; i < n; i++)
- if (layout[i*2] == 'p')
+ if (scm_i_symbol_ref (layout, i*2) == 'p')
m[i] = SCM_GOOPS_UNBOUND;
else
m[i] = 0;
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- /* Entities */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
+ /* FIXME applicable structs */
+ /* Generic functions */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
{
+ SCM gf;
m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
- "entity struct");
+ "generic function");
m[scm_struct_i_setter] = SCM_BOOL_F;
m[scm_struct_i_procedure] = SCM_BOOL_F;
- /* Generic functions */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM gf = wrap_init (class, m, n);
- clear_method_cache (gf);
- return gf;
- }
- else
- return wrap_init (class, m, n);
+ gf = wrap_init (class, m, n);
+ clear_method_cache (gf);
+ return gf;
}
/* Class objects */
for (i = scm_si_goops_fields; i < n; i++)
SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
- if (SCM_SUBCLASSP (class, scm_class_entity_class))
- SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
- else if (SCM_SUBCLASSP (class, scm_class_operator_class))
- SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR);
+ /* FIXME propagate applicable struct flag */
return z;
}
#define FUNC_NAME s_scm_sys_set_object_setter_x
{
SCM_ASSERT (SCM_STRUCTP (obj)
- && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
- || SCM_I_ENTITYP (obj)),
+ && (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC),
obj,
SCM_ARG1,
FUNC_NAME);
- if (SCM_I_ENTITYP (obj))
- SCM_SET_ENTITY_SETTER (obj, setter);
- else
- SCM_OPERATOR_CLASS (obj)->setter = setter;
+ SCM_SET_GENERIC_SETTER (obj, setter);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
*/
SCM_CRITICAL_SECTION_START;
{
- SCM car = SCM_CAR (old);
- SCM cdr = SCM_CDR (old);
- SCM_SETCAR (old, SCM_CAR (new));
- SCM_SETCDR (old, SCM_CDR (new));
- SCM_SETCAR (new, car);
- SCM_SETCDR (new, cdr);
+ 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_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
SCM_CRITICAL_SECTION_START;
{
- SCM car = SCM_CAR (old);
- SCM cdr = SCM_CDR (old);
- SCM_SETCAR (old, SCM_CAR (new));
- SCM_SETCDR (old, SCM_CDR (new));
+ 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_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
- SCM_SETCAR (new, car);
- SCM_SETCDR (new, cdr);
+ SCM_SET_CELL_WORD_0 (new, word0);
+ SCM_SET_CELL_WORD_1 (new, word1);
SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
}
SCM_CRITICAL_SECTION_END;
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
+ * formats:
+ *
+ * Format #1:
+ * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
+ * #((TYPE1 ... ENV FORMALS FORM ...) ...)
+ * GF)
+ *
+ * Format #2:
+ * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
+ * #((TYPE1 ... ENV FORMALS FORM ...) ...)
+ * GF)
+ *
+ * ARGS is either a list of expressions, in which case they
+ * are interpreted as the arguments of an application, or
+ * a non-pair, which is interpreted as a single expression
+ * yielding all arguments.
+ *
+ * SCM_IM_DISPATCH expressions in generic functions always
+ * have ARGS = the symbol `args' or the iloc #@0-0.
+ *
+ * Need FORMALS in order to support varying arity. This
+ * also avoids the need for renaming of bindings.
+ *
+ * We should probably not complicate this mechanism by
+ * introducing "optimizations" for getters and setters or
+ * primitive methods. Getters and setter will normally be
+ * compiled into @slot-[ref|set!] or a procedure call.
+ * They rely on the dispatch performed before executing
+ * the code which contains them.
+ *
+ * We might want to use a more efficient representation of
+ * this form in the future, perhaps after we have introduced
+ * low-level support for syntax-case macros.
+ */
+
+SCM
+scm_mcache_lookup_cmethod (SCM cache, SCM args)
+{
+ unsigned long i, mask, n, end;
+ SCM ls, methods, z = SCM_CDDR (cache);
+ n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
+ methods = SCM_CADR (z);
+
+ if (scm_is_simple_vector (methods))
+ {
+ /* cache format #1: prepare for linear search */
+ mask = -1;
+ i = 0;
+ end = SCM_SIMPLE_VECTOR_LENGTH (methods);
+ }
+ else
+ {
+ /* cache format #2: compute a hash value */
+ unsigned long hashset = scm_to_ulong (methods);
+ long j = n;
+ z = SCM_CDDR (z);
+ mask = scm_to_ulong (SCM_CAR (z));
+ methods = SCM_CADR (z);
+ i = 0;
+ ls = args;
+ if (!scm_is_null (ls))
+ do
+ {
+ i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
+ [scm_si_hashsets + hashset];
+ ls = SCM_CDR (ls);
+ }
+ while (j-- && !scm_is_null (ls));
+ i &= mask;
+ end = i;
+ }
+
+ /* Search for match */
+ do
+ {
+ long j = n;
+ z = SCM_SIMPLE_VECTOR_REF (methods, i);
+ ls = args; /* list of arguments */
+ if (!scm_is_null (ls))
+ do
+ {
+ /* More arguments than specifiers => CLASS != ENV */
+ if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
+ goto next_method;
+ ls = SCM_CDR (ls);
+ z = SCM_CDR (z);
+ }
+ while (j-- && !scm_is_null (ls));
+ /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
+ if (!scm_is_pair (z)
+ || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
+ return z;
+ next_method:
+ i = (i + 1) & mask;
+ } while (i != end);
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_mcache_compute_cmethod (SCM cache, SCM args)
+{
+ SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
+ if (scm_is_false (cmethod))
+ /* No match - memoize */
+ return scm_memoize_method (cache, args);
+ return cmethod;
+}
+
+SCM
+scm_apply_generic (SCM gf, SCM args)
+{
+ SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf), args);
+ if (SCM_PROGRAM_P (cmethod))
+ return scm_vm_apply (scm_the_vm (), cmethod, args);
+ else if (scm_is_pair (cmethod))
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+ else
+ return scm_apply (cmethod, args, SCM_EOL);
+}
+
+SCM
+scm_call_generic_0 (SCM gf)
+{
+ return scm_apply_generic (gf, SCM_EOL);
+}
+
+SCM
+scm_call_generic_1 (SCM gf, SCM a1)
+{
+ return scm_apply_generic (gf, scm_list_1 (a1));
+}
+
+SCM
+scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
+{
+ return scm_apply_generic (gf, scm_list_2 (a1, a2));
+}
+
+SCM
+scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
+{
+ return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
+}
+
SCM
scm_make_method_cache (SCM gf)
{
clear_method_cache (SCM gf)
{
SCM cache = scm_make_method_cache (gf);
- SCM_SET_ENTITY_PROCEDURE (gf, cache);
+ SCM_SET_GENERIC_METHOD_CACHE (gf, cache);
SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
}
{
SCM n = SCM_SLOT (gf, scm_si_n_specialized);
/* The sign of n is a flag indicating rest args. */
- SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n);
+ SCM_SET_MCACHE_N_SPECIALIZED (SCM_GENERIC_METHOD_CACHE (gf), n);
}
return SCM_UNSPECIFIED;
}
*SCM_SUBR_GENERIC (subr)
= scm_make (scm_list_3 (scm_class_generic,
k_name,
- SCM_SNAME (subr)));
+ SCM_SUBR_NAME (subr)));
subrs = SCM_CDR (subrs);
}
return SCM_UNSPECIFIED;
SCM extension;
} t_extension;
+
+/* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
+ objects. */
+static const char extension_gc_hint[] = "GOOPS extension";
+
static t_extension *extensions = 0;
SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
gf = *SCM_SUBR_GENERIC (extended);
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
gf,
- SCM_SNAME (extension));
- *SCM_SUBR_GENERIC (extension) = gext;
+ SCM_SUBR_NAME (extension));
+ SCM_SET_SUBR_GENERIC (extension, gext);
}
else
{
- t_extension *e = scm_malloc (sizeof (t_extension));
+ t_extension *e = scm_gc_malloc (sizeof (t_extension),
+ extension_gc_hint);
t_extension **loc = &extensions;
/* Make sure that extensions are placed before their own
* extensions in the extensions list. O(N^2) algorithm, but
t_extension *e = extensions;
scm_c_extend_primitive_generic (e->extended, e->extension);
extensions = e->next;
- free (e);
}
}
scm_class_class, scm_class_class, SCM_EOL);
make_stdcls (&scm_class_entity_class, "<entity-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
- make_stdcls (&scm_class_operator_class, "<operator-class>",
- scm_class_class, scm_class_procedure_class, SCM_EOL);
- make_stdcls (&scm_class_operator_with_setter_class,
- "<operator-with-setter-class>",
- scm_class_class, scm_class_operator_class, SCM_EOL);
make_stdcls (&scm_class_method, "<method>",
scm_class_class, scm_class_object, method_slots);
make_stdcls (&scm_class_simple_method, "<simple-method>",
scm_class_entity_class,
scm_list_2 (scm_class_object, scm_class_applicable),
SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_entity, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_entity_with_setter, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_generic, "<generic>",
scm_class_entity_class, scm_class_entity, gf_slots);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
scm_class_entity_class, scm_class_generic, egf_slots);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
scm_class_entity_class,
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_accessor, "<accessor>",
scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
SCM_EOL);
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic);
+ SCM_CLEAR_CLASS_FLAGS (scm_class_extended_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
return class;
}
+static SCM
+make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
+{
+ SCM class, name;
+ if (type_name_sym != SCM_BOOL_F)
+ {
+ name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
+ scm_symbol_to_string (type_name_sym),
+ scm_from_locale_string (">")));
+ name = scm_string_to_symbol (name);
+ }
+ else
+ name = SCM_GOOPS_UNBOUND;
+
+ class = scm_permanent_object (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;
+}
+
SCM
scm_make_extended_class (char const *type_name, int applicablep)
{
applicablep);
}
+static SCM
+scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep)
+{
+ return make_class_from_symbol (type_name_sym,
+ scm_list_1 (applicablep
+ ? scm_class_applicable
+ : scm_class_top),
+ applicablep);
+}
+
void
scm_i_inherit_applicable (SCM c)
{
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
- SCM_SET_STRUCT_TABLE_CLASS (data,
- scm_make_extended_class
- (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
- SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
+ SCM sym = SCM_STRUCT_TABLE_NAME (data);
+ if (scm_is_true (sym))
+ {
+ int applicablep = 0; /* FIXME SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY */
+
+ SCM_SET_STRUCT_TABLE_CLASS (data,
+ scm_make_extended_class_from_symbol (sym, applicablep));
+ }
+
+ scm_remember_upto_here_2 (data, vtable);
return SCM_UNSPECIFIED;
}
SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
}
- else if (size > 0)
- {
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
- SCM_SET_CLASS_INSTANCE_SIZE (class, size);
- }
SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
obj,
SCM_BOOL_F,
scm_struct_ihashq,
- scm_sloppy_assq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
0);
SCM_SETCDR (handle, container);
return obj;
HCoop / bpt / guile.git / blobdiff