Skip to content

R
riscv-gcc-1
Commit 5a0193ee by Paul Thomas
Options

re PR fortran/37836 (ICE in gfc_trans_auto_array_allocation) 

2008-11-09  Paul Thomas  <pault@gcc.gnu.org>

        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  <pault@gcc.gnu.org>

        PR fortran/37836
        * gfortran.dg/minmaxval_1.f90: New test.

From-SVN: r141717
parent 82d3b03a
Showing with 175 additions and 55 deletions
gcc/fortran/ChangeLog
2008-11-09 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
PR fortran/37597
......
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);
......
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 *);
......
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)
{
......
gcc/testsuite/ChangeLog
2008-11-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/37836
* gfortran.dg/minmaxval_1.f90: New test.
2008-11-09 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/loop_boolean.adb: New test.
......
gcc/testsuite/gfortran.dg/minmaxval_1.f90 0 → 100644
! { 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 <burnus@gcc.gnu.org>
!
! 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment