[gcc r12-7153] Fortran: try simplifications during reductions of array constructors

[gcc r12-7153] Fortran: try simplifications during reductions of array constructors

[Harald Anlauf]

https://gcc.gnu.org/g:f3ffea93ef31c03ad8cdcb54e71ec868b57b264f

commit r12-7153-gf3ffea93ef31c03ad8cdcb54e71ec868b57b264f
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Sun Feb 6 21:47:20 2022 +0100

    Fortran: try simplifications during reductions of array constructors
    
    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.

Diff:
---
 gcc/fortran/arith.cc                               | 36 +++++++++++---
 gcc/testsuite/gfortran.dg/array_constructor_55.f90 | 55 ++++++++++++++++++++++
 2 files changed, 85 insertions(+), 6 deletions(-)

diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index b3323ecf640..06e032e22db 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -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;
diff --git a/gcc/testsuite/gfortran.dg/array_constructor_55.f90 b/gcc/testsuite/gfortran.dg/array_constructor_55.f90
new file mode 100644
index 00000000000..52142cb10c0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_constructor_55.f90
@@ -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