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

10 files changed, 121 insertions, 0 deletions

diff --git a/libgfortran/m4/iforeach.m4 b/libgfortran/m4/iforeach.m4
index cfe563952bb..7d20213e9aa 100644
--- a/libgfortran/m4/iforeach.m4
+++ b/libgfortran/m4/iforeach.m4
@@ -248,3 +248,56 @@ $1
 START_MASKED_FOREACH_BLOCK
 $2
 FINISH_MASKED_FOREACH_FUNCTION')dnl
+define(SCALAR_FOREACH_FUNCTION,
+`
+extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, GFC_LOGICAL_4 *);
+export_proto(`s'name`'rtype_qual`_'atype_code);
+
+void
+`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * const restrict array,
+	GFC_LOGICAL_4 * mask)
+{
+  index_type rank;
+  index_type dstride;
+  index_type n;
+  rtype_name *dest;
+
+  if (*mask)
+    {
+      name`'rtype_qual`_'atype_code (retarray, array);
+      return;
+    }
+
+  rank = GFC_DESCRIPTOR_RANK (array);
+
+  if (rank <= 0)
+    runtime_error ("Rank of array needs to be > 0");
+
+  if (retarray->data == NULL)
+    {
+      retarray->dim[0].lbound = 0;
+      retarray->dim[0].ubound = rank-1;
+      retarray->dim[0].stride = 1;
+      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
+      retarray->offset = 0;
+      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
+    }
+  else
+    {
+      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
+	runtime_error ("rank of return array does not equal 1");
+
+      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
+        runtime_error ("dimension of return array incorrect");
+
+      if (retarray->dim[0].stride == 0)
+	retarray->dim[0].stride = 1;
+    }
+
+  dstride = retarray->dim[0].stride;
+  dest = retarray->data;
+  for (n = 0; n<rank; n++)
+    dest[n * dstride] = $1 ;
+}')dnl
diff --git a/libgfortran/m4/ifunction.m4 b/libgfortran/m4/ifunction.m4
index caf9dbaab8d..d1a34da00b1 100644
--- a/libgfortran/m4/ifunction.m4
+++ b/libgfortran/m4/ifunction.m4
@@ -317,6 +317,60 @@ define(FINISH_MASKED_ARRAY_FUNCTION,
         }
     }
 }')dnl
+define(SCALAR_ARRAY_FUNCTION,
+`
+extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, const index_type * const restrict,
+	GFC_LOGICAL_4 *);
+export_proto(`s'name`'rtype_qual`_'atype_code);
+
+void
+`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * const restrict array, 
+	const index_type * const restrict pdim, 
+	GFC_LOGICAL_4 * mask)
+{
+  index_type rank;
+  index_type n;
+  index_type dstride;
+  rtype_name *dest;
+
+  if (*mask)
+    {
+      name`'rtype_qual`_'atype_code (retarray, array, pdim);
+      return;
+    }
+    rank = GFC_DESCRIPTOR_RANK (array);
+  if (rank <= 0)
+    runtime_error ("Rank of array needs to be > 0");
+
+  if (retarray->data == NULL)
+    {
+      retarray->dim[0].lbound = 0;
+      retarray->dim[0].ubound = rank-1;
+      retarray->dim[0].stride = 1;
+      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
+      retarray->offset = 0;
+      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
+    }
+  else
+    {
+      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
+	runtime_error ("rank of return array does not equal 1");
+
+      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
+        runtime_error ("dimension of return array incorrect");
+
+      if (retarray->dim[0].stride == 0)
+	retarray->dim[0].stride = 1;
+    }
+
+    dstride = retarray->dim[0].stride;
+    dest = retarray->data;
+
+    for (n = 0; n < rank; n++)
+      dest[n * dstride] = $1 ;
+}')dnl
 define(ARRAY_FUNCTION,
 `START_ARRAY_FUNCTION
 $2
diff --git a/libgfortran/m4/maxloc0.m4 b/libgfortran/m4/maxloc0.m4
index 9feaa4b99b8..a7e88f0b2ce 100644
--- a/libgfortran/m4/maxloc0.m4
+++ b/libgfortran/m4/maxloc0.m4
@@ -64,4 +64,5 @@ MASKED_FOREACH_FUNCTION(
         dest[n * dstride] = count[n] + 1;
     }')
 
+SCALAR_FOREACH_FUNCTION(`0')
 #endif
diff --git a/libgfortran/m4/maxloc1.m4 b/libgfortran/m4/maxloc1.m4
index 161368482f6..3a6ed5ad974 100644
--- a/libgfortran/m4/maxloc1.m4
+++ b/libgfortran/m4/maxloc1.m4
@@ -60,4 +60,6 @@ MASKED_ARRAY_FUNCTION(0,
       result = (rtype_name)n + 1;
     }')
 
+SCALAR_ARRAY_FUNCTION(0)
+
 #endif
diff --git a/libgfortran/m4/maxval.m4 b/libgfortran/m4/maxval.m4
index 9bdf0d07cdd..07cbbdd6ac6 100644
--- a/libgfortran/m4/maxval.m4
+++ b/libgfortran/m4/maxval.m4
@@ -49,4 +49,6 @@ MASKED_ARRAY_FUNCTION(atype_min,
 `  if (*msrc && *src > result)
     result = *src;')
 
+SCALAR_ARRAY_FUNCTION(atype_min)
+
 #endif
diff --git a/libgfortran/m4/minloc0.m4 b/libgfortran/m4/minloc0.m4
index 1c2aa18cf08..33bfe312a54 100644
--- a/libgfortran/m4/minloc0.m4
+++ b/libgfortran/m4/minloc0.m4
@@ -64,4 +64,5 @@ MASKED_FOREACH_FUNCTION(
         dest[n * dstride] = count[n] + 1;
     }')
 
+SCALAR_FOREACH_FUNCTION(`0')
 #endif
diff --git a/libgfortran/m4/minloc1.m4 b/libgfortran/m4/minloc1.m4
index 0c116eb63be..f923ca80410 100644
--- a/libgfortran/m4/minloc1.m4
+++ b/libgfortran/m4/minloc1.m4
@@ -60,4 +60,6 @@ MASKED_ARRAY_FUNCTION(0,
       result = (rtype_name)n + 1;
     }')
 
+SCALAR_ARRAY_FUNCTION(0)
+
 #endif
diff --git a/libgfortran/m4/minval.m4 b/libgfortran/m4/minval.m4
index 9bd37f4d1fb..af02319c1dd 100644
--- a/libgfortran/m4/minval.m4
+++ b/libgfortran/m4/minval.m4
@@ -49,4 +49,6 @@ MASKED_ARRAY_FUNCTION(atype_max,
 `  if (*msrc && *src < result)
     result = *src;')
 
+SCALAR_ARRAY_FUNCTION(atype_max)
+
 #endif
diff --git a/libgfortran/m4/product.m4 b/libgfortran/m4/product.m4
index df77372e8b0..47ee25b8b80 100644
--- a/libgfortran/m4/product.m4
+++ b/libgfortran/m4/product.m4
@@ -47,4 +47,6 @@ MASKED_ARRAY_FUNCTION(1,
 `  if (*msrc)
     result *= *src;')
 
+SCALAR_ARRAY_FUNCTION(1)
+
 #endif
diff --git a/libgfortran/m4/sum.m4 b/libgfortran/m4/sum.m4
index 1d91c0d5100..a9406882cfa 100644
--- a/libgfortran/m4/sum.m4
+++ b/libgfortran/m4/sum.m4
@@ -47,4 +47,6 @@ MASKED_ARRAY_FUNCTION(0,
 `  if (*msrc)
     result += *src;')
 
+SCALAR_ARRAY_FUNCTION(0)
+
 #endif