[gcc r13-4545] Fortran: handle zero-sized arrays in ctors with typespec [PR108010]

[gcc r13-4545] Fortran: handle zero-sized arrays in ctors with typespec [PR108010]

[Harald Anlauf]

https://gcc.gnu.org/g:7d6512d102a5a4fb3939de95bce38d154512a19f

commit r13-4545-g7d6512d102a5a4fb3939de95bce38d154512a19f
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Wed Dec 7 21:50:23 2022 +0100

    Fortran: handle zero-sized arrays in ctors with typespec [PR108010]
    
    gcc/fortran/ChangeLog:
    
            PR fortran/108010
            * arith.cc (reduce_unary): Handle zero-sized arrays.
            (reduce_binary_aa): Likewise.
    
    gcc/testsuite/ChangeLog:
    
            PR fortran/108010
            * gfortran.dg/pr108010.f90: New test.

Diff:
---
 gcc/fortran/arith.cc                   | 24 ++++++++++++---
 gcc/testsuite/gfortran.dg/pr108010.f90 | 54 ++++++++++++++++++++++++++++++++++
 2 files changed, 74 insertions(+), 4 deletions(-)

diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index c4ab75b401c..c0d12cfad9d 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -1342,8 +1342,16 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
   else
     {
       gfc_constructor *c = gfc_constructor_first (head);
-      r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
-			      &op->where);
+      if (c == NULL)
+	{
+	  /* Handle zero-sized arrays.  */
+	  r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where);
+	}
+      else
+	{
+	  r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+				  &op->where);
+	}
       r->shape = gfc_copy_shape (op->shape, op->rank);
       r->rank = op->rank;
       r->value.constructor = head;
@@ -1501,8 +1509,16 @@ reduce_binary_aa (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);
+      if (c == NULL)
+	{
+	  /* Handle zero-sized arrays.  */
+	  r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
+	}
+      else
+	{
+	  r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+				  &op1->where);
+	}
       r->shape = gfc_copy_shape (op1->shape, op1->rank);
       r->rank = op1->rank;
       r->value.constructor = head;
diff --git a/gcc/testsuite/gfortran.dg/pr108010.f90 b/gcc/testsuite/gfortran.dg/pr108010.f90
new file mode 100644
index 00000000000..303b2b98220
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr108010.f90
@@ -0,0 +1,54 @@
+! { dg-do run }
+! PR fortran/108010 - ICE in reduce_unary, reduce_binary_aa
+! Contributed by G.Steinmetz
+
+program p
+  implicit none
+  print *,   + [integer :: [real ::]]
+  print *,   - [integer :: [real ::]]
+  print *, 1 + [integer :: [real ::]]
+  print *, 1 - [integer :: [real ::]]
+  print *, 2 * [integer :: [real ::]]
+  print *,   - [real :: [real ::], 2]
+  print *,   + [integer :: [real ::], 2]
+  print *,   - [integer :: [real ::], 2]
+  print *, 1 + [integer :: [real ::], 2]
+  print *, 1 - [integer :: [real ::], 2]
+  print *, 2 * [integer :: [real ::], 2]
+  print *, [integer :: [real ::]] + [integer :: [real ::]]
+  print *, [integer :: [real ::]] - [integer :: [real ::]]
+  print *, [integer :: [real ::]] * [integer :: [real ::]]
+  print *, [integer :: [real ::], 2] + [real :: [real ::], 3]
+  print *, [integer :: [real ::], 2] - [real :: [real ::], 3]
+  print *, [integer :: [real ::], 2] * [real :: [real ::], 3]
+
+  ! Validate type of resulting arrays
+  if (.not. is_int ([integer :: [real ::]]                         )) stop 1
+  if (.not. is_int ([integer :: [real ::]] + [integer :: [real ::]])) stop 2
+  if (.not. is_real([real :: [integer ::]]                         )) stop 3
+  if (.not. is_real([real :: [integer ::]] + [real :: [integer ::]])) stop 4
+  if (.not. is_real([real :: [integer ::]] + [integer :: [real ::]])) stop 5
+  if (.not. is_real([integer :: [real ::]] + [real :: [integer ::]])) stop 6
+
+contains
+
+  logical function is_int (x)
+    class(*) :: x(:)
+    select type (x)
+    type is (integer)
+       is_int = .true.
+    class default
+       is_int = .false.
+    end select
+  end function is_int
+    
+  logical function is_real (x)
+    class(*) :: x(:)
+    select type (x)
+    type is (real)
+       is_real = .true.
+    class default
+       is_real = .false.
+    end select
+  end function is_real
+end