From 96cc0333cdaa8459ef516ae8e74158cdb6302853 Mon Sep 17 00:00:00 2001 From: Harald Anlauf 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 . */ 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