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.
This commit is contained in:
Harald Anlauf
parent
c27f06260b
commit
d3b5a1bccc
4 changed files with 136 additions and 64 deletions
|
|
@ -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;
|
||||
else
|
||||
forwards = false;
|
||||
gfc_free_expr(stride);
|
||||
}
|
||||
else
|
||||
{
|
||||
mpz_add_ui (section_index[i], section_index[i], 1);
|
||||
forwards = true;
|
||||
}
|
||||
case DIMEN_ELEMENT:
|
||||
/* Loop to advance the next index. */
|
||||
advance = true;
|
||||
break;
|
||||
|
||||
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])
|
||||
case DIMEN_RANGE:
|
||||
if (ar->stride[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);
|
||||
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
|
||||
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
|
||||
{
|
||||
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 ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
|
||||
{
|
||||
/* 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);
|
||||
}
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
26
gcc/testsuite/gfortran.dg/data_vector_section.f90
Normal file
26
gcc/testsuite/gfortran.dg/data_vector_section.f90
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Reference in a new issue