re PR fortran/42736 (Wrong-code with allocatable or pointer components in elemental functions)

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

	PR fortran/42736
	* trans-stmt.c (gfc_conv_elemental_dependencies): If temporary
	is required, turn any trailing array elements after a range
	into ranges so that offsets can be calculated.

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

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

From-SVN: r156161

4 files changed, 136 insertions, 0 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8c8e080..84dcaae 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2010-01-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42736
+	* trans-stmt.c (gfc_conv_elemental_dependencies): If temporary
+	is required, turn any trailing array elements after a range
+	into ranges so that offsets can be calculated.
+
 2010-01-20  Joern Rennecke  <amylaar@spamcop.net>
 
 	* module.c (mio_f2k_derived): Use enumerator as initializer of
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 5159f42..010d86f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -196,6 +196,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
   gfc_ss *ss;
   gfc_ss_info *info;
   gfc_symbol *fsym;
+  gfc_ref *ref;
   int n;
   tree data;
   tree offset;
@@ -251,6 +252,34 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 	  /* Obtain the argument descriptor for unpacking.  */
 	  gfc_init_se (&parmse, NULL);
 	  parmse.want_pointer = 1;
+
+	  /* The scalarizer introduces some specific peculiarities when
+	     handling elemental subroutines; the stride can be needed up to
+	     the dim_array - 1, rather than dim_loop - 1 to calculate
+	     offsets outside the loop.  For this reason, we make sure that
+	     the descriptor has the dimensionality of the array by converting
+	     trailing elements into ranges with end = start.  */
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+	      break;
+
+	  if (ref)
+	    {
+	      bool seen_range = false;
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		{
+		  if (ref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		    seen_range = true;
+
+		  if (!seen_range
+			|| ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+		    continue;
+
+		  ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]);
+		  ref->u.ar.dimen_type[n] = DIMEN_RANGE;
+		}
+	    }
+
 	  gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
 	  gfc_add_block_to_block (&se->pre, &parmse.pre);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3f6a0ce..5f74978 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-01-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/42736
+	* gfortran.dg/dependency_25.f90 : New test.
+
 2010-01-21  Martin Jambor  <mjambor@suse.cz>
 
 	PR tree-optimization/42585
diff --git a/gcc/testsuite/gfortran.dg/dependency_25.f90 b/gcc/testsuite/gfortran.dg/dependency_25.f90
new file mode 100644
index 0000000..2576985
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependency_25.f90
@@ -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" } }