re PR fortran/14928 (minloc intrinsic does not understand mask)

fortran/
2004-06-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
        Andrew Vaught <andyv@firstinter.net>

PR fortran/14928
* gfortran.h (gfc_check_f): Add new field f3ml.
* check.c (gfc_check_minloc_maxloc): Take argument list instead
of individual arguments, reorder if necessary.
* intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
* intrinsic.c (add_sym_3ml): New function.
(add_functions): Change to add_sym_3ml for MINLOC, MAXLOC.
(check_specific): Catch special case MINLOC, MAXLOC.

testsuite/
PR fortran/14928
* gfortran.fortran-torture/compile/mloc.f90: New test.

Co-Authored-By: Andrew Vaught <andyv@firstinter.net>
From-SVN: r83111

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0cacdfc11d380e4344bf078555fb88cd1e56121d..72a0678b5e78fea4b27376f29f19b6e79bbc1047 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2004-06-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+        Andrew Vaught <andyv@firstinter.net>
+
+       PR fortran/14928
+       * gfortran.h (gfc_check_f): Add new field f3ml.
+       * check.c (gfc_check_minloc_maxloc): Take argument list instead
+       of individual arguments, reorder if necessary.
+       * intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
+       * intrinsic.c (add_sym_3ml): New function.
+       (add_functions): Change to add_sym_3ml for MINLOC, MAXLOC.
+       (check_specific): Catch special case MINLOC, MAXLOC. 
+
 2004-06-14  Paul Brook  <paul@codesourcery.com>
 
        * intrinsic.c (add_sym_2s): Use correct function types.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index cbf3d9dba7ab8e74c755459355e41b0b046ec4ce..9a82d88937111faa855f2112da989c6d61017046 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1096,53 +1096,40 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
          MASK       NULL
          NULL       MASK             minloc(array, mask=m)
          DIM        MASK
-*/
+
+   I.e. in the case of minloc(array,mask), mask will be in the second
+   position of the argument list and we'll have to fix that up.  */
 
 try
-gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
+gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
 {
+  gfc_expr *a, *m, *d;
 
-  if (int_or_real_check (array, 0) == FAILURE)
+  a = ap->expr;
+  if (int_or_real_check (a, 0) == FAILURE
+      || array_check (a, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
+  d = ap->next->expr;
+  m = ap->next->next->expr;
 
-  if (a3 != NULL)
+  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+      && ap->next->name[0] == '\0')
     {
-      if (logical_array_check (a3, 2) == FAILURE)
-       return FAILURE;
+      m = d;
+      d = NULL;
 
-      if (a2 != NULL)
-       {
-         if (scalar_check (a2, 1) == FAILURE)
-           return FAILURE;
-         if (type_check (a2, 1, BT_INTEGER) == FAILURE)
-           return FAILURE;
-       }
+      ap->next->expr = NULL;
+      ap->next->next->expr = m;
     }
-  else
-    {
-      if (a2 != NULL)
-       {
-         switch (a2->ts.type)
-           {
-           case BT_INTEGER:
-             if (scalar_check (a2, 1) == FAILURE)
-               return FAILURE;
-             break;
 
-           case BT_LOGICAL:    /* The '2' makes the error message correct */
-             if (logical_array_check (a2, 2) == FAILURE)
-               return FAILURE;
-             break;
+  if (d != NULL
+      && (scalar_check (d, 1) == FAILURE
+      || type_check (d, 1, BT_INTEGER) == FAILURE))
+    return FAILURE;
 
-           default:
-             type_check (a2, 1, BT_INTEGER);   /* Guaranteed to fail */
-             return FAILURE;
-           }
-       }
-    }
+  if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a533b1c348e4c3c37c7f82daad8f2b3ed8834860..d9107dd32cd458bab62f1cf95fc77140d813d182 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -821,6 +821,7 @@ typedef union
   try (*f1m)(gfc_actual_arglist *);
   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 (*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 bf72947e03c679c3cbf6abf05f41ddaaa5015939..04443d92ae1b47bf8beae76330745d238bd3e4ef 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -479,6 +479,33 @@ static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
           (void*)0);
 }
 
+/* MINLOC and MAXLOC get special treatment because their argument
+   might have to be reordered.  */
+
+static void add_sym_3ml (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.f3ml = 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. */
 
@@ -1281,10 +1308,10 @@ add_functions (void)
 
   make_generic ("maxexponent", GFC_ISYM_NONE);
 
-  add_sym_3 ("maxloc", 0, 1, BT_INTEGER, di,
-            gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
-            ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-            msk, BT_LOGICAL, dl, 1);
+  add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di,
+              gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
+              ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+              msk, BT_LOGICAL, dl, 1);
 
   make_generic ("maxloc", GFC_ISYM_MAXLOC);
 
@@ -1336,10 +1363,10 @@ add_functions (void)
 
   make_generic ("minexponent", GFC_ISYM_NONE);
 
-  add_sym_3 ("minloc", 0, 1, BT_INTEGER, di,
-            gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
-            ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
-            msk, BT_LOGICAL, dl, 1);
+  add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di,
+              gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
+              ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
+              msk, BT_LOGICAL, dl, 1);
 
   make_generic ("minloc", GFC_ISYM_MINLOC);
 
@@ -2331,14 +2358,21 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
                   &expr->where) == FAILURE)
     return FAILURE;
 
-  if (specific->check.f1 == NULL)
-    {
-      t = check_arglist (ap, specific, error_flag);
-      if (t == SUCCESS)
-       expr->ts = specific->ts;
-    }
+  if (specific->check.f3ml != gfc_check_minloc_maxloc)
+     {
+       if (specific->check.f1 == NULL)
+        {
+          t = check_arglist (ap, specific, error_flag);
+          if (t == SUCCESS)
+            expr->ts = specific->ts;
+        }
+       else
+        t = do_check (specific, *ap);
+     }
   else
-    t = do_check (specific, *ap);
+    /* 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 ab261431f06e45ea5994f0d5b172fd1899605a44..c345abc8eaa05245c6bfc5a13992af41817ed3f8 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -69,7 +69,7 @@ try gfc_check_min_max_real (gfc_actual_arglist *);
 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_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 *);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 86926967b0fde529b6292e36203e4456323dc081..02da20e350993d9a15eaf51f99278c11e0ba9aba 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2004-06-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       PR fortran/14928
+       * gfortran.fortran-torture/compile/mloc.f90: New test.
+       
 2004-06-13  Paul Brook  <paul@codesourcery.com>
 
        * gfortran.fortran-torture/execute/random_2.f90: New test.

diff --git a/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 b/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90
new file mode 100644 (file)
index 0000000..8d1d754
--- /dev/null
+++ b/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90
@@ -0,0 +1,8 @@
+! from PR 14928
+! we used to not accept the two argument variant of MINLOC and MAXLOC when
+! the MASK keyword was omitted.
+  real b(10)
+  integer c(1)
+  c = minloc(b,b<0)
+  c = maxloc(b,b>0)
+end