This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, fortran] PR40551 - Wrong code due to missing copy-in/copy-out stried array to assumed-size dummy


Attached is a fix for the above PR.  This bug has been present in
gfc_trans_arrayfunc_assign forever!  The fix is easy; only feed this
function contiguous left hand sides!

The modification to gfc_full_array_ref_p to flag up contiguous
arguments can be adapted with some work to optimise some other
assignments, although these produce correct code right now.  I'll flag
it up as a job to do.

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

Paul

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.
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c	(revision 149052)
+++ gcc/fortran/dependency.c	(working copy)
@@ -1189,9 +1189,11 @@
    entire array.  */
 
 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 +1211,10 @@
 	 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 +1234,24 @@
 	      || !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 +1369,11 @@
 	  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;
Index: gcc/fortran/dependency.h
===================================================================
--- gcc/fortran/dependency.h	(revision 149052)
+++ gcc/fortran/dependency.h	(working copy)
@@ -33,7 +33,7 @@
 /*********************** 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);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 149052)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -5008,7 +5008,7 @@
       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)
 	{
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 149052)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -4300,6 +4300,7 @@
   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 @@
       && 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 @@
   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.  */
Index: gcc/testsuite/gfortran.dg/func_assign_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/func_assign_2.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/func_assign_2.f90	(revision 0)
@@ -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
+

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]