This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR37836 - ICE in gfc_trans_auto_array_allocation
- From: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>
- To: "Fortran List" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 9 Nov 2008 07:40:52 +0100
- Subject: [Patch, fortran] PR37836 - ICE in gfc_trans_auto_array_allocation
This patch adds simplifiers for minval and maxval that handle the case
of a single argument, which must be a rank 1 array of constants.
Doubtless more elaborate things could be done but this is more than
sufficient for the present.
This is one of the diminishing band of F95 bugs (PR32834).
Bootstraps and regtests on FC9/x86_i64 - OK for trunk and, after a
decent interval, 4.3?
Paul
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.
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 141655)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -1957,7 +1957,7 @@
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 @@
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);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 141655)
+++ gcc/fortran/trans-array.c (working copy)
@@ -645,13 +645,16 @@
{
n = loop->order[dim];
if (n < loop->temp_dim)
- gcc_assert (integer_zerop (loop->from[n]));
+ gcc_assert (integer_zerop (loop->from[n]));
else
{
/* Callee allocated arrays may not have a known bound yet. */
if (loop->to[n])
- loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[n], loop->from[n]);
+ {
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ loop->to[n], loop->from[n]);
+ loop->to[n] = gfc_evaluate_now (tmp, pre);
+ }
loop->from[n] = gfc_index_zero_node;
}
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h (revision 141655)
+++ gcc/fortran/intrinsic.h (working copy)
@@ -271,7 +271,9 @@
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 *);
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 141655)
+++ gcc/fortran/simplify.c (working copy)
@@ -2619,6 +2619,66 @@
}
+/* 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,60 +2709,8 @@
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;
+ min_max_choose (arg->expr, extremum->expr, sign);
- 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");
- }
-
/* Delete the extra constant argument. */
if (last == NULL)
expr->value.function.actual = arg->next;
@@ -2746,7 +2754,70 @@
}
+/* This is a simplified version of simplify_min_max to provide
+ simplification of minval and maxval for a vactor. */
+
+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)
{
gfc_expr *result;
Index: gcc/testsuite/gfortran.dg/minmaxval_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/minmaxval_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/minmaxval_1.f90 (revision 0)
@@ -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 <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