From 98d24b31def0c55874715c90e5c48c6c5aaab988 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 9 Nov 2008 17:40:30 +0000 Subject: [PATCH] 2008-11-09 Paul Thomas PR fortran/37836 * intrinsic.c (add_functions): Reference gfc_simplify._minval and gfc_simplify_maxval. * intrinsic.h : Add prototypes for gfc_simplify._minval and gfc_simplify_maxval. * simplify.c (min_max_choose): New function extracted from simplify_min_max. (simplify_min_max): Call it. (simplify_minval_maxval, gfc_simplify_minval, gfc_simplify_maxval): New functions. 2008-11-09 Paul Thomas PR fortran/37836 * gfortran.dg/minmaxval_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@141717 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 13 +++ gcc/fortran/intrinsic.c | 4 +- gcc/fortran/intrinsic.h | 2 + gcc/fortran/simplify.c | 177 +++++++++++++++++++++--------- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/minmaxval_1.f90 | 29 +++++ 6 files changed, 175 insertions(+), 55 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/minmaxval_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c5abefa..efa4678 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2008-11-09 Paul Thomas + + PR fortran/37836 + * intrinsic.c (add_functions): Reference gfc_simplify._minval + and gfc_simplify_maxval. + * intrinsic.h : Add prototypes for gfc_simplify._minval and + gfc_simplify_maxval. + * simplify.c (min_max_choose): New function extracted from + simplify_min_max. + (simplify_min_max): Call it. + (simplify_minval_maxval, gfc_simplify_minval, + gfc_simplify_maxval): New functions. + 2008-11-04 Paul Thomas PR fortran/37597 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 1864785..f5bfcf9 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1957,7 +1957,7 @@ add_functions (void) make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_minval_maxval, NULL, gfc_resolve_maxval, + gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL); @@ -2023,7 +2023,7 @@ add_functions (void) make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_minval_maxval, NULL, gfc_resolve_minval, + gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 02eff46..0e0bd3a 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -271,7 +271,9 @@ gfc_expr *gfc_simplify_log (gfc_expr *); gfc_expr *gfc_simplify_log10 (gfc_expr *); gfc_expr *gfc_simplify_logical (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_min (gfc_expr *); +gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*); gfc_expr *gfc_simplify_max (gfc_expr *); +gfc_expr *gfc_simplify_maxval (gfc_expr *, gfc_expr*, gfc_expr*); gfc_expr *gfc_simplify_maxexponent (gfc_expr *); gfc_expr *gfc_simplify_minexponent (gfc_expr *); gfc_expr *gfc_simplify_mod (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 49a4aff..34105bc 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2619,6 +2619,66 @@ gfc_simplify_logical (gfc_expr *e, gfc_expr *k) } +/* Selects bewteen current value and extremum for simplify_min_max + and simplify_minval_maxval. */ +static void +min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) +{ + switch (arg->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (arg->value.integer, + extremum->value.integer) * sign > 0) + mpz_set (extremum->value.integer, arg->value.integer); + break; + + case BT_REAL: + /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ + if (sign > 0) + mpfr_max (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + else + mpfr_min (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + break; + + case BT_CHARACTER: +#define LENGTH(x) ((x)->value.character.length) +#define STRING(x) ((x)->value.character.string) + if (LENGTH(extremum) < LENGTH(arg)) + { + gfc_char_t *tmp = STRING(extremum); + + STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); + memcpy (STRING(extremum), tmp, + LENGTH(extremum) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', + LENGTH(arg) - LENGTH(extremum)); + STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ + LENGTH(extremum) = LENGTH(arg); + gfc_free (tmp); + } + + if (gfc_compare_string (arg, extremum) * sign > 0) + { + gfc_free (STRING(extremum)); + STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); + memcpy (STRING(extremum), STRING(arg), + LENGTH(arg) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', + LENGTH(extremum) - LENGTH(arg)); + STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ + } +#undef LENGTH +#undef STRING + break; + + default: + gfc_internal_error ("simplify_min_max(): Bad type in arglist"); + } +} + + /* This function is special since MAX() can take any number of arguments. The simplified expression is a rewritten version of the argument list containing at most one constant element. Other @@ -2649,59 +2709,7 @@ simplify_min_max (gfc_expr *expr, int sign) continue; } - switch (arg->expr->ts.type) - { - case BT_INTEGER: - if (mpz_cmp (arg->expr->value.integer, - extremum->expr->value.integer) * sign > 0) - mpz_set (extremum->expr->value.integer, arg->expr->value.integer); - break; - - case BT_REAL: - /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ - if (sign > 0) - mpfr_max (extremum->expr->value.real, extremum->expr->value.real, - arg->expr->value.real, GFC_RND_MODE); - else - mpfr_min (extremum->expr->value.real, extremum->expr->value.real, - arg->expr->value.real, GFC_RND_MODE); - break; - - case BT_CHARACTER: -#define LENGTH(x) ((x)->expr->value.character.length) -#define STRING(x) ((x)->expr->value.character.string) - if (LENGTH(extremum) < LENGTH(arg)) - { - gfc_char_t *tmp = STRING(extremum); - - STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); - memcpy (STRING(extremum), tmp, - LENGTH(extremum) * sizeof (gfc_char_t)); - gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', - LENGTH(arg) - LENGTH(extremum)); - STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ - LENGTH(extremum) = LENGTH(arg); - gfc_free (tmp); - } - - if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0) - { - gfc_free (STRING(extremum)); - STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); - memcpy (STRING(extremum), STRING(arg), - LENGTH(arg) * sizeof (gfc_char_t)); - gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', - LENGTH(extremum) - LENGTH(arg)); - STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ - } -#undef LENGTH -#undef STRING - break; - - - default: - gfc_internal_error ("simplify_min_max(): Bad type in arglist"); - } + min_max_choose (arg->expr, extremum->expr, sign); /* Delete the extra constant argument. */ if (last == NULL) @@ -2746,6 +2754,69 @@ gfc_simplify_max (gfc_expr *e) } +/* This is a simplified version of simplify_min_max to provide + simplification of minval and maxval for a vector. */ + +static gfc_expr * +simplify_minval_maxval (gfc_expr *expr, int sign) +{ + gfc_constructor *ctr, *extremum; + gfc_intrinsic_sym * specific; + + extremum = NULL; + specific = expr->value.function.isym; + + ctr = expr->value.constructor; + + for (; ctr; ctr = ctr->next) + { + if (ctr->expr->expr_type != EXPR_CONSTANT) + return NULL; + + if (extremum == NULL) + { + extremum = ctr; + continue; + } + + min_max_choose (ctr->expr, extremum->expr, sign); + } + + if (extremum == NULL) + return NULL; + + /* Convert to the correct type and kind. */ + if (expr->ts.type != BT_UNKNOWN) + return gfc_convert_constant (extremum->expr, + expr->ts.type, expr->ts.kind); + + if (specific->ts.type != BT_UNKNOWN) + return gfc_convert_constant (extremum->expr, + specific->ts.type, specific->ts.kind); + + return gfc_copy_expr (extremum->expr); +} + + +gfc_expr * +gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; + + return simplify_minval_maxval (array, -1); +} + + +gfc_expr * +gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; + return simplify_minval_maxval (array, 1); +} + + gfc_expr * gfc_simplify_maxexponent (gfc_expr *x) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 581dca7..5c1b974 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-11-09 Paul Thomas + + PR fortran/37836 + * gfortran.dg/minmaxval_1.f90: New test. + 2008-11-09 Eric Botcazou * gnat.dg/loop_boolean.adb: New test. diff --git a/gcc/testsuite/gfortran.dg/minmaxval_1.f90 b/gcc/testsuite/gfortran.dg/minmaxval_1.f90 new file mode 100644 index 0000000..bb16d2e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxval_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! Tests the fix for PR37836 in which the specification expressions for +! y were not simplified because there was no simplifier for minval and +! maxval. +! +! Contributed by Tobias Burnus +! +! nint(exp(3.0)) is equal to 20 :-) +! + function fun4a() + integer fun4a + real y(minval([25, nint(exp(3.0)), 15])) + + fun4a = size (y, 1) + end function fun4a + + function fun4b() + integer fun4b + real y(maxval([25, nint(exp(3.0)), 15])) + save + + fun4b = size (y, 1) + end function fun4b + + EXTERNAL fun4a, fun4b + integer fun4a, fun4b + if (fun4a () .ne. 15) call abort + if (fun4b () .ne. 25) call abort + end -- 2.7.4