re PR fortran/40551 (Optimizations possible using gfc_full_array_ref_p)

2009-06-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40551
	* dependency.h : Add second bool* argument to prototype of
	gfc_full_array_ref_p.
	* dependency.c (gfc_full_array_ref_p): If second argument is
	present, return true if last dimension of reference is an
	element or has unity stride.
	* trans-array.c : Add NULL second argument to references to
	gfc_full_array_ref_p.
	* trans-expr.c : The same, except for;
	(gfc_trans_arrayfunc_assign): Return fail if lhs reference
	is not a full array or a contiguous section.

2009-06-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40551
	* gfortran.dg/func_assign_2.f90 : New test.

From-SVN: r149062

7 files changed, 83 insertions, 11 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3357fde..976a448 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2009-06-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40551
+	* dependency.h : Add second bool* argument to prototype of
+	gfc_full_array_ref_p.
+	* dependency.c (gfc_full_array_ref_p): If second argument is
+	present, return true if last dimension of reference is an
+	element or has unity stride.
+	* trans-array.c : Add NULL second argument to references to
+	gfc_full_array_ref_p.
+	* trans-expr.c : The same, except for;
+	(gfc_trans_arrayfunc_assign): Return fail if lhs reference
+	is not a full array or a contiguous section.
+
 2009-06-28  Tobias Burnus  <burnus@net-b.de>
 	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index 5f74c34..eb07e7c 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -1186,12 +1186,16 @@ gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
 
 
 /* Determine if an array ref, usually an array section specifies the
-   entire array.  */
+   entire array.  In addition, if the second, pointer argument is
+   provided, the function will return true if the reference is
+   contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
 
 bool
-gfc_full_array_ref_p (gfc_ref *ref)
+gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
 {
   int i;
+  bool lbound_OK = true;
+  bool ubound_OK = true;
 
   if (ref->type != REF_ARRAY)
     return false;
@@ -1209,6 +1213,10 @@ gfc_full_array_ref_p (gfc_ref *ref)
 	 the correct element.  */
       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
 	{
+	  /* This is a contiguous reference.  */
+	  if (contiguous)
+	    *contiguous = (i + 1 == ref->u.ar.dimen);
+
 	  if (!ref->u.ar.as
 	      || !ref->u.ar.as->lower[i]
 	      || !ref->u.ar.as->upper[i]
@@ -1228,17 +1236,24 @@ gfc_full_array_ref_p (gfc_ref *ref)
 	      || !ref->u.ar.as->lower[i]
 	      || gfc_dep_compare_expr (ref->u.ar.start[i],
 				       ref->u.ar.as->lower[i])))
-	return false;
+	lbound_OK = false;
       /* Check the upper bound.  */
       if (ref->u.ar.end[i]
 	  && (!ref->u.ar.as
 	      || !ref->u.ar.as->upper[i]
 	      || gfc_dep_compare_expr (ref->u.ar.end[i],
 				       ref->u.ar.as->upper[i])))
-	return false;
+	ubound_OK = false;
       /* Check the stride.  */
       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
 	return false;
+
+      /* This is a contiguous reference.  */
+      if (contiguous)
+	*contiguous = (i + 1 == ref->u.ar.dimen);
+
+      if (!lbound_OK || !ubound_OK)
+	return false;
     }
   return true;
 }
@@ -1356,11 +1371,11 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
 	  if (lref->u.ar.dimen != rref->u.ar.dimen)
 	    {
 	      if (lref->u.ar.type == AR_FULL)
-		fin_dep = gfc_full_array_ref_p (rref) ? GFC_DEP_EQUAL
-						      : GFC_DEP_OVERLAP;
+		fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
+							    : GFC_DEP_OVERLAP;
 	      else if (rref->u.ar.type == AR_FULL)
-		fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL
-						      : GFC_DEP_OVERLAP;
+		fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
+							    : GFC_DEP_OVERLAP;
 	      else
 		return 1;
 	      break;
diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h
index 1920c55..6fa0416 100644
--- a/gcc/fortran/dependency.h
+++ b/gcc/fortran/dependency.h
@@ -33,7 +33,7 @@ gfc_dep_check;
 /*********************** Functions prototypes **************************/
 
 bool gfc_ref_needs_temporary_p (gfc_ref *);
-bool gfc_full_array_ref_p (gfc_ref *);
+bool gfc_full_array_ref_p (gfc_ref *, bool *);
 gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *);
 int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
 				 gfc_actual_arglist *, gfc_dep_check);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index cf38fc3..ce9114f 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5008,7 +5008,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       else if (se->direct_byref)
 	full = 0;
       else
-	full = gfc_full_array_ref_p (info->ref);
+	full = gfc_full_array_ref_p (info->ref, NULL);
 
       if (full)
 	{
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f79ad4b..6a38f10 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4300,6 +4300,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *ss;
   gfc_ref * ref;
   bool seen_array_ref;
+  bool c = false;
   gfc_component *comp = NULL;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
@@ -4311,6 +4312,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
       && expr2->value.function.esym->attr.elemental)
     return NULL;
 
+  /* Fail if rhs is not FULL or a contiguous section.  */
+  if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
+    return NULL;
+
   /* Fail if EXPR1 can't be expressed as a descriptor.  */
   if (gfc_ref_needs_temporary_p (expr1->ref))
     return NULL;
@@ -4785,7 +4790,7 @@ copyable_array_p (gfc_expr * expr)
   if (expr->rank < 1 || !expr->ref || expr->ref->next)
     return false;
 
-  if (!gfc_full_array_ref_p (expr->ref))
+  if (!gfc_full_array_ref_p (expr->ref, NULL))
     return false;
 
   /* Next check that it's of a simple enough type.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d325d4a..d8ed7cb 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-06-29  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40551
+	* gfortran.dg/func_assign_2.f90 : New test.
+
 2009-06-29  Richard Guenther  <rguenther@suse.de>
 
 	PR middle-end/14187
diff --git a/gcc/testsuite/gfortran.dg/func_assign_2.f90 b/gcc/testsuite/gfortran.dg/func_assign_2.f90
new file mode 100644
index 0000000..e308375
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/func_assign_2.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+! Test the fix for PR40551 in which the assignment
+! was not dealing correctly with non-contiguous lhs
+! references; eg. a(1,:)
+!
+! Reported by by Maciej Zwierzycki
+! at http://gcc.gnu.org/ml/fortran/2009-06/msg00254.html
+! and by Tobias Burnus <burnus@gcc.gnu.org> on Bugzilla
+!
+integer :: a(2,2)
+a = -42
+a(1,:) = func()
+if (any (reshape (a, [4]) /= [1, -42, 2, -42])) call abort 
+a = -42
+a(2,:) = func()
+if (any (reshape (a, [4]) /= [-42, 1, -42, 2])) call abort 
+a = -42
+a(:,1) = func()
+if (any (reshape (a, [4]) /= [1, 2, -42, -42])) call abort 
+a = -42
+a(:,2) = func()
+if (any (reshape (a, [4]) /= [-42, -42, 1, 2])) call abort 
+contains
+ function func()
+   integer :: func(2)
+   call sub(func)
+ end function func
+ subroutine sub(a)
+   integer :: a(2)
+   a = [1,2]
+ end subroutine
+end
+