re PR fortran/20935 (failed assertion for maxloc(n, mask=.true.))

2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/20935
	* iresolve.c (gfc_resolve_maxloc):   If mask is scalar,
	prefix the function name with an "s".  If the mask is scalar
	or if its kind is smaller than gfc_default_logical_kind,
	coerce it to default kind.
	(gfc_resolve_maxval):  Likewise.
	(gfc_resolve_minloc):  Likewise.
	(gfc_resolve_minval):  Likewise.
	(gfc_resolve_product):  Likewise.
	(gfc_resolve_sum):  Likewise.

2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/20935
	* m4/iforeach.m4:  Add SCALAR_FOREACH_FUNCTION macro.
	* m4/ifunction.m4:  Add SCALAR_ARRAY_FUNCTION macro.
	* m4/minloc0.m4:  Use SCALAR_FOREACH_FUNCTION.
	* m4/minloc1.m4:  Use SCALAR_ARRAY_FUNCTION.
	* m4/maxloc0.m4:  Use SCALAR_FOREACH_FUNCTION.
	* m4/maxloc1.m4:  Use SCALAR_ARRAY_FUNCTION.
	* m4/minval.m4:  Likewise.
	* m4/maxval.m4:  Likewise.
	* m4/product.m4:  Likewise.
	* m4/sum.m4:  Likewise.
	* minloc0_16_i16.c : Regenerated.
	* minloc0_16_i4.c : Regenerated.
	* minloc0_16_i8.c : Regenerated.
	* minloc0_16_r10.c : Regenerated.
	* minloc0_16_r16.c : Regenerated.
	* minloc0_16_r4.c : Regenerated.
	* minloc0_16_r8.c : Regenerated.
	* minloc0_4_i16.c : Regenerated.
	* minloc0_4_i4.c : Regenerated.
	* minloc0_4_i8.c : Regenerated.
	* minloc0_4_r10.c : Regenerated.
	* minloc0_4_r16.c : Regenerated.
	* minloc0_4_r4.c : Regenerated.
	* minloc0_4_r8.c : Regenerated.
	* minloc0_8_i16.c : Regenerated.
	* minloc0_8_i4.c : Regenerated.
	* minloc0_8_i8.c : Regenerated.
	* minloc0_8_r10.c : Regenerated.
	* minloc0_8_r16.c : Regenerated.
	* minloc0_8_r4.c : Regenerated.
	* minloc0_8_r8.c : Regenerated.
	* minloc1_16_i16.c : Regenerated.
	* minloc1_16_i4.c : Regenerated.
	* minloc1_16_i8.c : Regenerated.
	* minloc1_16_r10.c : Regenerated.
	* minloc1_16_r16.c : Regenerated.
	* minloc1_16_r4.c : Regenerated.
	* minloc1_16_r8.c : Regenerated.
	* minloc1_4_i16.c : Regenerated.
	* minloc1_4_i4.c : Regenerated.
	* minloc1_4_i8.c : Regenerated.
	* minloc1_4_r10.c : Regenerated.
	* minloc1_4_r16.c : Regenerated.
	* minloc1_4_r4.c : Regenerated.
	* minloc1_4_r8.c : Regenerated.
	* minloc1_8_i16.c : Regenerated.
	* minloc1_8_i4.c : Regenerated.
	* minloc1_8_i8.c : Regenerated.
	* minloc1_8_r10.c : Regenerated.
	* minloc1_8_r16.c : Regenerated.
	* minloc1_8_r4.c : Regenerated.
	* minloc1_8_r8.c : Regenerated.
	* maxloc0_16_i16.c : Regenerated.
	* maxloc0_16_i4.c : Regenerated.
	* maxloc0_16_i8.c : Regenerated.
	* maxloc0_16_r10.c : Regenerated.
	* maxloc0_16_r16.c : Regenerated.
	* maxloc0_16_r4.c : Regenerated.
	* maxloc0_16_r8.c : Regenerated.
	* maxloc0_4_i16.c : Regenerated.
	* maxloc0_4_i4.c : Regenerated.
	* maxloc0_4_i8.c : Regenerated.
	* maxloc0_4_r10.c : Regenerated.
	* maxloc0_4_r16.c : Regenerated.
	* maxloc0_4_r4.c : Regenerated.
	* maxloc0_4_r8.c : Regenerated.
	* maxloc0_8_i16.c : Regenerated.
	* maxloc0_8_i4.c : Regenerated.
	* maxloc0_8_i8.c : Regenerated.
	* maxloc0_8_r10.c : Regenerated.
	* maxloc0_8_r16.c : Regenerated.
	* maxloc0_8_r4.c : Regenerated.
	* maxloc0_8_r8.c : Regenerated.
	* maxloc1_16_i16.c : Regenerated.
	* maxloc1_16_i4.c : Regenerated.
	* maxloc1_16_i8.c : Regenerated.
	* maxloc1_16_r10.c : Regenerated.
	* maxloc1_16_r16.c : Regenerated.
	* maxloc1_16_r4.c : Regenerated.
	* maxloc1_16_r8.c : Regenerated.
	* maxloc1_4_i16.c : Regenerated.
	* maxloc1_4_i4.c : Regenerated.
	* maxloc1_4_i8.c : Regenerated.
	* maxloc1_4_r10.c : Regenerated.
	* maxloc1_4_r16.c : Regenerated.
	* maxloc1_4_r4.c : Regenerated.
	* maxloc1_4_r8.c : Regenerated.
	* maxloc1_8_i16.c : Regenerated.
	* maxloc1_8_i4.c : Regenerated.
	* maxloc1_8_i8.c : Regenerated.
	* maxloc1_8_r10.c : Regenerated.
	* maxloc1_8_r16.c : Regenerated.
	* maxloc1_8_r4.c : Regenerated.
	* maxloc1_8_r8.c : Regenerated.
	* maxval_i16.c : Regenerated.
	* maxval_i4.c : Regenerated.
	* maxval_i8.c : Regenerated.
	* maxval_r10.c : Regenerated.
	* maxval_r16.c : Regenerated.
	* maxval_r4.c : Regenerated.
	* maxval_r8.c : Regenerated.
	* minval_i16.c : Regenerated.
	* minval_i4.c : Regenerated.
	* minval_i8.c : Regenerated.
	* minval_r10.c : Regenerated.
	* minval_r16.c : Regenerated.
	* minval_r4.c : Regenerated.
	* minval_r8.c : Regenerated.
	* sum_c10.c : Regenerated.
	* sum_c16.c : Regenerated.
	* sum_c4.c : Regenerated.
	* sum_c8.c : Regenerated.
	* sum_i16.c : Regenerated.
	* sum_i4.c : Regenerated.
	* sum_i8.c : Regenerated.
	* sum_r10.c : Regenerated.
	* sum_r16.c : Regenerated.
	* sum_r4.c : Regenerated.
	* sum_r8.c : Regenerated.
	* product_c10.c : Regenerated.
	* product_c16.c : Regenerated.
	* product_c4.c : Regenerated.
	* product_c8.c : Regenerated.
	* product_i16.c : Regenerated.
	* product_i4.c : Regenerated.
	* product_i8.c : Regenerated.
	* product_r10.c : Regenerated.
	* product_r16.c : Regenerated.
	* product_r4.c : Regenerated.
	* product_r8.c : Regenerated.

2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/20935
	* gfortran.dg/scalar_mask_2.f90:  New test case.

From-SVN: r112230

2 files changed, 151 insertions, 6 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8101aae..7256b6e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/20935
+	* iresolve.c (gfc_resolve_maxloc):   If mask is scalar,
+	prefix the function name with an "s".  If the mask is scalar
+	or if its kind is smaller than gfc_default_logical_kind,
+	coerce it to default kind.
+	(gfc_resolve_maxval):  Likewise.
+	(gfc_resolve_minloc):  Likewise.
+	(gfc_resolve_minval):  Likewise.
+	(gfc_resolve_product):  Likewise.
+	(gfc_resolve_sum):  Likewise.
+
 2006-03-19  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/26741
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index f961c77..df562f7 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1093,7 +1093,27 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
       gfc_resolve_dim_arg (dim);
     }
 
-  name = mask ? "mmaxloc" : "maxloc";
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "smaxloc";
+      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);
+	}
+    }
+  else
+    name = "maxloc";
+
   f->value.function.name =
     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
                     gfc_type_letter (array->ts.type), array->ts.kind);
@@ -1104,6 +1124,8 @@ void
 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 		    gfc_expr * mask)
 {
+  const char *name;
+
   f->ts = array->ts;
 
   if (dim != NULL)
@@ -1112,8 +1134,29 @@ gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
       gfc_resolve_dim_arg (dim);
     }
 
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "smaxval";
+      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);
+	}
+    }
+  else
+    name = "maxval";
+
   f->value.function.name =
-    gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
+    gfc_get_string (PREFIX("%s_%c%d"), name,
 		    gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
@@ -1157,7 +1200,27 @@ gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
       gfc_resolve_dim_arg (dim);
     }
 
-  name = mask ? "mminloc" : "minloc";
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "sminloc";
+      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);
+	}
+    }
+  else
+    name = "minloc";
+
   f->value.function.name =
     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
                     gfc_type_letter (array->ts.type), array->ts.kind);
@@ -1168,6 +1231,8 @@ void
 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 		    gfc_expr * mask)
 {
+  const char *name;
+
   f->ts = array->ts;
 
   if (dim != NULL)
@@ -1176,8 +1241,29 @@ gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
       gfc_resolve_dim_arg (dim);
     }
 
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "sminval";
+      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);
+	}
+    }
+  else
+    name = "minval";
+
   f->value.function.name =
-    gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
+    gfc_get_string (PREFIX("%s_%c%d"), name,
 		    gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
@@ -1311,6 +1397,8 @@ void
 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 		     gfc_expr * mask)
 {
+  const char *name;
+
   f->ts = array->ts;
 
   if (dim != NULL)
@@ -1319,8 +1407,29 @@ gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
       gfc_resolve_dim_arg (dim);
     }
 
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "sproduct";
+      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);
+	}
+    }
+  else
+    name = "product";
+
   f->value.function.name =
-    gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
+    gfc_get_string (PREFIX("%s_%c%d"), name,
 		    gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
@@ -1733,8 +1842,31 @@ void
 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 		 gfc_expr * mask)
 {
+  const char *name;
+
   f->ts = array->ts;
 
+  if (mask)
+    {
+      if (mask->rank == 0)
+	name = "ssum";
+      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);
+	}
+    }
+  else
+    name = "sum";
+
   if (dim != NULL)
     {
       f->rank = array->rank - 1;
@@ -1742,7 +1874,7 @@ gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
     }
 
   f->value.function.name =
-    gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
+    gfc_get_string (PREFIX("%s_%c%d"), name,
 		    gfc_type_letter (array->ts.type), array->ts.kind);
 }