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, 36 insertions, 46 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 9a82d889371..aff024a5874 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1135,20 +1135,50 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
 }
 
 
+/* Similar to minloc/maxloc, the argument list might need to be
+   reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
+   difference is that MINLOC/MAXLOC take an additional KIND argument.
+   The possibilities are:
+
+         Arg #2     Arg #3
+         NULL       NULL
+         DIM        NULL
+         MASK       NULL
+         NULL       MASK             minval(array, mask=m)
+         DIM        MASK
+
+   I.e. in the case of minval(array,mask), mask will be in the second
+   position of the argument list and we'll have to fix that up.  */
+
 try
-gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
+gfc_check_reduction (gfc_actual_arglist * ap)
 {
+  gfc_expr *a, *m, *d;
 
-  if (array_check (array, 0) == FAILURE)
+  a = ap->expr;
+  if (int_or_real_check (a, 0) == FAILURE
+      || array_check (a, 0) == FAILURE)
     return FAILURE;
 
-  if (int_or_real_check (array, 0) == FAILURE)
-    return FAILURE;
+  d = ap->next->expr;
+  m = ap->next->next->expr;
 
-  if (dim_check (dim, 1, 1) == FAILURE)
+  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+      && ap->next->name[0] == '\0')
+    {
+      m = d;
+      d = NULL;
+
+      ap->next->expr = NULL;
+      ap->next->next->expr = m;
+    }
+
+  if (d != NULL
+      && (scalar_check (d, 1) == FAILURE
+      || type_check (d, 1, BT_INTEGER) == FAILURE))
     return FAILURE;
 
-  if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
+  if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -1277,26 +1307,6 @@ gfc_check_present (gfc_expr * a)
 
 
 try
-gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
-{
-
-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
-
-  if (numeric_check (array, 0) == FAILURE)
-    return FAILURE;
-
-  if (dim_check (dim, 1, 1) == FAILURE)
-    return FAILURE;
-
-  if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
-    return FAILURE;
-
-  return SUCCESS;
-}
-
-
-try
 gfc_check_radix (gfc_expr * x)
 {
 
@@ -1553,26 +1563,6 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
 
 
 try
-gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
-{
-
-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
-
-  if (numeric_check (array, 0) == FAILURE)
-    return FAILURE;
-
-  if (dim_check (dim, 1, 1) == FAILURE)
-    return FAILURE;
-
-  if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
-    return FAILURE;
-
-  return SUCCESS;
-}
-
-
-try
 gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
 		    gfc_expr * mold ATTRIBUTE_UNUSED,
 		    gfc_expr * size)