re PR fortran/66128 (ICE for some intrinsics with zero sized array parameter)

2018-03-03  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/66128
	* simplify.c (is_size_zero_array): New function to check for size
	zero array.
	(gfc_simplify_all, gfc_simplify_any, gfc_simplify_count, 
	 gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity,
	 gfc_simplify_minval, gfc_simplify_maxval, gfc_simplify_norm2,
	 gfc_simplify_product, gfc_simplify_sum): Use it, and implement
	requirements from F2018.

2018-03-03  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/66128
	* gfortran.dg/zero_sized_8.f90: New test.

From-SVN: r258223

1 files changed, 180 insertions, 0 deletions

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index b130aba..3bd9868 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -258,6 +258,29 @@ is_constant_array_expr (gfc_expr *e)
   return true;
 }
 
+/* Test for a size zero array.  */
+static bool
+is_size_zero_array (gfc_expr *array)
+{
+  gfc_expr *e;
+  bool t;
+
+  e = gfc_copy_expr (array);
+  gfc_simplify_expr (e, 1);
+
+  if (e->expr_type == EXPR_CONSTANT && e->rank > 0 && !e->shape)
+     t = true;
+  else if (e->expr_type == EXPR_ARRAY && e->rank > 0 
+	   && !e->shape && !e->value.constructor)
+     t = true;
+  else
+     t = false;
+
+  gfc_free_expr (e);
+
+  return t;
+}
+
 
 /* Initialize a transformational result expression with a given value.  */
 
@@ -951,6 +974,9 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 gfc_expr *
 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 {
+  if (is_size_zero_array (mask))
+    return gfc_get_logical_expr (mask->ts.kind, &mask->where, true);
+
   return simplify_transformation (mask, dim, NULL, true, gfc_and);
 }
 
@@ -1040,6 +1066,9 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 gfc_expr *
 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
 {
+  if (is_size_zero_array (mask))
+    return gfc_get_logical_expr (mask->ts.kind, &mask->where, false);
+
   return simplify_transformation (mask, dim, NULL, false, gfc_or);
 }
 
@@ -1936,6 +1965,13 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 {
   gfc_expr *result;
 
+  if (is_size_zero_array (mask))
+    {
+      int k;
+      k = kind ? mpz_get_si (kind->value.integer) : gfc_default_integer_kind;
+      return gfc_get_int_expr (k, NULL, 0);
+    }
+
   if (!is_constant_array_expr (mask)
       || !gfc_is_constant_expr (dim)
       || !gfc_is_constant_expr (kind))
@@ -3227,6 +3263,9 @@ do_bit_and (gfc_expr *result, gfc_expr *e)
 gfc_expr *
 gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    return gfc_get_int_expr (array->ts.kind, NULL, -1);
+
   return simplify_transformation (array, dim, mask, -1, do_bit_and);
 }
 
@@ -3246,6 +3285,9 @@ do_bit_ior (gfc_expr *result, gfc_expr *e)
 gfc_expr *
 gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    return gfc_get_int_expr (array->ts.kind, NULL, 0);
+
   return simplify_transformation (array, dim, mask, 0, do_bit_ior);
 }
 
@@ -3686,6 +3728,9 @@ do_bit_xor (gfc_expr *result, gfc_expr *e)
 gfc_expr *
 gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    return gfc_get_int_expr (array->ts.kind, NULL, 0);
+
   return simplify_transformation (array, dim, mask, 0, do_bit_xor);
 }
 
@@ -4993,6 +5038,43 @@ gfc_min (gfc_expr *op1, gfc_expr *op2)
 gfc_expr *
 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    {
+      gfc_expr *result;
+      int i;
+
+      i = gfc_validate_kind (array->ts.type, array->ts.kind, false);
+      result = gfc_get_constant_expr (array->ts.type, array->ts.kind,
+				      &array->where);
+      switch (array->ts.type)
+	{
+	  case BT_INTEGER:
+	    mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
+	    break;
+
+	  case BT_REAL:
+	    mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+	    break;
+
+	  case BT_CHARACTER:
+	    /* If ARRAY has size zero and type character, the result has the
+	       value of a string of characters of length LEN (ARRAY), with
+	       each character equal to CHAR(n - 1, KIND (ARRAY)), where n is
+	       the number of characters in the collating sequence for
+	       characters with the kind type parameter of ARRAY.  */
+	    gfc_error ("MINVAL(string) at %L is not implemented, yet!",
+			&array->where);
+	    gfc_free_expr (result);
+	    return &gfc_bad_expr;
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+    	}
+
+      return result;
+    }
+
   return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
 }
 
@@ -5012,6 +5094,42 @@ gfc_max (gfc_expr *op1, gfc_expr *op2)
 gfc_expr *
 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    {
+      gfc_expr *result;
+      int i;
+
+      i = gfc_validate_kind (array->ts.type, array->ts.kind, false);
+      result = gfc_get_constant_expr (array->ts.type, array->ts.kind,
+				      &array->where);
+      switch (array->ts.type)
+	{
+	  case BT_INTEGER:
+	    mpz_set (result->value.integer, gfc_integer_kinds[i].min_int);
+	    break;
+
+	  case BT_REAL:
+	    mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+	    mpfr_neg (result->value.real, result->value.real,  GFC_RND_MODE);
+	    break;
+
+	  case BT_CHARACTER:
+	    /* If ARRAY has size zero and type character, the result has the
+               value of a string of characters of length LEN (ARRAY), with
+               each character equal to CHAR (0, KIND (ARRAY)).  */
+	    gfc_error ("MAXVAL(string) at %L is not implemented, yet!",
+			&array->where);
+	    gfc_free_expr (result);
+	    return &gfc_bad_expr;
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+    	}
+
+      return result;
+    }
+
   return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
 }
 
@@ -5658,6 +5776,14 @@ gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
 {
   gfc_expr *result;
 
+  if (is_size_zero_array (e))
+    {
+      gfc_expr *result;
+      result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+      return result;
+    }
+
   if (!is_constant_array_expr (e)
       || (dim != NULL && !gfc_is_constant_expr (dim)))
     return NULL;
@@ -5914,6 +6040,33 @@ gfc_simplify_precision (gfc_expr *e)
 gfc_expr *
 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    {
+      gfc_expr *result;
+
+      result = gfc_get_constant_expr (array->ts.type, array->ts.kind,
+				      &array->where);
+      switch (array->ts.type)
+	{
+	  case BT_INTEGER:
+	    mpz_set_ui (result->value.integer, 1);
+	    break;
+
+	  case BT_REAL:
+	    mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+	    break;
+
+	  case BT_COMPLEX:
+	    mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+    	}
+
+      return result;
+    }
+
   return simplify_transformation (array, dim, mask, 1, gfc_multiply);
 }
 
@@ -7231,6 +7384,33 @@ gfc_simplify_sqrt (gfc_expr *e)
 gfc_expr *
 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
+  if (is_size_zero_array (array))
+    {
+      gfc_expr *result;
+
+      result = gfc_get_constant_expr (array->ts.type, array->ts.kind,
+				      &array->where);
+      switch (array->ts.type)
+	{
+	  case BT_INTEGER:
+	    mpz_set_ui (result->value.integer, 0);
+	    break;
+
+	  case BT_REAL:
+	    mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+	    break;
+
+	  case BT_COMPLEX:
+	    mpc_set_ui (result->value.complex, 0, GFC_MPC_RND_MODE);
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+    	}
+
+      return result;
+    }
+
   return simplify_transformation (array, dim, mask, 0, gfc_add);
 }