From 94e6b5e5a65e83b71a1a3f736dd7e0e9f460af9c Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sat, 3 Mar 2018 19:49:20 +0000 Subject: [PATCH] re PR fortran/66128 (ICE for some intrinsics with zero sized array parameter) 2018-03-03 Steven G. Kargl 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 PR fortran/66128 * gfortran.dg/zero_sized_8.f90: New test. From-SVN: r258223 --- gcc/fortran/ChangeLog | 11 +++ gcc/fortran/simplify.c | 180 ++++++++++++++++++++++++++++++++++++++++ gcc/testsuite/ChangeLog | 5 ++ 3 files changed, 196 insertions(+) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c04a552344c..eb64c7452f1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2018-03-03 Steven G. Kargl + + 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 PR fortran/51434 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index b130abacc52..3bd98688e88 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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2460b06280c..1df6a18f4e0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-03-03 Steven G. Kargl + + PR fortran/66128 + * gfortran.dg/zero_sized_8.f90: New test. + 2018-03-03 Steven G. Kargl PR fortran/51434 -- 2.30.2