OSDN Git Service

2008-11-09 Paul Thomas <pault@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 9 Nov 2008 17:40:30 +0000 (17:40 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 9 Nov 2008 17:40:30 +0000 (17:40 +0000)
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@141717 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/simplify.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/minmaxval_1.f90 [new file with mode: 0644]

index c5abefa..efa4678 100644 (file)
@@ -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
index 1864785..f5bfcf9 100644 (file)
@@ -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);
 
index 02eff46..0e0bd3a 100644 (file)
@@ -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 *);
index 49a4aff..34105bc 100644 (file)
@@ -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)
 {
index 581dca7..5c1b974 100644 (file)
@@ -1,3 +1,8 @@
+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.
diff --git a/gcc/testsuite/gfortran.dg/minmaxval_1.f90 b/gcc/testsuite/gfortran.dg/minmaxval_1.f90
new file mode 100644 (file)
index 0000000..bb16d2e
--- /dev/null
@@ -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