Skip to content

Commit d3b5a1b

Browse files
harald-anlaufharald-anlauf
committed
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.
1 parent c27f062 commit d3b5a1b

File tree

4 files changed

+134
-62
lines changed

4 files changed

+134
-62
lines changed

‎gcc/fortran/data.cc‎

Lines changed: 103 additions & 58 deletions
Original file line numberDiff line numberDiff line change
@@ -634,65 +634,102 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
634634

635635
void
636636
gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
637-
mpz_t *offset_ret)
637+
mpz_t *offset_ret, int *vector_offset)
638638
{
639639
int i;
640640
mpz_t delta;
641641
mpz_t tmp;
642642
bool forwards;
643643
int cmp;
644-
gfc_expr *start, *end, *stride;
644+
gfc_expr *start, *end, *stride, *elem;
645+
gfc_constructor_base base;
645646

646647
for (i = 0; i < ar->dimen; i++)
647648
{
648-
if (ar->dimen_type[i] != DIMEN_RANGE)
649-
continue;
649+
bool advance = false;
650650

651-
if (ar->stride[i])
651+
switch (ar->dimen_type[i])
652652
{
653-
stride = gfc_copy_expr(ar->stride[i]);
654-
if(!gfc_simplify_expr(stride, 1))
655-
gfc_internal_error("Simplification error");
656-
mpz_add (section_index[i], section_index[i],
657-
stride->value.integer);
658-
if (mpz_cmp_si (stride->value.integer, 0) >= 0)
659-
forwards = true;
653+
case DIMEN_ELEMENT:
654+
/* Loop to advance the next index. */
655+
advance = true;
656+
break;
657+
658+
case DIMEN_RANGE:
659+
if (ar->stride[i])
660+
{
661+
stride = gfc_copy_expr(ar->stride[i]);
662+
if(!gfc_simplify_expr(stride, 1))
663+
gfc_internal_error("Simplification error");
664+
mpz_add (section_index[i], section_index[i],
665+
stride->value.integer);
666+
if (mpz_cmp_si (stride->value.integer, 0) >= 0)
667+
forwards = true;
668+
else
669+
forwards = false;
670+
gfc_free_expr(stride);
671+
}
660672
else
661-
forwards = false;
662-
gfc_free_expr(stride);
663-
}
664-
else
665-
{
666-
mpz_add_ui (section_index[i], section_index[i], 1);
667-
forwards = true;
668-
}
673+
{
674+
mpz_add_ui (section_index[i], section_index[i], 1);
675+
forwards = true;
676+
}
669677

670-
if (ar->end[i])
671-
{
672-
end = gfc_copy_expr(ar->end[i]);
673-
if(!gfc_simplify_expr(end, 1))
674-
gfc_internal_error("Simplification error");
675-
cmp = mpz_cmp (section_index[i], end->value.integer);
676-
gfc_free_expr(end);
677-
}
678-
else
679-
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
678+
if (ar->end[i])
679+
{
680+
end = gfc_copy_expr(ar->end[i]);
681+
if(!gfc_simplify_expr(end, 1))
682+
gfc_internal_error("Simplification error");
683+
cmp = mpz_cmp (section_index[i], end->value.integer);
684+
gfc_free_expr(end);
685+
}
686+
else
687+
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
680688

681-
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
682-
{
683-
/* Reset index to start, then loop to advance the next index. */
684-
if (ar->start[i])
689+
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
685690
{
686-
start = gfc_copy_expr(ar->start[i]);
687-
if(!gfc_simplify_expr(start, 1))
688-
gfc_internal_error("Simplification error");
691+
/* Reset index to start, then loop to advance the next index. */
692+
if (ar->start[i])
693+
{
694+
start = gfc_copy_expr(ar->start[i]);
695+
if(!gfc_simplify_expr(start, 1))
696+
gfc_internal_error("Simplification error");
697+
mpz_set (section_index[i], start->value.integer);
698+
gfc_free_expr(start);
699+
}
700+
else
701+
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
702+
advance = true;
703+
}
704+
break;
705+
706+
case DIMEN_VECTOR:
707+
vector_offset[i]++;
708+
base = ar->start[i]->value.constructor;
709+
elem = gfc_constructor_lookup_expr (base, vector_offset[i]);
710+
711+
if (elem == NULL)
712+
{
713+
/* Reset to first vector element and advance the next index. */
714+
vector_offset[i] = 0;
715+
elem = gfc_constructor_lookup_expr (base, 0);
716+
advance = true;
717+
}
718+
if (elem)
719+
{
720+
start = gfc_copy_expr (elem);
721+
if (!gfc_simplify_expr (start, 1))
722+
gfc_internal_error ("Simplification error");
689723
mpz_set (section_index[i], start->value.integer);
690-
gfc_free_expr(start);
724+
gfc_free_expr (start);
691725
}
692-
else
693-
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
726+
break;
727+
728+
default:
729+
gcc_unreachable ();
694730
}
695-
else
731+
732+
if (!advance)
696733
break;
697734
}
698735

@@ -793,12 +830,14 @@ gfc_formalize_init_value (gfc_symbol *sym)
793830
offset. */
794831

795832
void
796-
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
833+
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset,
834+
int *vector_offset)
797835
{
798836
int i;
799837
mpz_t delta;
800838
mpz_t tmp;
801-
gfc_expr *start;
839+
gfc_expr *start, *elem;
840+
gfc_constructor_base base;
802841

803842
mpz_set_si (*offset, 0);
804843
mpz_init (tmp);
@@ -810,29 +849,35 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
810849
{
811850
case DIMEN_ELEMENT:
812851
case DIMEN_RANGE:
813-
if (ar->start[i])
814-
{
815-
start = gfc_copy_expr(ar->start[i]);
816-
if(!gfc_simplify_expr(start, 1))
817-
gfc_internal_error("Simplification error");
818-
mpz_sub (tmp, start->value.integer,
819-
ar->as->lower[i]->value.integer);
820-
mpz_mul (tmp, tmp, delta);
821-
mpz_add (*offset, tmp, *offset);
822-
mpz_set (section_index[i], start->value.integer);
823-
gfc_free_expr(start);
824-
}
825-
else
826-
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
852+
elem = ar->start[i];
827853
break;
828854

829855
case DIMEN_VECTOR:
830-
gfc_internal_error ("TODO: Vector sections in data statements");
856+
vector_offset[i] = 0;
857+
base = ar->start[i]->value.constructor;
858+
elem = gfc_constructor_lookup_expr (base, vector_offset[i]);
859+
break;
831860

832861
default:
833862
gcc_unreachable ();
834863
}
835864

865+
if (elem)
866+
{
867+
start = gfc_copy_expr (elem);
868+
if (!gfc_simplify_expr (start, 1))
869+
gfc_internal_error ("Simplification error");
870+
mpz_sub (tmp, start->value.integer,
871+
ar->as->lower[i]->value.integer);
872+
mpz_mul (tmp, tmp, delta);
873+
mpz_add (*offset, tmp, *offset);
874+
mpz_set (section_index[i], start->value.integer);
875+
gfc_free_expr (start);
876+
}
877+
else
878+
/* Fallback for empty section or constructor. */
879+
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
880+
836881
mpz_sub (tmp, ar->as->upper[i]->value.integer,
837882
ar->as->lower[i]->value.integer);
838883
mpz_add_ui (tmp, tmp, 1);

‎gcc/fortran/data.h‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,6 @@ along with GCC; see the file COPYING3. If not see
1818
<http://www.gnu.org/licenses/>. */
1919

2020
void gfc_formalize_init_value (gfc_symbol *);
21-
void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
21+
void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *, int *);
2222
bool gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t, mpz_t *);
23-
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
23+
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *, int *);

‎gcc/fortran/resolve.cc‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -16765,6 +16765,7 @@ check_data_variable (gfc_data_variable *var, locus *where)
1676516765
ar_type mark = AR_UNKNOWN;
1676616766
int i;
1676716767
mpz_t section_index[GFC_MAX_DIMENSIONS];
16768+
int vector_offset[GFC_MAX_DIMENSIONS];
1676816769
gfc_ref *ref;
1676916770
gfc_array_ref *ar;
1677016771
gfc_symbol *sym;
@@ -16888,7 +16889,7 @@ check_data_variable (gfc_data_variable *var, locus *where)
1688816889
case AR_SECTION:
1688916890
ar = &ref->u.ar;
1689016891
/* Get the start position of array section. */
16891-
gfc_get_section_index (ar, section_index, &offset);
16892+
gfc_get_section_index (ar, section_index, &offset, vector_offset);
1689216893
mark = AR_SECTION;
1689316894
break;
1689416895

@@ -16971,7 +16972,7 @@ check_data_variable (gfc_data_variable *var, locus *where)
1697116972
/* Modify the array section indexes and recalculate the offset
1697216973
for next element. */
1697316974
else if (mark == AR_SECTION)
16974-
gfc_advance_section (section_index, ar, &offset);
16975+
gfc_advance_section (section_index, ar, &offset, vector_offset);
1697516976
}
1697616977
}
1697716978

‎gcc/testsuite/gfortran.dg/data_vector_section.f90‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
! { dg-do run }
2+
! PR fortran/49588 - vector sections in data statements
3+
4+
block data
5+
implicit none
6+
integer :: a(8), b(3,2), i
7+
data a(::2) /4*1/
8+
data a([2,6]) /2*2/
9+
data a([4]) /3/
10+
data a([(6+2*i,i=1,1)]) /1*5/
11+
data b( 1 ,[1,2]) /11,12/
12+
data b([2,3],[2,1]) /22,32,21,31/
13+
common /com/ a, b
14+
end block data
15+
16+
program test
17+
implicit none
18+
integer :: a(8), b(3,2), i, j
19+
common /com/ a, b
20+
print *, a
21+
print *, b
22+
! print *, a - [1,2,1,3,1,2,1,5]
23+
! print *, ((b(i,j)-(10*i+j),i=1,3),j=1,2)
24+
if (.not. all (a == [1,2,1,3,1,2,1,5])) stop 1
25+
if (.not. all (b == reshape ([((10*i+j,i=1,3),j=1,2)], shape (b)))) stop 2
26+
end program test

0 commit comments

Comments
 (0)