re PR fortran/66578 ([F2008] Invalid free on allocate(...,source=a(:)) in block)

gcc/testsuite/ChangeLog:

2015-07-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/66578
	* gfortran.dg/allocate_with_source_9.f08: New test.

gcc/fortran/ChangeLog:

2015-07-07  Mikael Morin  <mikael@gcc.gnu.org>
	    Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/66578
	* trans-array.c (gfc_conv_expr_descriptor): Ensure array descriptor
	is one-based for non-full array refs. Correct the offset when a
	rank_remap occurs.

From-SVN: r225507

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a3a37db8e202501ba41e6d1a9cbefcabaed1ae0d..75bce2f6e53e17962928965c4d19d3d271e3193f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2015-07-07  Andre Vehreschild  <vehre@gmx.de>
+
+       PR fortran/66578
+       * trans-array.c (gfc_conv_expr_descriptor): Ensure array descriptor
+       is one-based for non-full array refs. Correct the offset when a
+       rank_remap occurs.
+
 2015-07-06  Steven G. Kargl  <kargl@gcc.gnu.org>
 
        * io.c (check_char_variable): New function.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index fece3abd2ef1abc12910f638239a434dd26e8102..afea5eca7d0f971fdc344fb108a0e7d6cca77572 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6912,9 +6912,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       tree from;
       tree to;
       tree base;
-      bool onebased = false;
+      bool onebased = false, rank_remap;
 
       ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
+      rank_remap = ss->dimen < ndim;
 
       if (se->want_coarray)
        {
@@ -6947,6 +6948,22 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       if (expr->ts.type == BT_CHARACTER)
        se->string_length =  gfc_get_expr_charlen (expr);
 
+      /* If we have an array section or are assigning make sure that
+        the lower bound is 1.  References to the full
+        array should otherwise keep the original bounds.  */
+      if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
+       for (dim = 0; dim < loop.dimen; dim++)
+         if (!integer_onep (loop.from[dim]))
+           {
+             tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                    gfc_array_index_type, gfc_index_one_node,
+                                    loop.from[dim]);
+             loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
+                                             gfc_array_index_type,
+                                             loop.to[dim], tmp);
+             loop.from[dim] = gfc_index_one_node;
+           }
+
       desc = info->descriptor;
       if (se->direct_byref && !se->byref_noassign)
        {
@@ -7040,20 +7057,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
          from = loop.from[dim];
          to = loop.to[dim];
 
-         /* If we have an array section or are assigning make sure that
-            the lower bound is 1.  References to the full
-            array should otherwise keep the original bounds.  */
-         if ((!info->ref
-                 || info->ref->u.ar.type != AR_FULL)
-             && !integer_onep (from))
-           {
-             tmp = fold_build2_loc (input_location, MINUS_EXPR,
-                                    gfc_array_index_type, gfc_index_one_node,
-                                    from);
-             to = fold_build2_loc (input_location, PLUS_EXPR,
-                                   gfc_array_index_type, to, tmp);
-             from = gfc_index_one_node;
-           }
          onebased = integer_onep (from);
          gfc_conv_descriptor_lbound_set (&loop.pre, parm,
                                          gfc_rank_cst[dim], from);
@@ -7079,7 +7082,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
            {
              tmp = gfc_conv_array_lbound (desc, n);
              tmp = fold_build2_loc (input_location, MINUS_EXPR,
-                                    TREE_TYPE (base), tmp, loop.from[dim]);
+                                    TREE_TYPE (base), tmp, from);
              tmp = fold_build2_loc (input_location, MULT_EXPR,
                                     TREE_TYPE (base), tmp,
                                     gfc_conv_array_stride (desc, n));
@@ -7114,7 +7117,19 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       /* Force the offset to be -1, when the lower bound of the highest
         dimension is one and the symbol is present and is not a
         pointer/allocatable or associated.  */
-      if (onebased && se->use_offset
+      if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+          && !se->data_not_needed)
+         || (se->use_offset && base != NULL_TREE))
+       {
+         /* Set the offset depending on base.  */
+         tmp = rank_remap && !se->direct_byref ?
+               fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, base,
+                                offset)
+             : base;
+         gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
+       }
+      else if (onebased && (!rank_remap || se->use_offset)
          && expr->symtree
          && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
               && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
@@ -7129,11 +7144,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
          tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
          gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
        }
-      else if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
-               && !se->data_not_needed)
-              || (se->use_offset && base != NULL_TREE))
-       /* Set the offset depending on base.  */
-       gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
       else
        {
          /* Only the callee knows what the correct offset it, so just set

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a398b6f467f541c1aa343ae58fbd6871ba918d67..631872176ff31a059894923cc24533b7c889cb7b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-07-07  Andre Vehreschild  <vehre@gmx.de>
+
+       PR fortran/66578
+       * gfortran.dg/allocate_with_source_9.f08: New test.
+
 2015-07-07  Christian Bruel  <christian.bruel@st.com>
 
        PR target/52144

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_9.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_9.f08
new file mode 100644 (file)
index 0000000..aa7cb47
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_9.f08
@@ -0,0 +1,29 @@
+! { dg-do run }
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>,
+!                Andre Vehreschild  <vehre@gcc.gnu.org>
+
+program main
+
+  type T
+     integer, allocatable :: acc(:)
+  end type
+
+  integer :: n, lb, ub
+  integer :: vec(9)
+  type(T) :: o1, o2
+  vec = [(i, i= 1, 9)]
+  n = 42
+  lb = 7
+  ub = lb + 2
+  allocate(o1%acc, source=vec)
+  allocate(o2%acc, source=o1%acc(lb:ub))
+  if (any (o2%acc /= [7, 8, 9])) call abort()
+  block
+    real, dimension(0:n) :: a
+    real, dimension(:), allocatable :: c
+    call random_number(a)
+    allocate(c,source=a(:))
+    if (any (abs(a - c) > 1E-6)) call abort()
+  end block
+end program main