[gfortran] Fix MINLOC and MAXLOC

[Paul Brook <paul at nowt dot org>]

Attached patch fixes a couple of bugs in the MINLOC and MAXLOC intrinsics.

Applied to tree-ssa branch.

Paul

2003-10-17  Feng Wang  <wf_cs@yahoo.com>

	* iresolve.c (gfc_resolve_maxloc): Change the result's kind and type.
	(gfc_resolve_minloc): Ditto.
	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Use correct types.
	Return the value after subtracting the lower bound.
testsuite
	* gfortran.fortran-torture/execute/intrinsics_mmloc_2.f90: New test.

diff -urpxCVS clean/tree-ssa/gcc/fortran/iresolve.c gcc/gcc/fortran/iresolve.c
--- clean/tree-ssa/gcc/fortran/iresolve.c	2003-10-12 22:56:59.000000000 +0100
+++ gcc/gcc/fortran/iresolve.c	2003-10-17 19:13:49.000000000 +0100
@@ -784,7 +784,8 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_ex
 {
   const char *name;
 
-  f->ts = array->ts;
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind ();
 
   if (dim == NULL)
     f->rank = 1;
@@ -797,7 +798,7 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_ex
   name = mask ? "mmaxloc" : "maxloc";
   f->value.function.name =
     gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
-		    gfc_type_letter (array->ts.type), array->ts.kind);
+                    gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
 
@@ -846,7 +847,8 @@ gfc_resolve_minloc (gfc_expr * f, gfc_ex
 {
   const char *name;
 
-  f->ts = array->ts;
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind ();
 
   if (dim == NULL)
     f->rank = 1;
@@ -859,7 +861,7 @@ gfc_resolve_minloc (gfc_expr * f, gfc_ex
   name = mask ? "mminloc" : "minloc";
   f->value.function.name =
     gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
-		    gfc_type_letter (array->ts.type), array->ts.kind);
+                    gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
 void
diff -urpxCVS clean/tree-ssa/gcc/fortran/trans-intrinsic.c gcc/gcc/fortran/trans-intrinsic.c
--- clean/tree-ssa/gcc/fortran/trans-intrinsic.c	2003-10-12 22:56:59.000000000 +0100
+++ gcc/gcc/fortran/trans-intrinsic.c	2003-10-17 19:47:26.000000000 +0100
@@ -1315,29 +1315,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
       return;
     }
 
-  type = gfc_typenode_for_spec (&expr->ts);
   /* Initialize the result.  */
-  limit = gfc_create_var (type, "limit");
   pos = gfc_create_var (gfc_array_index_type, "pos");
-  n = gfc_validate_kind (expr->ts.type, expr->ts.kind);
-  switch (expr->ts.type)
-    {
-    case BT_REAL:
-      tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
-      break;
-
-    case BT_INTEGER:
-      tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
-      break;
-
-    default:
-      abort ();
-    }
-
-  /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
-  if (op == GT_EXPR)
-    tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
-  gfc_add_modify_expr (&se->pre, limit, tmp);
+  type = gfc_typenode_for_spec (&expr->ts);
 
   /* Walk the arguments.  */
   actual = expr->value.function.actual;
@@ -1356,6 +1336,28 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
   else
     maskss = NULL;
 
+  limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
+  n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind);
+  switch (arrayexpr->ts.type)
+    {
+    case BT_REAL:
+      tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
+      break;
+
+    case BT_INTEGER:
+      tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
+				  arrayexpr->ts.kind);
+      break;
+
+    default:
+      abort ();
+    }
+
+  /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
+  if (op == GT_EXPR)
+    tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
+  gfc_add_modify_expr (&se->pre, limit, tmp);
+
   /* Initialize the scalarizer.  */
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, arrayss);
@@ -1433,7 +1435,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
 		     integer_one_node));
   tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
   /* And convert to the required type.  */
-  se->expr = convert (type, pos);
+  se->expr = convert (type, tmp);
 }
 
 static void

program intrinsic_mmloc_2
  real a(-1:1), b(2:3), c(1:2)
  integer, dimension(1):: i
  real (kind = 8), dimension(-1:1) :: vc

  a = 0
  b = 0
  c = 0
  a(-1) = 1
  b(2) = 1
  c(1) = 1

  if (maxloc (a, 1) .ne. 1) call abort()
  if (maxloc (b, 1) .ne. 1) call abort()
  if (maxloc (c, 1) .ne. 1) call abort()


  ! We were giving MINLOC and MAXLOC the wrong return type
  vc = (/4.0d0, 2.50d1, 1.0d1/)
  i = minloc (vc)
  if (i(1) .ne. 1) call abort()
END PROGRAM