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, 78 insertions, 29 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d96b332..94c21be 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -454,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc)
 static void
 find_arglists (gfc_symbol *sym)
 {
-  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
+  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
+      || sym->attr.flavor == FL_DERIVED)
     return;
 
   resolve_formal_arglist (sym);
@@ -967,13 +968,6 @@ resolve_structure_cons (gfc_expr *expr, int init)
     resolve_fl_derived0 (expr->ts.u.derived);
 
   cons = gfc_constructor_first (expr->value.constructor);
-  /* A constructor may have references if it is the result of substituting a
-     parameter variable.  In this case we just pull out the component we
-     want.  */
-  if (expr->ref)
-    comp = expr->ref->u.c.sym->components;
-  else
-    comp = expr->ts.u.derived->components;
 
   /* See if the user is trying to invoke a structure constructor for one of
      the iso_c_binding derived types.  */
@@ -992,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init)
       && cons->expr && cons->expr->expr_type == EXPR_NULL)
     return SUCCESS;
 
+  /* A constructor may have references if it is the result of substituting a
+     parameter variable.  In this case we just pull out the component we
+     want.  */
+  if (expr->ref)
+    comp = expr->ref->u.c.sym->components;
+  else
+    comp = expr->ts.u.derived->components;
+
   for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
     {
       int rank;
@@ -1401,7 +1403,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
   gfc_symbol* context_proc;
   gfc_namespace* real_context;
 
-  if (sym->attr.flavor == FL_PROGRAM)
+  if (sym->attr.flavor == FL_PROGRAM
+      || sym->attr.flavor == FL_DERIVED)
     return false;
 
   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
@@ -2323,6 +2326,7 @@ resolve_generic_f (gfc_expr *expr)
 {
   gfc_symbol *sym;
   match m;
+  gfc_interface *intr = NULL;
 
   sym = expr->symtree->n.sym;
 
@@ -2335,6 +2339,11 @@ resolve_generic_f (gfc_expr *expr)
 	return FAILURE;
 
 generic:
+      if (!intr)
+	for (intr = sym->generic; intr; intr = intr->next)
+	  if (intr->sym->attr.flavor == FL_DERIVED)
+	    break;
+
       if (sym->ns->parent == NULL)
 	break;
       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
@@ -2347,16 +2356,25 @@ generic:
 
   /* Last ditch attempt.  See if the reference is to an intrinsic
      that possesses a matching interface.  14.1.2.4  */
-  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
+  if (sym  && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
     {
-      gfc_error ("There is no specific function for the generic '%s' at %L",
-		 expr->symtree->n.sym->name, &expr->where);
+      gfc_error ("There is no specific function for the generic '%s' "
+		 "at %L", expr->symtree->n.sym->name, &expr->where);
       return FAILURE;
     }
 
+  if (intr)
+    {
+      if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
+						false) != SUCCESS)
+	return FAILURE;
+      return resolve_structure_cons (expr, 0);
+    }
+
   m = gfc_intrinsic_func_interface (expr, 0);
   if (m == MATCH_YES)
     return SUCCESS;
+
   if (m == MATCH_NO)
     gfc_error ("Generic function '%s' at %L is not consistent with a "
 	       "specific intrinsic interface", expr->symtree->n.sym->name,
@@ -5053,6 +5071,9 @@ resolve_variable (gfc_expr *e)
   if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
     return FAILURE;
 
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
+    sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+
   /* On the other hand, the parser may not have known this is an array;
      in this case, we have to add a FULL reference.  */
   if (sym->assoc && sym->attr.dimension && !e->ref)
@@ -10152,6 +10173,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
     {
       gfc_symbol *s;
       gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
+      if (s && s->attr.generic)
+	s = gfc_find_dt_in_generic (s);
       if (s && s->attr.flavor != FL_DERIVED)
 	{
 	  gfc_error ("The type '%s' cannot be host associated at %L "
@@ -11718,6 +11741,13 @@ resolve_fl_derived0 (gfc_symbol *sym)
 	    }
 	}
 
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
+	c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
+      else if (c->ts.type == BT_CLASS && c->attr.class_ok
+	       && CLASS_DATA (c)->ts.u.derived->attr.generic)
+	CLASS_DATA (c)->ts.u.derived
+			= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
+
       if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
 	  && c->attr.pointer && c->ts.u.derived->components == NULL
 	  && !c->ts.u.derived->attr.zero_comp)
@@ -11788,6 +11818,23 @@ resolve_fl_derived0 (gfc_symbol *sym)
 static gfc_try
 resolve_fl_derived (gfc_symbol *sym)
 {
+  gfc_symbol *gen_dt = NULL;
+
+  if (!sym->attr.is_class)
+    gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
+  if (gen_dt && gen_dt->generic && gen_dt->generic->next
+      && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
+			 "function '%s' at %L being the same name as derived "
+			 "type at %L", sym->name,
+			 gen_dt->generic->sym == sym
+			   ? gen_dt->generic->next->sym->name
+			   : gen_dt->generic->sym->name,
+			 gen_dt->generic->sym == sym
+			   ? &gen_dt->generic->next->sym->declared_at
+			   : &gen_dt->generic->sym->declared_at,
+			 &sym->declared_at) == FAILURE)
+    return FAILURE;
+
   if (sym->attr.is_class && sym->ts.u.derived == NULL)
     {
       /* Fix up incomplete CLASS symbols.  */
@@ -12191,6 +12238,20 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+      && sym->ts.u.derived->attr.generic)
+    {
+      sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+      if (!sym->ts.u.derived)
+	{
+	  gfc_error ("The derived type '%s' at %L is of type '%s', "
+		     "which has not been defined", sym->name,
+		     &sym->declared_at, sym->ts.u.derived->name);
+	  sym->ts.type = BT_UNKNOWN;
+	  return;
+	}
+    }
+
   /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
      do this for something that was implicitly typed because that is handled
      in gfc_set_default_type.  Handle dummy arguments and procedure
@@ -12260,7 +12321,8 @@ resolve_symbol (gfc_symbol *sym)
      the type is not declared in the scope of the implicit
      statement. Change the type to BT_UNKNOWN, both because it is so
      and to prevent an ICE.  */
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
+  if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+      && sym->ts.u.derived->components == NULL
       && !sym->ts.u.derived->attr.zero_comp)
     {
       gfc_error ("The derived type '%s' at %L is of type '%s', "
@@ -12276,22 +12338,9 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->ts.type == BT_DERIVED
 	&& sym->ts.u.derived->attr.use_assoc
 	&& sym->ns->proc_name
-	&& sym->ns->proc_name->attr.flavor == FL_MODULE)
-    {
-      gfc_symbol *ds;
-
-      if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
-	return;
-
-      gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
-      if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
-	{
-	  symtree = gfc_new_symtree (&sym->ns->sym_root,
-				     sym->ts.u.derived->name);
-	  symtree->n.sym = sym->ts.u.derived;
-	  sym->ts.u.derived->refs++;
-	}
-    }
+	&& sym->ns->proc_name->attr.flavor == FL_MODULE
+        && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
+    return;
 
   /* Unless the derived-type declaration is use associated, Fortran 95
      does not allow public entries of private derived types.