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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 9a82d88937111faa855f2112da989c6d61017046..aff024a5874f709e04526957c09d44eccd93f20c 100644 (file)
--- 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;
@@ -1276,26 +1306,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)
 {
@@ -1552,26 +1562,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,

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 45851610e38d476d8bae67b52467f7e9d1994555..2839b4a995eb80086c1f6a3fc10ae2b24b5442b0 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -923,6 +923,7 @@ typedef union
   try (*f2)(struct gfc_expr *, struct gfc_expr *);
   try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
   try (*f3ml)(gfc_actual_arglist *);
+  try (*f3red)(gfc_actual_arglist *);
   try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
            struct gfc_expr *);
   try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 14014a007a6237e242ecd5b63c18267672660890..00cdecf87da1d27239ea873f0a4f6e626102ccc8 100644 (file)
--- 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)

diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 3a50d05b8c56447f737d6eb9ca28a1c00983df3a..0eeeaf96e852970d4e610722cad04591061cedd5 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -70,17 +70,16 @@ 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_expr *, gfc_expr *, gfc_expr *);
 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 (gfc_expr *, gfc_expr *, gfc_expr *);
 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 *);

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 21fd0150c0b84d182587a4ecebcdfd5a2f931b3b..bfa51c4ea7cd8fb3552a5976be9db11d52c6b030 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -882,6 +882,7 @@ gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
                     gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
+
 void
 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
                    gfc_expr * mask)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b3e70dc964a3152d5ffe9329a275653c9551efcf..6ec5172ba1d31f60d9b27bb1d186858246bf2b06 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2004-08-19  Erik Schnetter  <schnetter@aei.mpg.de>
+
+       PR fortran/16946
+       * gfortran.dg/reduction.f90: New testcase.
+
 2004-08-19  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
        PR fortran/16520

diff --git a/gcc/testsuite/gfortran.dg/reduction.f90 b/gcc/testsuite/gfortran.dg/reduction.f90
new file mode 100644 (file)
index 0000000..f98eb29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduction.f90
@@ -0,0 +1,58 @@
+! { dg-do run }
+! PR 16946
+! Not all allowed combinations of arguments for MAXVAL, MINVAL,
+! PRODUCT and SUM were supported.
+program reduction_mask
+  implicit none
+  logical :: equal(3)
+  
+  integer, parameter :: res(4*9) = (/ 3, 3, 3, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, &
+       1, 1, 1, 1, 1, 6, 6, 6, 2, 2, 2, 2, 2, 2, 6, 6, 6, 3, 3, 3, 3, 3, 3 /)
+  integer :: val(4*9)
+  
+  equal = (/ .true., .true., .false. /)
+  
+  ! use all combinations of the dim and mask arguments for the
+  ! reduction intrinsics
+  val( 1) = maxval((/ 1, 2, 3 /))
+  val( 2) = maxval((/ 1, 2, 3 /), 1)
+  val( 3) = maxval((/ 1, 2, 3 /), dim=1)
+  val( 4) = maxval((/ 1, 2, 3 /), equal)
+  val( 5) = maxval((/ 1, 2, 3 /), mask=equal)
+  val( 6) = maxval((/ 1, 2, 3 /), 1, equal)
+  val( 7) = maxval((/ 1, 2, 3 /), 1, mask=equal)
+  val( 8) = maxval((/ 1, 2, 3 /), dim=1, mask=equal)
+  val( 9) = maxval((/ 1, 2, 3 /), mask=equal, dim=1)
+       
+  val(10) = minval((/ 1, 2, 3 /))
+  val(11) = minval((/ 1, 2, 3 /), 1)
+  val(12) = minval((/ 1, 2, 3 /), dim=1)
+  val(13) = minval((/ 1, 2, 3 /), equal)
+  val(14) = minval((/ 1, 2, 3 /), mask=equal)
+  val(15) = minval((/ 1, 2, 3 /), 1, equal)
+  val(16) = minval((/ 1, 2, 3 /), 1, mask=equal)
+  val(17) = minval((/ 1, 2, 3 /), dim=1, mask=equal)
+  val(18) = minval((/ 1, 2, 3 /), mask=equal, dim=1)
+       
+  val(19) = product((/ 1, 2, 3 /))
+  val(20) = product((/ 1, 2, 3 /), 1)
+  val(21) = product((/ 1, 2, 3 /), dim=1)
+  val(22) = product((/ 1, 2, 3 /), equal)
+  val(23) = product((/ 1, 2, 3 /), mask=equal)
+  val(24) = product((/ 1, 2, 3 /), 1, equal)
+  val(25) = product((/ 1, 2, 3 /), 1, mask=equal)
+  val(26) = product((/ 1, 2, 3 /), dim=1, mask=equal)
+  val(27) = product((/ 1, 2, 3 /), mask=equal, dim=1)
+       
+  val(28) = sum((/ 1, 2, 3 /))
+  val(29) = sum((/ 1, 2, 3 /), 1)
+  val(30) = sum((/ 1, 2, 3 /), dim=1)
+  val(31) = sum((/ 1, 2, 3 /), equal)
+  val(32) = sum((/ 1, 2, 3 /), mask=equal)
+  val(33) = sum((/ 1, 2, 3 /), 1, equal)
+  val(34) = sum((/ 1, 2, 3 /), 1, mask=equal)
+  val(35) = sum((/ 1, 2, 3 /), dim=1, mask=equal)
+  val(36) = sum((/ 1, 2, 3 /), mask=equal, dim=1)
+  
+  if (any (val /= res)) call abort
+end program reduction_mask