mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Avoid unpacking symbols in GOOPS

Browse source 
* libguile/goops.c (scm_make_extended_class_from_symbol): new function
  (scm_class_of): don't unpack symbol chars
  (wrap_init): don't unpack symbol chars
  (make_class_from_symbol): new function
  (make_struct_class): don't unpack symbol chars
This commit is contained in:
Michael Gran 2009-08-23 10:40:44 -07:00
parent 587a33556f
commit 9db8cf1634
1 changed files with 55 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

65
libguile/goops.c
View file

@ -176,6 +176,8 @@ static SCM scm_unbound_p (SCM obj);
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,
@ -281,9 +283,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
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 class = scm_make_extended_class_from_symbol (scm_is_true (name)
? name
: scm_nullstr,
SCM_I_OPERATORP (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
@ -1526,11 +1528,11 @@ wrap_init (SCM class, SCM *m, long n)
{
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;
@ -2680,6 +2682,34 @@ make_class_from_template (char const *template, char const *type_name, SCM super
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)
{
@ -2691,6 +2721,16 @@ 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)
{
@ -2783,11 +2823,16 @@ static SCM
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 = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR;
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym, applicablep));
}
scm_remember_upto_here_2 (data, vtable);
return SCM_UNSPECIFIED;
}