Fortran: implement vector sections in DATA statements [PR49588]

gcc/fortran/ChangeLog:

	PR fortran/49588
	* data.cc (gfc_advance_section): Derive next index set and next offset
	into DATA variable also for array references using vector sections.
	Use auxiliary array to keep track of offsets into indexing vectors.
	(gfc_get_section_index): Set up initial indices also for DATA variables
	with array references using vector sections.
	* data.h (gfc_get_section_index): Adjust prototype.
	(gfc_advance_section): Likewise.
	* resolve.cc (check_data_variable): Pass vector offsets.

gcc/testsuite/ChangeLog:

	PR fortran/49588
	* gfortran.dg/data_vector_section.f90: New test.

diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc
index d29eb12c1b16a7bc11d7b3ed54c372b4c8e16530..7c2537dd3f0a43eae51e5cf41dd3d90c2abbc2d8 100644 (file)
--- a/gcc/fortran/data.cc
+++ b/gcc/fortran/data.cc
@@ -634,65 +634,102 @@ abort:
 
 void
 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
-                    mpz_t *offset_ret)
+                    mpz_t *offset_ret, int *vector_offset)
 {
   int i;
   mpz_t delta;
   mpz_t tmp;
   bool forwards;
   int cmp;
-  gfc_expr *start, *end, *stride;
+  gfc_expr *start, *end, *stride, *elem;
+  gfc_constructor_base base;
 
   for (i = 0; i < ar->dimen; i++)
     {
-      if (ar->dimen_type[i] != DIMEN_RANGE)
-       continue;
+      bool advance = false;
 
-      if (ar->stride[i])
+      switch (ar->dimen_type[i])
        {
-         stride = gfc_copy_expr(ar->stride[i]);
-         if(!gfc_simplify_expr(stride, 1))
-           gfc_internal_error("Simplification error");
-         mpz_add (section_index[i], section_index[i],
-                  stride->value.integer);
-         if (mpz_cmp_si (stride->value.integer, 0) >= 0)
-           forwards = true;
+       case DIMEN_ELEMENT:
+         /* Loop to advance the next index.  */
+         advance = true;
+         break;
+
+       case DIMEN_RANGE:
+         if (ar->stride[i])
+           {
+             stride = gfc_copy_expr(ar->stride[i]);
+             if(!gfc_simplify_expr(stride, 1))
+               gfc_internal_error("Simplification error");
+             mpz_add (section_index[i], section_index[i],
+                      stride->value.integer);
+             if (mpz_cmp_si (stride->value.integer, 0) >= 0)
+               forwards = true;
+             else
+               forwards = false;
+             gfc_free_expr(stride);
+           }
          else
-           forwards = false;
-         gfc_free_expr(stride);
-       }
-      else
-       {
-         mpz_add_ui (section_index[i], section_index[i], 1);
-         forwards = true;
-       }
+           {
+             mpz_add_ui (section_index[i], section_index[i], 1);
+             forwards = true;
+           }
 
-      if (ar->end[i])
-        {
-         end = gfc_copy_expr(ar->end[i]);
-         if(!gfc_simplify_expr(end, 1))
-           gfc_internal_error("Simplification error");
-         cmp = mpz_cmp (section_index[i], end->value.integer);
-         gfc_free_expr(end);
-       }
-      else
-       cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
+         if (ar->end[i])
+           {
+             end = gfc_copy_expr(ar->end[i]);
+             if(!gfc_simplify_expr(end, 1))
+               gfc_internal_error("Simplification error");
+             cmp = mpz_cmp (section_index[i], end->value.integer);
+             gfc_free_expr(end);
+           }
+         else
+           cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
 
-      if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
-       {
-         /* Reset index to start, then loop to advance the next index.  */
-         if (ar->start[i])
+         if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
            {
-             start = gfc_copy_expr(ar->start[i]);
-             if(!gfc_simplify_expr(start, 1))
-               gfc_internal_error("Simplification error");
+             /* Reset index to start, then loop to advance the next index.  */
+             if (ar->start[i])
+               {
+                 start = gfc_copy_expr(ar->start[i]);
+                 if(!gfc_simplify_expr(start, 1))
+                   gfc_internal_error("Simplification error");
+                 mpz_set (section_index[i], start->value.integer);
+                 gfc_free_expr(start);
+               }
+             else
+               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
+             advance = true;
+           }
+         break;
+
+       case DIMEN_VECTOR:
+         vector_offset[i]++;
+         base = ar->start[i]->value.constructor;
+         elem = gfc_constructor_lookup_expr (base, vector_offset[i]);
+
+         if (elem == NULL)
+           {
+             /* Reset to first vector element and advance the next index.  */
+             vector_offset[i] = 0;
+             elem = gfc_constructor_lookup_expr (base, 0);
+             advance = true;
+           }
+         if (elem)
+           {
+             start = gfc_copy_expr (elem);
+             if (!gfc_simplify_expr (start, 1))
+               gfc_internal_error ("Simplification error");
              mpz_set (section_index[i], start->value.integer);
-             gfc_free_expr(start);
+             gfc_free_expr (start);
            }
-         else
-           mpz_set (section_index[i], ar->as->lower[i]->value.integer);
+         break;
+
+       default:
+         gcc_unreachable ();
        }
-      else
+
+      if (!advance)
        break;
     }
 
@@ -793,12 +830,14 @@ gfc_formalize_init_value (gfc_symbol *sym)
    offset.  */
 
 void
-gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
+gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset,
+                      int *vector_offset)
 {
   int i;
   mpz_t delta;
   mpz_t tmp;
-  gfc_expr *start;
+  gfc_expr *start, *elem;
+  gfc_constructor_base base;
 
   mpz_set_si (*offset, 0);
   mpz_init (tmp);
@@ -810,29 +849,35 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
        {
        case DIMEN_ELEMENT:
        case DIMEN_RANGE:
-         if (ar->start[i])
-           {
-             start = gfc_copy_expr(ar->start[i]);
-             if(!gfc_simplify_expr(start, 1))
-               gfc_internal_error("Simplification error");
-             mpz_sub (tmp, start->value.integer,
-                      ar->as->lower[i]->value.integer);
-             mpz_mul (tmp, tmp, delta);
-             mpz_add (*offset, tmp, *offset);
-             mpz_set (section_index[i], start->value.integer);
-             gfc_free_expr(start);
-           }
-         else
-             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
+         elem = ar->start[i];
          break;
 
        case DIMEN_VECTOR:
-         gfc_internal_error ("TODO: Vector sections in data statements");
+         vector_offset[i] = 0;
+         base = ar->start[i]->value.constructor;
+         elem = gfc_constructor_lookup_expr (base, vector_offset[i]);
+         break;
 
        default:
          gcc_unreachable ();
        }
 
+      if (elem)
+       {
+         start = gfc_copy_expr (elem);
+         if (!gfc_simplify_expr (start, 1))
+           gfc_internal_error ("Simplification error");
+         mpz_sub (tmp, start->value.integer,
+                  ar->as->lower[i]->value.integer);
+         mpz_mul (tmp, tmp, delta);
+         mpz_add (*offset, tmp, *offset);
+         mpz_set (section_index[i], start->value.integer);
+         gfc_free_expr (start);
+       }
+      else
+       /* Fallback for empty section or constructor.  */
+       mpz_set (section_index[i], ar->as->lower[i]->value.integer);
+
       mpz_sub (tmp, ar->as->upper[i]->value.integer,
               ar->as->lower[i]->value.integer);
       mpz_add_ui (tmp, tmp, 1);

diff --git a/gcc/fortran/data.h b/gcc/fortran/data.h
index 40dbee1ef28b13157c4e90d0a4b69298b085a800..8f2013ac8947dd639cc763aac66a20ae4b454909 100644 (file)
--- a/gcc/fortran/data.h
+++ b/gcc/fortran/data.h
@@ -18,6 +18,6 @@ along with GCC; see the file COPYING3.  If not see
 <http://www.gnu.org/licenses/>.  */
 
 void gfc_formalize_init_value (gfc_symbol *);
-void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
+void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *, int *);
 bool gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t, mpz_t *);
-void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
+void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *, int *);

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f51674f7faa5ad04dd3a42ac003c3ac705924733..ce8261d646a961a62c281388753dbee02192fec2 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16765,6 +16765,7 @@ check_data_variable (gfc_data_variable *var, locus *where)
   ar_type mark = AR_UNKNOWN;
   int i;
   mpz_t section_index[GFC_MAX_DIMENSIONS];
+  int vector_offset[GFC_MAX_DIMENSIONS];
   gfc_ref *ref;
   gfc_array_ref *ar;
   gfc_symbol *sym;
@@ -16888,7 +16889,7 @@ check_data_variable (gfc_data_variable *var, locus *where)
        case AR_SECTION:
          ar = &ref->u.ar;
          /* Get the start position of array section.  */
-         gfc_get_section_index (ar, section_index, &offset);
+         gfc_get_section_index (ar, section_index, &offset, vector_offset);
          mark = AR_SECTION;
          break;
 
@@ -16971,7 +16972,7 @@ check_data_variable (gfc_data_variable *var, locus *where)
          /* Modify the array section indexes and recalculate the offset
             for next element.  */
          else if (mark == AR_SECTION)
-           gfc_advance_section (section_index, ar, &offset);
+           gfc_advance_section (section_index, ar, &offset, vector_offset);
        }
     }
 

diff --git a/gcc/testsuite/gfortran.dg/data_vector_section.f90 b/gcc/testsuite/gfortran.dg/data_vector_section.f90
new file mode 100644 (file)
index 0000000..3e099de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_vector_section.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! PR fortran/49588 - vector sections in data statements
+
+block data
+  implicit none
+  integer :: a(8), b(3,2), i
+  data a(::2)   /4*1/
+  data a([2,6]) /2*2/
+  data a([4])   /3/
+  data a([(6+2*i,i=1,1)]) /1*5/
+  data b( 1   ,[1,2]) /11,12/
+  data b([2,3],[2,1]) /22,32,21,31/
+  common /com/ a, b
+end block data
+
+program test
+  implicit none
+  integer :: a(8), b(3,2), i, j
+  common /com/ a, b
+  print *, a
+  print *, b
+! print *, a - [1,2,1,3,1,2,1,5]
+! print *, ((b(i,j)-(10*i+j),i=1,3),j=1,2)
+  if (.not. all (a == [1,2,1,3,1,2,1,5])) stop 1
+  if (.not. all (b == reshape ([((10*i+j,i=1,3),j=1,2)], shape (b)))) stop 2
+end program test