re PR fortran/39427 (F2003: Procedures with same name as types/type constructors)

gcc/fortran
2011-11-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39427
        PR fortran/37829
        * decl.c (match_data_constant, match_data_constant,
        * variable_decl,
        gfc_match_decl_type_spec, access_attr_decl,
        check_extended_derived_type, gfc_match_derived_decl,
        gfc_match_derived_decl, gfc_match_derived_decl) Modified to deal
        with DT constructors.
        * gfortran.h (gfc_find_dt_in_generic,
        gfc_convert_to_structure_constructor): New function prototypes.
        * interface.c (check_interface0, check_interface1,
        gfc_search_interface): Ignore DT constructors in generic list.
        * match.h (gfc_match_structure_constructor): Update prototype.
        * match.c (match_derived_type_spec): Ensure that one uses the DT
        not the generic function.
        * module.c (MOD_VERSION): Bump.
        (dt_lower_string, dt_upper_string): New functions.
        (find_use_name_n, find_use_operator, compare_true_names,
        find_true_name, add_true_name, fix_mio_expr, load_needed,
        read_module, write_dt_extensions, write_symbol): Changes to deal with
        different symtree vs. sym names.
        (create_derived_type): Create also generic procedure.
        * parse.c (gfc_fixup_sibling_symbols): Don't regard DT and
        * generic
        function as the same.
        * primary.c (gfc_convert_to_structure_constructor): New
        * function.
        (gfc_match_structure_constructor): Restructured; calls
        gfc_convert_to_structure_constructor.
        (build_actual_constructor, gfc_match_rvalue): Update for DT generic
        functions.
        * resolve.c (resolve_formal_arglist, resolve_structure_cons,
        is_illegal_recursion, resolve_generic_f, resolve_variable,
        resolve_fl_variable_derived, resolve_fl_derived0,
        resolve_symbol): Handle DT and DT generic constructors.
        * symbol.c (gfc_use_derived, gfc_undo_symbols,
        gen_special_c_interop_ptr, gen_cptr_param,
        generate_isocbinding_symbol, gfc_get_derived_super_type): Handle
        derived-types, which are hidden in the generic type.
        (gfc_find_dt_in_generic): New function
        * trans-array.c (gfc_conv_array_initializer): Replace
        * FL_PARAMETER
        expr by actual value.
        * trans-decl.c (gfc_get_module_backend_decl,
        * gfc_trans_use_stmts):
        Ensure that we use the DT and not the generic function.
        * trans-types.c (gfc_get_derived_type): Ensure that we use the
        * DT
        and not the generic procedure.

gcc/testsuite/
2011-11-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39427
        PR fortran/37829
        * gfortran.dg/constructor_1.f90: New.
        * gfortran.dg/constructor_2.f90: New.
        * gfortran.dg/constructor_3.f90: New.
        * gfortran.dg/constructor_4.f90: New.
        * gfortran.dg/constructor_5.f90: New.
        * gfortran.dg/constructor_6.f90: New.
        * gfortran.dg/use_only_5.f90: New.
        * gfortran.dg/c_ptr_tests_17.f90: New.
        * gfortran.dg/c_ptr_tests_18.f90: New.
        * gfortran.dg/used_types_25.f90: New.
        * gfortran.dg/used_types_26.f90: New
        * gfortran.dg/type_decl_3.f90: New.
        * gfortran.dg/function_types_3.f90: Update dg-error.
        * gfortran.dg/result_1.f90: Ditto.
        * gfortran.dg/structure_constructor_3.f03: Ditto.
        * gfortran.dg/structure_constructor_4.f03: Ditto.

From-SVN: r181425

1 files changed, 150 insertions, 29 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2dd38b9..3e553a3 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -323,7 +323,7 @@ static match
 match_data_constant (gfc_expr **result)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym = NULL;
   gfc_expr *expr;
   match m;
   locus old_loc;
@@ -366,15 +366,19 @@ match_data_constant (gfc_expr **result)
   if (gfc_find_symbol (name, NULL, 1, &sym))
     return MATCH_ERROR;
 
+  if (sym && sym->attr.generic)
+    dt_sym = gfc_find_dt_in_generic (sym);
+
   if (sym == NULL
-      || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
+      || (sym->attr.flavor != FL_PARAMETER
+	  && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
     {
       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
 		 name);
       return MATCH_ERROR;
     }
-  else if (sym->attr.flavor == FL_DERIVED)
-    return gfc_match_structure_constructor (sym, result, false);
+  else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
+    return gfc_match_structure_constructor (dt_sym, result);
 
   /* Check to see if the value is an initialization array expression.  */
   if (sym->value->expr_type == EXPR_ARRAY)
@@ -1954,10 +1958,10 @@ variable_decl (int elem)
       st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
       if (!(current_ts.u.derived->attr.imported
 		&& st != NULL
-		&& st->n.sym == current_ts.u.derived)
+		&& gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived)
 	    && !gfc_current_ns->has_import_set)
 	{
-	    gfc_error ("the type of '%s' at %C has not been declared within the "
+	    gfc_error ("The type of '%s' at %C has not been declared within the "
 		       "interface", name);
 	    m = MATCH_ERROR;
 	    goto cleanup;
@@ -2501,10 +2505,11 @@ match
 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym;
   match m;
   char c;
   bool seen_deferred_kind, matched_type;
+  const char *dt_name;
 
   /* A belt and braces check that the typespec is correctly being treated
      as a deferred characteristic association.  */
@@ -2668,40 +2673,96 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       ts->u.derived = NULL;
       if (gfc_current_state () != COMP_INTERFACE
 	    && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
-	ts->u.derived = sym;
+	{
+	  sym = gfc_find_dt_in_generic (sym);
+	  ts->u.derived = sym;
+	}
       return MATCH_YES;
     }
 
   /* Search for the name but allow the components to be defined later.  If
      type = -1, this typespec has been seen in a function declaration but
-     the type could not be accessed at that point.  */
+     the type could not be accessed at that point.  The actual derived type is
+     stored in a symtree with the first letter of the name captialized; the
+     symtree with the all lower-case name contains the associated
+     generic function.  */
+  dt_name = gfc_get_string ("%c%s",
+			    (char) TOUPPER ((unsigned char) name[0]),
+			    (const char*)&name[1]);
   sym = NULL;
-  if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
+  dt_sym = NULL;
+  if (ts->kind != -1)
     {
-      gfc_error ("Type name '%s' at %C is ambiguous", name);
-      return MATCH_ERROR;
+      gfc_get_ha_symbol (name, &sym);
+      if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
+	{
+	  gfc_error ("Type name '%s' at %C is ambiguous", name);
+	  return MATCH_ERROR;
+	}
+      if (sym->generic && !dt_sym)
+	dt_sym = gfc_find_dt_in_generic (sym);
     }
   else if (ts->kind == -1)
     {
       int iface = gfc_state_stack->previous->state != COMP_INTERFACE
 		    || gfc_current_ns->has_import_set;
-      if (gfc_find_symbol (name, NULL, iface, &sym))
+      gfc_find_symbol (name, NULL, iface, &sym);
+      if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
 	{       
 	  gfc_error ("Type name '%s' at %C is ambiguous", name);
 	  return MATCH_ERROR;
 	}
+      if (sym && sym->generic && !dt_sym)
+	dt_sym = gfc_find_dt_in_generic (sym);
 
       ts->kind = 0;
       if (sym == NULL)
 	return MATCH_NO;
     }
 
-  if (sym->attr.flavor != FL_DERIVED
-      && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
-    return MATCH_ERROR;
+  if ((sym->attr.flavor != FL_UNKNOWN
+       && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
+      || sym->attr.subroutine)
+    {
+      gfc_error ("Type name '%s' at %C conflicts with previously declared "
+	         "entity at %L, which has the same name", name,
+		 &sym->declared_at);
+      return MATCH_ERROR;
+    }
 
   gfc_set_sym_referenced (sym);
-  ts->u.derived = sym;
+  if (!sym->attr.generic
+      && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
+    return MATCH_ERROR;
+
+  if (!sym->attr.function
+      && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+    return MATCH_ERROR;
+
+  if (!dt_sym)
+    {
+      gfc_interface *intr, *head;
+
+      /* Use upper case to save the actual derived-type symbol.  */
+      gfc_get_symbol (dt_name, NULL, &dt_sym);
+      dt_sym->name = gfc_get_string (sym->name);
+      head = sym->generic;
+      intr = gfc_get_interface ();
+      intr->sym = dt_sym;
+      intr->where = gfc_current_locus;
+      intr->next = head;
+      sym->generic = intr;
+      sym->attr.if_source = IFSRC_DECL;
+    }
+
+  gfc_set_sym_referenced (dt_sym);
+
+  if (dt_sym->attr.flavor != FL_DERIVED
+      && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
+			 == FAILURE)
+    return MATCH_ERROR;
+
+  ts->u.derived = dt_sym;
 
   return MATCH_YES;
 
@@ -3053,6 +3114,20 @@ gfc_match_import (void)
 	  sym->refs++;
 	  sym->attr.imported = 1;
 
+	  if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
+	    {
+	      /* The actual derived type is stored in a symtree with the first
+		 letter of the name captialized; the symtree with the all
+		 lower-case name contains the associated generic function. */
+	      st = gfc_new_symtree (&gfc_current_ns->sym_root,
+			gfc_get_string ("%c%s",
+				(char) TOUPPER ((unsigned char) sym->name[0]),
+				&sym->name[1]));
+	      st->n.sym = sym;
+	      sym->refs++;
+	      sym->attr.imported = 1;
+	    }
+
 	  goto next_item;
 
 	case MATCH_NO:
@@ -6475,7 +6550,7 @@ access_attr_decl (gfc_statement st)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   interface_type type;
   gfc_user_op *uop;
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym;
   gfc_intrinsic_op op;
   match m;
 
@@ -6505,6 +6580,13 @@ access_attr_decl (gfc_statement st)
 			      sym->name, NULL) == FAILURE)
 	    return MATCH_ERROR;
 
+	  if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
+	      && gfc_add_access (&dt_sym->attr,
+				 (st == ST_PUBLIC) ? ACCESS_PUBLIC
+						   : ACCESS_PRIVATE,
+				 sym->name, NULL) == FAILURE)
+	    return MATCH_ERROR;
+
 	  break;
 
 	case INTERFACE_INTRINSIC_OP:
@@ -7175,6 +7257,8 @@ check_extended_derived_type (char *name)
       return NULL;
     }
 
+  extended = gfc_find_dt_in_generic (extended);
+
   if (extended->attr.flavor != FL_DERIVED)
     {
       gfc_error ("'%s' in EXTENDS expression at %C is not a "
@@ -7277,11 +7361,12 @@ gfc_match_derived_decl (void)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   char parent[GFC_MAX_SYMBOL_LEN + 1];
   symbol_attribute attr;
-  gfc_symbol *sym;
+  gfc_symbol *sym, *gensym;
   gfc_symbol *extended;
   match m;
   match is_type_attr_spec = MATCH_NO;
   bool seen_attr = false;
+  gfc_interface *intr = NULL, *head;
 
   if (gfc_current_state () == COMP_DERIVED)
     return MATCH_NO;
@@ -7327,16 +7412,50 @@ gfc_match_derived_decl (void)
       return MATCH_ERROR;
     }
 
-  if (gfc_get_symbol (name, NULL, &sym))
+  if (gfc_get_symbol (name, NULL, &gensym))
     return MATCH_ERROR;
 
-  if (sym->ts.type != BT_UNKNOWN)
+  if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
     {
       gfc_error ("Derived type name '%s' at %C already has a basic type "
-		 "of %s", sym->name, gfc_typename (&sym->ts));
+		 "of %s", gensym->name, gfc_typename (&gensym->ts));
+      return MATCH_ERROR;
+    }
+
+  if (!gensym->attr.generic
+      && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE)
+    return MATCH_ERROR;
+
+  if (!gensym->attr.function
+      && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE)
+    return MATCH_ERROR;
+
+  sym = gfc_find_dt_in_generic (gensym);
+
+  if (sym && (sym->components != NULL || sym->attr.zero_comp))
+    {
+      gfc_error ("Derived type definition of '%s' at %C has already been "
+                 "defined", sym->name);
       return MATCH_ERROR;
     }
 
+  if (!sym)
+    {
+      /* Use upper case to save the actual derived-type symbol.  */
+      gfc_get_symbol (gfc_get_string ("%c%s",
+			(char) TOUPPER ((unsigned char) gensym->name[0]),
+			&gensym->name[1]), NULL, &sym);
+      sym->name = gfc_get_string (gensym->name);
+      head = gensym->generic;
+      intr = gfc_get_interface ();
+      intr->sym = sym;
+      intr->where = gfc_current_locus;
+      intr->sym->declared_at = gfc_current_locus;
+      intr->next = head;
+      gensym->generic = intr;
+      gensym->attr.if_source = IFSRC_DECL;
+    }
+
   /* The symbol may already have the derived attribute without the
      components.  The ways this can happen is via a function
      definition, an INTRINSIC statement or a subtype in another
@@ -7346,16 +7465,18 @@ gfc_match_derived_decl (void)
       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
     return MATCH_ERROR;
 
-  if (sym->components != NULL || sym->attr.zero_comp)
-    {
-      gfc_error ("Derived type definition of '%s' at %C has already been "
-		 "defined", sym->name);
-      return MATCH_ERROR;
-    }
-
   if (attr.access != ACCESS_UNKNOWN
       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
     return MATCH_ERROR;
+  else if (sym->attr.access == ACCESS_UNKNOWN
+	   && gensym->attr.access != ACCESS_UNKNOWN
+	   && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)
+	      == FAILURE)
+    return MATCH_ERROR;
+
+  if (sym->attr.access != ACCESS_UNKNOWN
+      && gensym->attr.access == ACCESS_UNKNOWN)
+    gensym->attr.access = sym->attr.access;
 
   /* See if the derived type was labeled as bind(c).  */
   if (attr.is_bind_c != 0)