re PR fortran/46971 ([OOP] ICE on long class names)

2010-12-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46971
	* gfortran.h (gfc_hash_value): Add prototype.
	* class.c (get_unique_type_string): Check if proc_name is present and
	make sure string contains an underscore.
	(get_unique_hashed_string): New function which creates a hashed string
	if the given unique string is too long.
	(gfc_hash_value): Moved here from decl.c, renamed and simplified.
	(gfc_build_class_symbol, gfc_find_derived_vtab): Use hashed strings.
	* decl.c (hash_value): Moved to class.c.
	(gfc_match_derived_decl): Renamed 'hash_value'.


2010-12-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46971
	* gfortran.dg/class_33.f90: New.

From-SVN: r168363

gcc/fortran/ChangeLog

+2010-12-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46971
+	* gfortran.h (gfc_hash_value): Add prototype.
+	* class.c (get_unique_type_string): Check if proc_name is present and
+	make sure string contains an underscore.
+	(get_unique_hashed_string): New function which creates a hashed string
+	if the given unique string is too long.
+	(gfc_hash_value): Moved here from decl.c, renamed and simplified.
+	(gfc_build_class_symbol, gfc_find_derived_vtab): Use hashed strings.
+	* decl.c (hash_value): Moved to class.c.
+	(gfc_match_derived_decl): Renamed 'hash_value'.
+
 2010-12-30  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/47085

gcc/fortran/class.c

 /* Implementation of Fortran 2003 Polymorphism.
    Copyright (C) 2009, 2010
    Free Software Foundation, Inc.
-   Contributed by Paul Richard Thomas & Janus Weil
+   Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
+   and Janus Weil <janus@gcc.gnu.org>
 
 This file is part of GCC.
 
@@ -116,8 +117,51 @@ get_unique_type_string (char *string, gfc_symbol *derived)
 {  
   if (derived->module)
     sprintf (string, "%s_%s", derived->module, derived->name);
-  else
+  else if (derived->ns->proc_name)
     sprintf (string, "%s_%s", derived->ns->proc_name->name, derived->name);
+  else
+    sprintf (string, "_%s", derived->name);
+}
+
+
+/* A relative of 'get_unique_type_string' which makes sure the generated
+   string will not be too long (replacing it by a hash string if needed).  */
+
+static void
+get_unique_hashed_string (char *string, gfc_symbol *derived)
+{
+  char tmp[2*GFC_MAX_SYMBOL_LEN+2];
+  get_unique_type_string (&tmp[0], derived);
+  /* If string is too long, use hash value in hex representation
+     (allow for extra decoration, cf. gfc_build_class_symbol)*/
+  if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 10)
+    {
+      int h = gfc_hash_value (derived);
+      sprintf (string, "%X", h);
+    }
+  else
+    strcpy (string, tmp);
+}
+
+
+/* Assign a hash value for a derived type. The algorithm is that of SDBM.  */
+
+unsigned int
+gfc_hash_value (gfc_symbol *sym)
+{
+  unsigned int hash = 0;
+  char c[2*(GFC_MAX_SYMBOL_LEN+1)];
+  int i, len;
+  
+  get_unique_type_string (&c[0], sym);
+  len = strlen (c);
+  
+  for (i = 0; i < len; i++)
+    hash = (hash << 6) + (hash << 16) - hash + c[i];
+
+  /* Return the hash but take the modulus for the sake of module read,
+     even though this slightly increases the chance of collision.  */
+  return (hash % 100000000);
 }
 
 
@@ -130,13 +174,13 @@ gfc_try
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 			gfc_array_spec **as, bool delayed_vtab)
 {
-  char name[GFC_MAX_SYMBOL_LEN], tname[GFC_MAX_SYMBOL_LEN];
+  char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
 
   /* Determine the name of the encapsulating type.  */
-  get_unique_type_string (tname, ts->u.derived);
+  get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && (*as)->rank && attr->allocatable)
     sprintf (name, "__class_%s_%d_a", tname, (*as)->rank);
   else if ((*as) && (*as)->rank)
@@ -343,9 +387,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
     
   if (ns)
     {
-      char name[GFC_MAX_SYMBOL_LEN], tname[GFC_MAX_SYMBOL_LEN];
+      char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
       
-      get_unique_type_string (tname, derived);
+      get_unique_hashed_string (tname, derived);
       sprintf (name, "__vtab_%s", tname);
 
       /* Look for the vtab symbol in various namespaces.  */

gcc/fortran/decl.c

@@ -7183,46 +7183,6 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
 }
 
 
-/* Assign a hash value for a derived type. The algorithm is that of
-   SDBM. The hashed string is '[module_name #] derived_name'.  */
-static unsigned int
-hash_value (gfc_symbol *sym)
-{
-  unsigned int hash = 0;
-  const char *c;
-  int i, len;
-
-  /* Hash of the module or procedure name.  */
-  if (sym->module != NULL)
-    c = sym->module;
-  else if (sym->ns && sym->ns->proc_name
-	     && sym->ns->proc_name->attr.flavor == FL_MODULE)
-    c = sym->ns->proc_name->name;
-  else
-    c = NULL;
-
-  if (c)
-    { 
-      len = strlen (c);
-      for (i = 0; i < len; i++, c++)
-	hash =  (hash << 6) + (hash << 16) - hash + (*c);
-
-      /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'.  */ 
-      hash =  (hash << 6) + (hash << 16) - hash + '#';
-    }
-
-  /* Hash of the derived type name.  */
-  len = strlen (sym->name);
-  c = sym->name;
-  for (i = 0; i < len; i++, c++)
-    hash = (hash << 6) + (hash << 16) - hash + (*c);
-
-  /* Return the hash but take the modulus for the sake of module read,
-     even though this slightly increases the chance of collision.  */
-  return (hash % 100000000);
-}
-
-
 /* Match the beginning of a derived type declaration.  If a type name
    was the result of a function, then it is possible to have a symbol
    already to be known as a derived type yet have no components.  */
@@ -7355,7 +7315,7 @@ gfc_match_derived_decl (void)
 
   if (!sym->hash_value)
     /* Set the hash for the compound name for this type.  */
-    sym->hash_value = hash_value (sym);
+    sym->hash_value = gfc_hash_value (sym);
 
   /* Take over the ABSTRACT attribute.  */
   sym->attr.abstract = attr.abstract;

gcc/fortran/gfortran.h

@@ -2868,6 +2868,7 @@ void gfc_add_component_ref (gfc_expr *, const char *);
 #define gfc_add_size_component(e)     gfc_add_component_ref(e,"_size")
 #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
 gfc_expr *gfc_class_null_initializer (gfc_typespec *);
+unsigned int gfc_hash_value (gfc_symbol *);
 gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 				gfc_array_spec **, bool);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);

gcc/testsuite/ChangeLog

+2010-12-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46971
+	* gfortran.dg/class_33.f90: New.
+
 2010-12-30  Nicola Pero  <nicola.pero@meta-innovation.com>
 
 	* objc.dg/method-conflict-3.m: New.

gcc/testsuite/gfortran.dg/class_33.f90

+! { dg-do compile }
+!
+! PR 46971: [4.6 Regression] [OOP] ICE on long class names
+!
+! Contributed by Andrew Benson <abenson@its.caltech.edu>
+
+module Molecular_Abundances_Structure
+  type molecularAbundancesStructure
+  end type
+  class(molecularAbundancesStructure), pointer :: molecules
+end module
+
+! { dg-final { cleanup-modules "Molecular_Abundances_Structure" } }