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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149062 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3357fde..976a448 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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
+