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

4 files changed, 188 insertions, 6 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8101aaea5a5..7256b6eb267 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 f961c776e21..df562f78604 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);
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 92e62fc66fa..b7d52acf0d8 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/20935
+	* gfortran.dg/scalar_mask_2.f90:  New test case.
+
 2006-03-20  Andrew Pinski  <pinskia@physics.uc.edu>
 
 	PR tree-opt/26629
diff --git a/gcc/testsuite/gfortran.dg/scalar_mask_2.f90 b/gcc/testsuite/gfortran.dg/scalar_mask_2.f90
new file mode 100644
index 00000000000..adc7bbd60d4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/scalar_mask_2.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+program main
+  ! Test scalar masks for different intrinsics.
+  real, dimension(2,2) :: a
+  logical(kind=2) :: lo
+  lo = .false.
+  a(1,1) = 1.
+  a(1,2) = -1.
+  a(2,1) = 13.
+  a(2,2) = -31.
+  if (any (minloc (a, lo) /= 0)) call abort
+  if (any (minloc (a, .true.) /= (/ 2, 2 /))) call abort
+  if (any (minloc(a, 1, .true.) /= (/ 1, 2/))) call abort
+  if (any (minloc(a, 1, lo ) /= (/ 0, 0/))) call abort
+
+  if (any (maxloc (a, lo) /= 0)) call abort
+  if (any (maxloc (a, .true.) /= (/ 2,1 /))) call abort
+  if (any (maxloc(a, 1, .true.) /= (/ 2, 1/))) call abort
+  if (any (maxloc(a, 1, lo) /= (/ 0, 0/))) call abort
+
+  if (any (maxval(a, 1, lo) /= -HUGE(a))) call abort
+  if (any (maxval(a, 1, .true.) /= (/13., -1./))) call abort
+  if (any (minval(a, 1, lo) /= HUGE(a))) call abort
+  if (any (minval(a, 1, .true.) /= (/1., -31./))) call abort
+
+  if (any (product(a, 1, .true.) /= (/13., 31./))) call abort
+  if (any (product(a, 1, lo ) /= (/1., 1./))) call abort
+
+  if (any (sum(a, 1, .true.) /= (/14., -32./))) call abort
+  if (any (sum(a, 1, lo) /= (/0., 0./))) call abort
+
+end program main