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

4 files changed, 50 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5d1ad31..1210d39 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+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  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/37580
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fa3f865..4e9959e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2517,8 +2517,7 @@ gfc_try gfc_add_interface (gfc_symbol *);
 gfc_interface *gfc_current_interface_head (void);
 void gfc_set_current_interface_head (gfc_interface *);
 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
-int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*,
-      			       int, int, locus*);
+bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
 
 /* io.c */
 extern gfc_st_label format_asterisk;
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;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a7c62c3..d682e10 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4510,10 +4510,11 @@ resolve_typebound_generic_call (gfc_expr* e)
 
 	      args = update_arglist_pass (args, po, g->specific->pass_arg_num);
 	    }
+	  resolve_actual_arglist (args, target->attr.proc,
+				  is_external_proc (target) && !target->formal);
 
 	  /* Check if this arglist matches the formal.  */
-	  matches = gfc_compare_actual_formal (&args, target->formal, 1,
-					       target->attr.elemental, NULL);
+	  matches = gfc_arglist_matches_symbol (&args, target);
 
 	  /* Clean up and break out of the loop if we've found it.  */
 	  gfc_free_actual_arglist (args);
@@ -4606,6 +4607,7 @@ resolve_compcall (gfc_expr* e)
   e->value.function.isym = NULL;
   e->value.function.esym = NULL;
   e->symtree = target;
+  e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
   return gfc_resolve_expr (e);