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

4 files changed, 141 insertions, 55 deletions

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  <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
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)
 {