re PR fortran/16946 (sum (array, mask) is not accepted)

fortran/
PR fortran/16946
* check.c (gfc_check_reduction): New function.
(gfc_check_minval_maxval): Removed.
(gfc_check_product): Removed.
(gfc_check_sum): Removed.
* intrinsic.h: Add/remove declarations for these.
* gfortran.h: Add field f3red to union gfc_check_f.
* intrinsic.c (add_sym_3red): New function.
(add_functions): Register maxval, minval, product, and sum intrinsics
through add_sym_3red.
(check_specific): Handle f3red union field.
* iresolve.c: Whitespace change.

testsuite/
PR fortran/16946
* gfortran.dg/reduction.f90: New testcase.

From-SVN: r86255

1 files changed, 52 insertions, 21 deletions

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 14014a0..00cdecf 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -506,6 +506,33 @@ static void add_sym_3ml (const char *name, int elemental,
 	   (void*)0);
 }
 
+/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
+   their argument also might have to be reordered.  */
+
+static void add_sym_3red (const char *name, int elemental, 
+                          int actual_ok, bt type, int kind,
+                          try (*check)(gfc_actual_arglist *),
+                          gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
+                          void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
+                          const char* a1, bt type1, int kind1, int optional1,
+                          const char* a2, bt type2, int kind2, int optional2,
+                          const char* a3, bt type3, int kind3, int optional3
+                          ) {
+  gfc_check_f cf;
+  gfc_simplify_f sf;
+  gfc_resolve_f rf;
+
+  cf.f3red = check;
+  sf.f3 = simplify;
+  rf.f3 = resolve;
+
+  add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
+	   a1, type1, kind1, optional1,
+	   a2, type2, kind2, optional2,
+	   a3, type3, kind3, optional3,
+	   (void*)0);
+}
+
 /* Add the name of an intrinsic subroutine with three arguments to the list
    of intrinsic names. */
 
@@ -1378,10 +1405,10 @@ add_functions (void)
 
   make_generic ("maxloc", GFC_ISYM_MAXLOC);
 
-  add_sym_3 ("maxval", 0, 1, BT_REAL, dr,
-	     gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
-	     ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-	     msk, BT_LOGICAL, dl, 1);
+  add_sym_3red ("maxval", 0, 1, BT_REAL, dr,
+                gfc_check_reduction, NULL, gfc_resolve_maxval,
+                ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+                msk, BT_LOGICAL, dl, 1);
 
   make_generic ("maxval", GFC_ISYM_MAXVAL);
 
@@ -1433,10 +1460,10 @@ add_functions (void)
 
   make_generic ("minloc", GFC_ISYM_MINLOC);
 
-  add_sym_3 ("minval", 0, 1, BT_REAL, dr,
-	     gfc_check_minval_maxval, NULL, gfc_resolve_minval,
-	     ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-	     msk, BT_LOGICAL, dl, 1);
+  add_sym_3red ("minval", 0, 1, BT_REAL, dr,
+                gfc_check_reduction, NULL, gfc_resolve_minval,
+                ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+                msk, BT_LOGICAL, dl, 1);
 
   make_generic ("minval", GFC_ISYM_MINVAL);
 
@@ -1506,10 +1533,10 @@ add_functions (void)
 
   make_generic ("present", GFC_ISYM_PRESENT);
 
-  add_sym_3 ("product", 0, 1, BT_REAL, dr,
-	     gfc_check_product, NULL, gfc_resolve_product,
-	     ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-	     msk, BT_LOGICAL, dl, 1);
+  add_sym_3red ("product", 0, 1, BT_REAL, dr,
+                gfc_check_reduction, NULL, gfc_resolve_product,
+                ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+                msk, BT_LOGICAL, dl, 1);
 
   make_generic ("product", GFC_ISYM_PRODUCT);
 
@@ -1688,10 +1715,10 @@ add_functions (void)
 
   make_generic ("sqrt", GFC_ISYM_SQRT);
 
-  add_sym_3 ("sum", 0, 1, BT_UNKNOWN, 0,
-	     gfc_check_sum, NULL, gfc_resolve_sum,
-	     ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-	     msk, BT_LOGICAL, dl, 1);
+  add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0,
+                gfc_check_reduction, NULL, gfc_resolve_sum,
+                ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+                msk, BT_LOGICAL, dl, 1);
 
   make_generic ("sum", GFC_ISYM_SUM);
 
@@ -2462,7 +2489,15 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
 		   &expr->where) == FAILURE)
     return FAILURE;
 
-  if (specific->check.f3ml != gfc_check_minloc_maxloc)
+  if (specific->check.f3ml == gfc_check_minloc_maxloc)
+    /* This is special because we might have to reorder the argument
+       list.  */
+    t = gfc_check_minloc_maxloc (*ap);
+  else if (specific->check.f3red == gfc_check_reduction)
+    /* This is also special because we also might have to reorder the
+       argument list.  */
+    t = gfc_check_reduction (*ap);
+  else
      {
        if (specific->check.f1 == NULL)
 	 {
@@ -2473,10 +2508,6 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
        else
 	 t = do_check (specific, *ap);
      }
-  else
-    /* This is special because we might have to reorder the argument
-       list.  */
-    t = gfc_check_minloc_maxloc (*ap);
 
   /* Check ranks for elemental intrinsics.  */
   if (t == SUCCESS && specific->elemental)