2007-08-01 Thomas Koenig <tkoenig@gcc.gnu.org>

	PR libfortran/32954
	* intrinsic.c (resolve_mask_arg):  New function.
	(gfc_resolve_maxloc):  Use resolve_mask_arg for mask resolution.
	(gfc_resolve_maxval):  Likewise.
	(gfc_resolve_minloc):  Likewise.
	(gfc_resolve_minval):  Likewise.
	(gfc_resolve_pack):  Likewise.
	(gfc_resolve_product):  Likewise.
	(gfc_resolve_sum):  Likewise.
	(gfc_resolve_unpack):  Likewise.

2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32954
	* minmaxloc_3.f90:  New test case.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127137 138bc75d-0d04-0410-961f-82ee72b054a4

2 files changed, 56 insertions, 97 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 81bff2b42ca..1d6ca667456 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR libfortran/32954
+	* intrinsic.c (resolve_mask_arg):  New function.
+	(gfc_resolve_maxloc):  Use resolve_mask_arg for mask resolution.
+	(gfc_resolve_maxval):  Likewise.
+	(gfc_resolve_minloc):  Likewise.
+	(gfc_resolve_minval):  Likewise.
+	(gfc_resolve_pack):  Likewise.
+	(gfc_resolve_product):  Likewise.
+	(gfc_resolve_sum):  Likewise.
+	(gfc_resolve_unpack):  Likewise.
+
 2007-08-01  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/32936
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 9c388c57781..32ed6da5645 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -72,6 +72,41 @@ check_charlen_present (gfc_expr *source)
     }
 }
 
+/* Helper function for resolving the "mask" argument.  */
+
+static void
+resolve_mask_arg (gfc_expr *mask)
+{
+  int newkind;
+
+  /* The mask can be kind 4 or 8 for the array case.
+     For the scalar case, coerce it to kind=4 unconditionally
+     (because this is the only kind we have a library function
+     for).  */
+
+  newkind = 0;
+
+  if (mask->rank == 0)
+    {
+      if (mask->ts.kind != 4)
+	newkind = 4;
+    }
+  else
+    {
+      if (mask->ts.kind < 4)
+	newkind = gfc_default_logical_kind;
+    }
+
+  if (newkind)
+    {
+      gfc_typespec ts;
+
+      ts.type = BT_LOGICAL;
+      ts.kind = newkind;
+      gfc_convert_type (mask, &ts, 2);
+    }
+}
+
 /********************** Resolution functions **********************/
 
 
@@ -1232,16 +1267,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
 	name = "mmaxloc";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-	 scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-	  || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-	{
-	  gfc_typespec ts;
-	  ts.type = BT_LOGICAL;
-	  ts.kind = gfc_default_logical_kind;
-	  gfc_convert_type_warn (mask, &ts, 2, 0);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "maxloc";
@@ -1286,16 +1312,7 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
 	name = "mmaxval";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-	 scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-	  || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-	{
-	  gfc_typespec ts;
-	  ts.type = BT_LOGICAL;
-	  ts.kind = gfc_default_logical_kind;
-	  gfc_convert_type_warn (mask, &ts, 2, 0);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "maxval";
@@ -1386,16 +1403,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
 	name = "mminloc";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-	 scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-	  || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-	{
-	  gfc_typespec ts;
-	  ts.type = BT_LOGICAL;
-	  ts.kind = gfc_default_logical_kind;
-	  gfc_convert_type_warn (mask, &ts, 2, 0);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "minloc";
@@ -1440,16 +1448,7 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
 	name = "mminval";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-	 scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-	  || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-	{
-	  gfc_typespec ts;
-	  ts.type = BT_LOGICAL;
-	  ts.kind = gfc_default_logical_kind;
-	  gfc_convert_type_warn (mask, &ts, 2, 0);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "minval";
@@ -1555,35 +1554,10 @@ void
 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
 		  gfc_expr *vector ATTRIBUTE_UNUSED)
 {
-  int newkind;
-
   f->ts = array->ts;
   f->rank = 1;
 
-  /* The mask can be kind 4 or 8 for the array case.  For the scalar
-     case, coerce it to kind=4 unconditionally (because this is the only
-     kind we have a library function for).  */
-
-  newkind = 0;
-  if (mask->rank == 0)
-    {
-      if (mask->ts.kind != 4)
-	newkind = 4;
-    }
-  else
-    {
-      if (mask->ts.kind < 4)
-	newkind = gfc_default_logical_kind;
-    }
-
-  if (newkind)
-    {
-      gfc_typespec ts;
-
-      ts.type = BT_LOGICAL;
-      ts.kind = gfc_default_logical_kind;
-      gfc_convert_type (mask, &ts, 2);
-    }
+  resolve_mask_arg (mask);
 
   if (mask->rank != 0)
     f->value.function.name = (array->ts.type == BT_CHARACTER
@@ -1615,16 +1589,7 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
 	name = "mproduct";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-	 scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-	  || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-	{
-	  gfc_typespec ts;
-	  ts.type = BT_LOGICAL;
-	  ts.kind = gfc_default_logical_kind;
-	  gfc_convert_type_warn (mask, &ts, 2, 0);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "product";
@@ -2112,16 +2077,7 @@ gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
       else
 	name = "msum";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-	 scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-	  || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-	{
-	  gfc_typespec ts;
-	  ts.type = BT_LOGICAL;
-	  ts.kind = gfc_default_logical_kind;
-	  gfc_convert_type_warn (mask, &ts, 2, 0);
-	}
+      resolve_mask_arg (mask);
     }
   else
     name = "sum";
@@ -2350,17 +2306,7 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
 {
   f->ts = vector->ts;
   f->rank = mask->rank;
-
-  /* Coerce the mask to default logical kind if it has kind < 4.  */
-
-  if (mask->ts.kind < 4)
-    {
-      gfc_typespec ts;
-
-      ts.type = BT_LOGICAL;
-      ts.kind = gfc_default_logical_kind;
-      gfc_convert_type (mask, &ts, 2);
-    }
+  resolve_mask_arg (mask);
 
   f->value.function.name
     = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,