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

gcc/fortran/ChangeLog

+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.

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;
 }

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 *,

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)

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 *);

gcc/testsuite/ChangeLog

+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.

gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90

+! 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