re PR fortran/37588 (GENERIC type-bound procedure is not resolved)

2008-09-23  Daniel Kraft  <d@domob.eu>

	PR fortran/37588
	* gfortran.h (gfc_compare_actual_formal): Removed, made private.
	(gfc_arglist_matches_symbol): New method.
	* interface.c (compare_actual_formal): Made static.
	(gfc_procedure_use): Use new name of compare_actual_formal.
	(gfc_arglist_matches_symbol): New method.
	(gfc_search_interface): Moved code partially to new
	gfc_arglist_matches_symbol.
	* resolve.c (resolve_typebound_generic_call): Resolve actual arglist
	before checking against formal and use new gfc_arglist_matches_symbol
	for checking.
	(resolve_compcall): Set type-spec of generated expression.

2008-09-23  Daniel Kraft  <d@domob.eu>

	PR fortran/37588
	* gfortran.dg/typebound_generic_4.f03: New test.
	* gfortran.dg/typebound_generic_5.f03: New test.

From-SVN: r140594

1 files changed, 30 insertions, 16 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9df24ff..17f7033 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1818,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
    errors when things don't match instead of just returning the status
    code.  */
 
-int
-gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
-      			   int ranks_must_agree, int is_elemental, locus *where)
+static int
+compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+	 	       int ranks_must_agree, int is_elemental, locus *where)
 {
   gfc_actual_arglist **new_arg, *a, *actual, temp;
   gfc_formal_arglist *f;
@@ -2448,8 +2448,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
       return;
     }
 
-  if (!gfc_compare_actual_formal (ap, sym->formal, 0,
-		  		  sym->attr.elemental, where))
+  if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
     return;
 
   check_intents (sym->formal, *ap);
@@ -2458,6 +2457,30 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 }
 
 
+/* Try if an actual argument list matches the formal list of a symbol,
+   respecting the symbol's attributes like ELEMENTAL.  This is used for
+   GENERIC resolution.  */
+
+bool
+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
+{
+  bool r;
+
+  gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+  r = !sym->attr.elemental;
+  if (compare_actual_formal (args, sym->formal, r, !r, NULL))
+    {
+      check_intents (sym->formal, *args);
+      if (gfc_option.warn_aliasing)
+	check_some_aliasing (sym->formal, *args);
+      return true;
+    }
+
+  return false;
+}
+
+
 /* Given an interface pointer and an actual argument list, search for
    a formal argument list that matches the actual.  If found, returns
    a pointer to the symbol of the correct interface.  Returns NULL if
@@ -2467,8 +2490,6 @@ gfc_symbol *
 gfc_search_interface (gfc_interface *intr, int sub_flag,
 		      gfc_actual_arglist **ap)
 {
-  int r;
-
   for (; intr; intr = intr->next)
     {
       if (sub_flag && intr->sym->attr.function)
@@ -2476,15 +2497,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
       if (!sub_flag && intr->sym->attr.subroutine)
 	continue;
 
-      r = !intr->sym->attr.elemental;
-
-      if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
-	{
-	  check_intents (intr->sym->formal, *ap);
-	  if (gfc_option.warn_aliasing)
-	    check_some_aliasing (intr->sym->formal, *ap);
-	  return intr->sym;
-	}
+      if (gfc_arglist_matches_symbol (ap, intr->sym))
+	return intr->sym;
     }
 
   return NULL;