mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-27 13:54:19 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran: try simplifications during reductions of array constructors

Browse Source 
gcc/fortran/ChangeLog:

	PR fortran/66193
	* arith.cc (reduce_binary_ac): When reducing binary expressions,
	try simplification.  Handle case of empty constructor.
	(reduce_binary_ca): Likewise.

gcc/testsuite/ChangeLog:

	PR fortran/66193
	* gfortran.dg/array_constructor_55.f90: New test.
This commit is contained in:
Harald Anlauf 2022-02-06 21:47:20 +01:00
parent f6ff6738fa
commit f3ffea93ef
2 changed files with 85 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
gcc/fortran/arith.cc
View File

@ -1305,6 +1305,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
head = gfc_constructor_copy (op1->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
gfc_simplify_expr (c->expr, 0);
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (c->expr, op2, &r);
else
@ -1321,9 +1323,19 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
else
{
gfc_constructor *c = gfc_constructor_first (head);
r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
&op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
if (c)
{
r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
&op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
}
else
{
gcc_assert (op1->ts.type != BT_UNKNOWN);
r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
&op1->where);
r->shape = gfc_get_shape (op1->rank);
}
r->rank = op1->rank;
r->value.constructor = head;
*result = r;
@ -1345,6 +1357,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
head = gfc_constructor_copy (op2->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
gfc_simplify_expr (c->expr, 0);
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (op1, c->expr, &r);
else
@ -1361,9 +1375,19 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
else
{
gfc_constructor *c = gfc_constructor_first (head);
r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
&op2->where);
r->shape = gfc_copy_shape (op2->shape, op2->rank);
if (c)
{
r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
&op2->where);
r->shape = gfc_copy_shape (op2->shape, op2->rank);
}
else
{
gcc_assert (op2->ts.type != BT_UNKNOWN);
r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
&op2->where);
r->shape = gfc_get_shape (op2->rank);
}
r->rank = op2->rank;
r->value.constructor = head;
*result = r;

55
gcc/testsuite/gfortran.dg/array_constructor_55.f90 Normal file
View File

@ -0,0 +1,55 @@
! { dg-do run }
! PR fortran/66193 - ICE for initialisation of some non-zero-sized arrays
! Testcase by G.Steinmetz
program p
implicit none
call s1
call s2
call s3
call s4
contains
subroutine s1
integer(8), parameter :: z1(2) = 10 + [ integer(8) :: [ integer(4) ::],1,2]
integer(8) :: z2(2) = 10 + [ integer(8) :: [ integer(4) ::],1,2]
integer(8) :: z3(2)
z3 = 10 + [ integer(8) :: [ integer(4) :: ], 1, 2 ]
if ( z1(1) /= 11 .or. z1(2) /= 12 ) stop 1
if ( z2(1) /= 11 .or. z2(2) /= 12 ) stop 2
if ( z3(1) /= 11 .or. z3(2) /= 12 ) stop 3
end subroutine s1
subroutine s2
logical(8), parameter :: z1(3) = .true. .or. &
[ logical(8) :: [ logical(4) :: ], .false., .false., .true. ]
logical(8) :: z2(3) = .true. .or. &
[ logical(8) :: [ logical(4) :: ], .false., .false., .true. ]
logical(8) :: z3(3)
z3 = .true. .or. &
[ logical(8) :: [ logical(4) :: ], .false., .false., .true. ]
if ( .not. all(z1) ) stop 11
if ( .not. all(z2) ) stop 12
if ( .not. all(z3) ) stop 13
end subroutine s2
subroutine s3
real(8), parameter :: eps = 4.0_8 * epsilon(1.0_8)
real(8), parameter :: z1(2) = 10. + [ real(8) :: [ real(4) :: ], 1., 2. ]
real(8) :: z2(2) = 10. + [ real(8) :: [ real(4) :: ], 1., 2. ]
real(8) :: z3(2)
z3 = 10.0 + [ real(8) :: [ real(4) :: ], 1.0, 2.0 ]
if ( abs(1-z1(1)/11) > eps ) stop 21
if ( abs(1-z1(2)/12) > eps ) stop 22
if ( abs(1-z2(1)/11) > eps ) stop 23
if ( abs(1-z2(2)/12) > eps ) stop 24
if ( abs(1-z3(1)/11) > eps ) stop 25
if ( abs(1-z3(2)/12) > eps ) stop 26
end subroutine s3
subroutine s4
real, parameter :: x(3) = 2.0 * [real :: 1, (2), 3]
real, parameter :: y(2) = [real :: 1, (2)] + 10.0
real, parameter :: z(2) = [real ::(1),(2)] + 10.0
end subroutine s4
end program p