[PATCH] PR fortran/66193 - ICE for initialisation of some non-zero-sized arrays

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 704 bytes --]

Dear Fortranners,

some instances of valid constant array constructors did lead to ICEs.
It turned out that on the one hand we need to attempt simplification of
elements of the constructor, especially when we encounter parenthesized
expression.  On the other hand the occurence of type specs and empty
constructors need to be handled more gracefully.

Parts of the PR have been fixed previously, so the remaining part was
rather simple.

The testcase is based on Gerhards latest example attached to the PR.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Given the simplicity of the patch and that it is an ICE on valid code,
would this qualify for later application to 11-branch?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fortran-try-simplifications-during-reductions-of-arr.patch --]
[-- Type: text/x-patch, Size: 5582 bytes --]

From 65966b608cff757f43316e1aeed37bd07ce63fe2 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sun, 6 Feb 2022 21:47:20 +0100
Subject: [PATCH] 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.
---
 gcc/fortran/arith.cc                          | 36 ++++++++++--
 .../gfortran.dg/array_constructor_55.f90      | 55 +++++++++++++++++++
 2 files changed, 85 insertions(+), 6 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/array_constructor_55.f90

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
--
2.34.1