Re: [Patch, Fortran] PR fortran/37588: GENERIC resolution broken for array arguments

[Daniel Kraft <d at domob dot eu>]

Daniel Kraft wrote:
> Hi Tobias,
>
> thanks for the quick review!  Thinking about it, however, I found the 
> following test still fails and I guess it should be valid:
[example program typebound_generic_5.f03 from the patch]
> The problem is that ELEMENTAL procedures are not recognized correctly 
> because ranks_must_agree is set to constant true in the call to 
> gfc_compare_actual_formal (I thought that passing the elemental-flag 
> itself would be enough but it seems those two parameters must be set to 
> complementary values; doesn't make sense to me, though).

The attached extended patch fixes this problem, too.  I made 
gfc_compare_actual_formal static again and introduced a new checking 
method instead to compare an actual arglist against a procedure symbol, 
taking into account the ELEMENTAL attribute.  I also had to add a 
missing type-spec initialization in resolve_compcall.

No regressions with the new patch on GNU/Linux-x86-32.  Is this ok to 
commit, too?

Yours,
Daniel

--
Done:     Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go:    Hea-Kni-Mon-Pri-Ran-Rog-Tou

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.

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 140527)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2515,8 +2515,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;
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 140527)
+++ gcc/fortran/interface.c	(working copy)
@@ -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_
       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_
 }
 
 
+/* 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 *int
       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;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 140527)
+++ gcc/fortran/resolve.c	(working copy)
@@ -4501,10 +4501,11 @@ resolve_typebound_generic_call (gfc_expr
 
 	      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);
@@ -4597,6 +4598,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);
Index: gcc/testsuite/gfortran.dg/typebound_generic_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_5.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_generic_5.f03	(revision 0)
@@ -0,0 +1,55 @@
+! { dg-do run }
+
+! Check that generic bindings targetting ELEMENTAL procedures work.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE :: t
+  CONTAINS
+    PROCEDURE, NOPASS :: double
+    PROCEDURE, NOPASS :: double_here
+    GENERIC :: double_it => double
+    GENERIC :: double_inplace => double_here
+  END TYPE t
+
+CONTAINS
+
+  ELEMENTAL INTEGER FUNCTION double (val)
+    IMPLICIT NONE
+    INTEGER, INTENT(IN) :: val
+    double = 2 * val
+  END FUNCTION double
+
+  ELEMENTAL SUBROUTINE double_here (val)
+    IMPLICIT NONE
+    INTEGER, INTENT(INOUT) :: val
+    val = 2 * val
+  END SUBROUTINE double_here
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+
+  TYPE(t) :: obj
+  INTEGER :: arr(42), arr2(42), arr3(42), arr4(42)
+  INTEGER :: i
+
+  arr = (/ (i, i = 1, 42) /)
+
+  arr2 = obj%double (arr)
+  arr3 = obj%double_it (arr)
+
+  arr4 = arr
+  CALL obj%double_inplace (arr4)
+
+  IF (ANY (arr2 /= 2 * arr) .OR. &
+      ANY (arr3 /= 2 * arr) .OR. &
+      ANY (arr4 /= 2 * arr)) THEN
+    CALL abort ()
+  END IF
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_generic_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_4.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_generic_4.f03	(revision 0)
@@ -0,0 +1,57 @@
+! { dg-do run }
+
+! FIXME: Remove -w once the TYPE/CLASS issue is resolved
+! { dg-options "-w" }
+
+! PR fortran/37588
+! This test used to not resolve the GENERIC binding.
+
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+module bar_mod
+
+  type foo
+    integer :: i
+    
+  contains
+    procedure, pass(a) :: foo_v => foo_v_inner    
+    procedure, pass(a) :: foo_m => foo_m_inner    
+    generic, public    :: foo => foo_v, foo_m
+  end type foo
+  
+  private foo_v_inner, foo_m_inner
+
+contains
+  
+  subroutine foo_v_inner(x,a)
+    real :: x(:)
+    type(foo) :: a
+    
+    a%i = int(x(1))
+    WRITE (*,*) "Vector"
+  end subroutine foo_v_inner
+  
+  subroutine foo_m_inner(x,a)
+    real :: x(:,:)
+    type(foo) :: a
+    
+    a%i = int(x(1,1))
+    WRITE (*,*) "Matrix"
+  end subroutine foo_m_inner
+end module bar_mod
+
+program foobar
+  use bar_mod
+  type(foo) :: dat
+  real :: x1(10), x2(10,10)
+
+  x1=1
+  x2=2
+ 
+  call dat%foo(x1)
+  call dat%foo(x2)
+
+end program foobar
+
+! { dg-output "Vector.*Matrix" }
+! { dg-final { cleanup-modules "bar_mod" } }