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
@@ -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);
@@ -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 *);
@@ -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);
}
}
new file mode 100644
@@ -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