[patch, fortran] Fix PR 20935, failed assertion for scalar mask
Thomas Koenig
Thomas.Koenig@online.de
Tue Mar 14 21:12:00 GMT 2006
:ADDPATCH fortran:
Hello world,
this fixes PR 20935, where the library version of various intrinsics
was doing strange things with a scalar mask. This also fixes a few
unreported bugs with kind=1 and kind=2 masks for the same intrinsics.
OK for trunk and 4.1 after a week or so?
Thomas
2006-03-14 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-14 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-14 Thomas Koenig <Thomas.Koenig@online.de>
PR fortran/20935
* gfortran.dg/scalar_mask_2.f90: New test case.
-------------- next part --------------
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c (revision 112055)
+++ gcc/fortran/iresolve.c (working copy)
@@ -1093,7 +1093,27 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_ex
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_ex
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_ex
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_ex
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_e
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
}
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);
}
Index: libgfortran/m4/minloc1.m4
===================================================================
--- libgfortran/m4/minloc1.m4 (revision 112055)
+++ libgfortran/m4/minloc1.m4 (working copy)
@@ -60,4 +60,6 @@ MASKED_ARRAY_FUNCTION(0,
result = (rtype_name)n + 1;
}')
+SCALAR_ARRAY_FUNCTION(0)
+
#endif
Index: libgfortran/m4/maxloc1.m4
===================================================================
--- libgfortran/m4/maxloc1.m4 (revision 112055)
+++ libgfortran/m4/maxloc1.m4 (working copy)
@@ -60,4 +60,6 @@ MASKED_ARRAY_FUNCTION(0,
result = (rtype_name)n + 1;
}')
+SCALAR_ARRAY_FUNCTION(0)
+
#endif
Index: libgfortran/m4/sum.m4
===================================================================
--- libgfortran/m4/sum.m4 (revision 112055)
+++ libgfortran/m4/sum.m4 (working copy)
@@ -47,4 +47,6 @@ MASKED_ARRAY_FUNCTION(0,
` if (*msrc)
result += *src;')
+SCALAR_ARRAY_FUNCTION(0)
+
#endif
Index: libgfortran/m4/iforeach.m4
===================================================================
--- libgfortran/m4/iforeach.m4 (revision 112055)
+++ libgfortran/m4/iforeach.m4 (working copy)
@@ -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
Index: libgfortran/m4/minval.m4
===================================================================
--- libgfortran/m4/minval.m4 (revision 112055)
+++ libgfortran/m4/minval.m4 (working copy)
@@ -49,4 +49,6 @@ MASKED_ARRAY_FUNCTION(atype_max,
` if (*msrc && *src < result)
result = *src;')
+SCALAR_ARRAY_FUNCTION(atype_max)
+
#endif
Index: libgfortran/m4/maxval.m4
===================================================================
--- libgfortran/m4/maxval.m4 (revision 112055)
+++ libgfortran/m4/maxval.m4 (working copy)
@@ -49,4 +49,6 @@ MASKED_ARRAY_FUNCTION(atype_min,
` if (*msrc && *src > result)
result = *src;')
+SCALAR_ARRAY_FUNCTION(atype_min)
+
#endif
Index: libgfortran/m4/minloc0.m4
===================================================================
--- libgfortran/m4/minloc0.m4 (revision 112055)
+++ libgfortran/m4/minloc0.m4 (working copy)
@@ -64,4 +64,5 @@ MASKED_FOREACH_FUNCTION(
dest[n * dstride] = count[n] + 1;
}')
+SCALAR_FOREACH_FUNCTION(`0')
#endif
Index: libgfortran/m4/maxloc0.m4
===================================================================
--- libgfortran/m4/maxloc0.m4 (revision 112055)
+++ libgfortran/m4/maxloc0.m4 (working copy)
@@ -64,4 +64,5 @@ MASKED_FOREACH_FUNCTION(
dest[n * dstride] = count[n] + 1;
}')
+SCALAR_FOREACH_FUNCTION(`0')
#endif
Index: libgfortran/m4/product.m4
===================================================================
--- libgfortran/m4/product.m4 (revision 112055)
+++ libgfortran/m4/product.m4 (working copy)
@@ -47,4 +47,6 @@ MASKED_ARRAY_FUNCTION(1,
` if (*msrc)
result *= *src;')
+SCALAR_ARRAY_FUNCTION(1)
+
#endif
Index: libgfortran/m4/ifunction.m4
===================================================================
--- libgfortran/m4/ifunction.m4 (revision 112055)
+++ libgfortran/m4/ifunction.m4 (working copy)
@@ -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
-------------- next part --------------
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
More information about the Gcc-patches
mailing list