[PATCH] Fortran: implement vector sections in DATA statements [PR49588]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 591 bytes --]

Dear all,

the attached patch implements vector sections in DATA statements.

The implementation is simpler than the size of the patch suggests,
as part of changes try to clean up the existing code to make it
easier to understand, as ordinary sections (start:end:stride)
and vector sections may actually share some common code.

The basisc idea of the implementation is that one needs a
temporary vector that keeps track of the offsets into the
array constructors for the indices in the array reference
that are vectors.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr49588.diff --]
[-- Type: text/x-patch, Size: 10336 bytes --]

From 96cc0333cdaa8459ef516ae8e74158cdb6302853 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 21 Aug 2023 21:23:57 +0200
Subject: [PATCH] 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.
---
 gcc/fortran/data.cc                           | 161 +++++++++++-------
 gcc/fortran/data.h                            |   4 +-
 gcc/fortran/resolve.cc                        |   5 +-
 .../gfortran.dg/data_vector_section.f90       |  26 +++
 4 files changed, 134 insertions(+), 62 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/data_vector_section.f90

diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc
index d29eb12c1b1..7c2537dd3f0 100644
--- 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 40dbee1ef28..8f2013ac894 100644
--- 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 f51674f7faa..ce8261d646a 100644
--- 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
index 00000000000..3e099de99d0
--- /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
--
2.35.3