[Patch, fortran] PR42736 - [4.3/4.4/4.5 Regression] Wrong-code with allocatable or pointer components in elemental functions

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

This PR, as correctly identified by Tobias, was caused by r142154.

The part of the dependency checking that tries to check for aliasing
is excessively loose for derived types. So much so, that the fact that
the variable 'Table' is a pointer is sufficient to trigger a
dependency, with any pointee, and requires that a temporary is used
for the result of the interface assignment.  This fails for the
elemental function used in the assignment.

The patch tightens up the checking for aliasing by looking for a type
match between the ultimate pointer component of one expression and the
other expression or its components.  This is done symmetrically by
calling the new functions twice, with the arguments interchanged.

I believe that it is still possible to trigger the seg fault by
judicious choice of pointer and pointee.  I will check this out and
will report the conditions for this to occur.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk, 4.4 and 4.3?

Cheers

Paul

2010-01-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42736
	* dependency.c (possible_aliasing_types): New function.
	(possible_aliasing): New function.
	(gfc_check_dependency): Call the above to tighten up checking
	of potential aliasing with derived types.

2010-01-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42736
	* gfortran.dg/dependency_25.f90 : New test.

Index: gcc/fortran/dependency.c
===================================================================
*** gcc/fortran/dependency.c	(revision 155875)
--- gcc/fortran/dependency.c	(working copy)
*************** gfc_are_equivalenced_arrays (gfc_expr *e
*** 677,682 ****
--- 677,758 ----
  }
  
  
+ /* Check that a pointer type ts1 cannot point to ts2 or its
+    components.  */
+ static int
+ possible_aliasing_types (gfc_typespec *ts1, gfc_typespec *ts2)
+ {
+   gfc_component *cmp;
+ 
+   if (gfc_compare_types (ts1, ts2))
+     return 1;
+ 
+   if (ts2->type == BT_DERIVED)
+     {
+       cmp = ts2->u.derived->components;
+       for (; cmp; cmp = cmp->next)
+ 	if (possible_aliasing_types (ts1, &cmp->ts))
+ 	  return 1;
+     }
+ 
+   return 0;
+ }
+ 
+ 
+ /* If expr1 or, if it is a derived type, one of its components, test
+    the type of expr2 or its components to see if they match.  In this
+    case there is a possibility for aliasing.  */
+ static int
+ possible_aliasing (gfc_expr *expr1, gfc_expr *expr2)
+ {
+   gfc_ref *ref1;
+   gfc_ref *ref2;
+   gfc_typespec *ts1;
+   gfc_typespec *ts2;
+ 
+   if (expr1->expr_type != EXPR_VARIABLE
+ 	|| expr1->expr_type != EXPR_VARIABLE)
+     return 0;
+ 
+   ts1 = NULL;
+ 
+   /* Check the last component reference of expr1.  */
+   for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
+     if (ref1->type == REF_COMPONENT)
+       {
+ 	if (ref1->u.c.component->attr.pointer)
+           ts1 = &ref1->u.c.component->ts;
+       }
+ 
+   /* If the last component reference is not a pointer,
+      check the symbol, if it is a pointer.  */
+   if (ts1 == NULL && expr1->symtree->n.sym->attr.pointer)
+     ts1 = &expr1->symtree->n.sym->ts;
+ 
+   if (ts1 == NULL)
+     return 0;
+ 
+   /* Check for match with last component reference of
+      expr2.  */
+   ts2 = NULL;
+   for (ref2 = expr2->ref; ref2; ref2 = ref2->next)
+     if (ref2->type == REF_COMPONENT)
+       ts2 = &ref2->u.c.component->ts;
+ 
+   /* Again, if the last component reference is not a potential
+      pointee, try the symbol.  */
+   if (ts2 == NULL)
+     ts2 = &expr2->ts;
+ 
+   /* Compare the types, including components of ts2.  */
+   if (possible_aliasing_types (ts1, ts2))
+     return 1;
+ 
+   return 0;
+ }
+ 
+ 
+ 
  /* Return true if the statement body redefines the condition.  Returns
     true if expr2 depends on expr1.  expr1 should be a single term
     suitable for the lhs of an assignment.  The IDENTICAL flag indicates
*************** gfc_check_dependency (gfc_expr *expr1, g
*** 725,731 ****
  
  	  /* If either variable is a pointer, assume the worst.  */
  	  /* TODO: -fassume-no-pointer-aliasing */
! 	  if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
  	    return 1;
  
  	  /* Otherwise distinct symbols have no dependencies.  */
--- 801,810 ----
  
  	  /* If either variable is a pointer, assume the worst.  */
  	  /* TODO: -fassume-no-pointer-aliasing */
! 	  if (gfc_is_data_pointer (expr1) && possible_aliasing (expr1, expr2))
! 	    return 1;
! 
! 	  if (gfc_is_data_pointer (expr2) && possible_aliasing (expr2, expr1))
  	    return 1;
  
  	  /* Otherwise distinct symbols have no dependencies.  */
Index: gcc/testsuite/gfortran.dg/dependency_25.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dependency_25.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/dependency_25.f90	(revision 0)
***************
*** 0 ****
--- 1,95 ----
+ ! { dg-do run }
+ ! Test the fix for PR42736, in which an excessively rigorous dependency
+ ! checking for the assignment generated an unnecessary temporary, whose
+ ! rank was wrong.  When accessed by the scalarizer, a segfault ensued.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ ! Reported by Armelius Cameron <armeliusc@gmail.com>
+ !
+ module UnitValue_Module
+ 
+   implicit none
+   private
+ 
+   public :: &
+     operator(*), &
+     assignment(=)
+ 
+   type, public :: UnitValue
+     real :: &
+       Value = 1.0
+     character(31) :: &
+       Label
+   end type UnitValue
+ 
+   interface operator(*)
+     module procedure ProductReal_LV
+   end interface operator(*)
+ 
+   interface assignment(=)
+     module procedure Assign_LV_Real
+   end interface assignment(=)
+ 
+ contains
+ 
+   elemental function ProductReal_LV(Multiplier, Multiplicand) result(P_R_LV)
+ 
+     real, intent(in) :: &
+       Multiplier
+     type(UnitValue), intent(in) :: &
+       Multiplicand
+     type(UnitValue) :: &
+       P_R_LV
+ 
+     P_R_LV%Value = Multiplier * Multiplicand%Value
+     P_R_LV%Label = Multiplicand%Label
+ 
+   end function ProductReal_LV
+ 
+ 
+   elemental subroutine Assign_LV_Real(LeftHandSide, RightHandSide)
+ 
+     real, intent(inout) :: &
+       LeftHandSide
+     type(UnitValue), intent(in) :: &
+       RightHandSide
+ 
+     LeftHandSide = RightHandSide%Value
+ 
+   end subroutine Assign_LV_Real
+ 
+ end module UnitValue_Module
+ 
+ program TestProgram
+ 
+   use UnitValue_Module
+ 
+   implicit none
+ 
+   type :: TableForm
+     real, dimension(:,:), allocatable :: &
+       RealData
+   end type TableForm
+ 
+   type(UnitValue) :: &
+     CENTIMETER
+ 
+   type(TableForm), pointer :: &
+     Table
+ 
+   allocate(Table)
+   allocate(Table%RealData(10,5))
+ 
+   CENTIMETER%value = 42
+   Table%RealData = 1
+   Table%RealData(:,1) = Table%RealData(:,1) * CENTIMETER
+   Table%RealData(:,2) = Table%RealData(:,2) * CENTIMETER
+   Table%RealData(:,3) = Table%RealData(:,3) * CENTIMETER
+   Table%RealData(:,5) = Table%RealData(:,5) * CENTIMETER
+ 
+ !  print *, Table%RealData
+   if (any (abs(Table%RealData(:,4) - 1) > epsilon(1.0))) call abort ()
+   if (any (abs(Table%RealData(:,[1,2,3,5]) - 42) > epsilon(1.0))) call abort ()
+ end program TestProgram
+ 
+ ! { dg-final { cleanup-modules "UnitValue_Module" } }