From 9db8cf1634ca9a91cb88b2532f7b87f2502b4abd Mon Sep 17 00:00:00 2001
From: Michael Gran <spk121@yahoo.com>
Date: Sun, 23 Aug 2009 10:40:44 -0700
Subject: [PATCH] Avoid unpacking symbols in GOOPS

* 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
---
 libguile/goops.c | 65 ++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 55 insertions(+), 10 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 8145e4162..d1beab3d6 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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;
 }
 
-- 
2.20.1