check.c (gfc_check_reduction): Rename to ...

* check.c (gfc_check_reduction): Rename to ...
(check_reduction): ... this. Make static. Don't check type of
first argument.
(gfc_check_minval_maxval, gfc_check_prodcut_sum): New functions.
* intrinsic.c (add_functions): Change MAXVAL, MINVAL, PRODUCT and
SUM to use new check functions.
(check_specific): Change logic to call new functions.
* intrinsic.h (gfc_check_minval_maxval, gfc_check_product_sum):
Add prototypes.
(gfc_check_reduction): Remove prototype.

From-SVN: r86377

4 files changed, 52 insertions, 15 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fed67a6..d9c4d5f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2004-08-22  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* check.c (gfc_check_reduction): Rename to ...
+	(check_reduction): ... this. Make static. Don't check type of 
+	first argument.
+	(gfc_check_minval_maxval, gfc_check_prodcut_sum): New functions.
+	* intrinsic.c (add_functions): Change MAXVAL, MINVAL, PRODUCT and
+	SUM to use new check functions.
+	(check_specific): Change logic to call new functions.
+	* intrinsic.h (gfc_check_minval_maxval, gfc_check_product_sum):
+	Add prototypes.
+	(gfc_check_reduction): Remove prototype.
+
 2004-08-20  Paul Brook  <paul@codesourcery.com>
 	Canqun Yang  <canqun@nudt.edu.cn>
 
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index aff024a..9e5906a 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1150,15 +1150,10 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
    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_reduction (gfc_actual_arglist * ap)
+static try
+check_reduction (gfc_actual_arglist * ap)
 {
-  gfc_expr *a, *m, *d;
-
-  a = ap->expr;
-  if (int_or_real_check (a, 0) == FAILURE
-      || array_check (a, 0) == FAILURE)
-    return FAILURE;
+  gfc_expr *m, *d;
 
   d = ap->next->expr;
   m = ap->next->next->expr;
@@ -1186,6 +1181,30 @@ gfc_check_reduction (gfc_actual_arglist * ap)
 
 
 try
+gfc_check_minval_maxval (gfc_actual_arglist * ap)
+{
+  
+  if (int_or_real_check (ap->expr, 0) == FAILURE
+      || array_check (ap->expr, 0) == FAILURE)
+    return FAILURE;
+  
+  return check_reduction (ap);
+}
+
+
+try
+gfc_check_product_sum (gfc_actual_arglist * ap)
+{
+  
+  if (numeric_check (ap->expr, 0) == FAILURE
+      || array_check (ap->expr, 0) == FAILURE)
+    return FAILURE;
+  
+  return check_reduction (ap);
+}
+
+
+try
 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
 {
 
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 00cdecf..2784a7a 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1406,7 +1406,7 @@ add_functions (void)
   make_generic ("maxloc", GFC_ISYM_MAXLOC);
 
   add_sym_3red ("maxval", 0, 1, BT_REAL, dr,
-                gfc_check_reduction, NULL, gfc_resolve_maxval,
+                gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
                 msk, BT_LOGICAL, dl, 1);
 
@@ -1461,7 +1461,7 @@ add_functions (void)
   make_generic ("minloc", GFC_ISYM_MINLOC);
 
   add_sym_3red ("minval", 0, 1, BT_REAL, dr,
-                gfc_check_reduction, NULL, gfc_resolve_minval,
+                gfc_check_minval_maxval, NULL, gfc_resolve_minval,
                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
                 msk, BT_LOGICAL, dl, 1);
 
@@ -1534,7 +1534,7 @@ add_functions (void)
   make_generic ("present", GFC_ISYM_PRESENT);
 
   add_sym_3red ("product", 0, 1, BT_REAL, dr,
-                gfc_check_reduction, NULL, gfc_resolve_product,
+                gfc_check_product_sum, NULL, gfc_resolve_product,
                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
                 msk, BT_LOGICAL, dl, 1);
 
@@ -1716,7 +1716,7 @@ add_functions (void)
   make_generic ("sqrt", GFC_ISYM_SQRT);
 
   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0,
-                gfc_check_reduction, NULL, gfc_resolve_sum,
+                gfc_check_product_sum, NULL, gfc_resolve_sum,
                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
                 msk, BT_LOGICAL, dl, 1);
 
@@ -2493,10 +2493,14 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
     /* 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)
+  else if (specific->check.f3red == gfc_check_minval_maxval)
     /* This is also special because we also might have to reorder the
        argument list.  */
-    t = gfc_check_reduction (*ap);
+    t = gfc_check_minval_maxval (*ap);
+  else if (specific->check.f3red == gfc_check_product_sum)
+    /* Same here. The difference to the previous case is that we allow a
+       general numeric type.  */
+    t = gfc_check_product_sum (*ap);
   else
      {
        if (specific->check.f1 == NULL)
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 0eeeaf9..d09bcd0 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -70,16 +70,17 @@ try gfc_check_min_max_double (gfc_actual_arglist *);
 try gfc_check_matmul (gfc_expr *, gfc_expr *);
 try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_minloc_maxloc (gfc_actual_arglist *);
+try gfc_check_minval_maxval (gfc_actual_arglist *);
 try gfc_check_nearest (gfc_expr *, gfc_expr *);
 try gfc_check_null (gfc_expr *);
 try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_precision (gfc_expr *);
 try gfc_check_present (gfc_expr *);
+try gfc_check_product_sum (gfc_actual_arglist *);
 try gfc_check_radix (gfc_expr *);
 try gfc_check_rand (gfc_expr *);
 try gfc_check_range (gfc_expr *);
 try gfc_check_real (gfc_expr *, gfc_expr *);
-try gfc_check_reduction (gfc_actual_arglist *);
 try gfc_check_repeat (gfc_expr *, gfc_expr *);
 try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_scale (gfc_expr *, gfc_expr *);