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 --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index c4ab75b..c0d12cf 100644 (file)
--- 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 (file)
index 0000000..303b2b9
--- /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