aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/data.cc161
-rw-r--r--gcc/fortran/data.h4
-rw-r--r--gcc/fortran/resolve.cc5
-rw-r--r--gcc/testsuite/gfortran.dg/data_vector_section.f9026
4 files changed, 134 insertions, 62 deletions
diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc
index d29eb12..7c2537d 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 40dbee1..8f2013a 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 f51674f..ce8261d 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 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
generated by cgit v1.1 at 2025-05-22 07:13:39 +0000