From 97a62038664e3b5f7e46ce900b2a090c79bb03bd Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Mon, 20 Mar 2006 21:56:00 +0000 Subject: re PR fortran/20935 (failed assertion for maxloc(n, mask=.true.)) 2006-03-20 Thomas Koenig 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 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 PR fortran/20935 * gfortran.dg/scalar_mask_2.f90: New test case. From-SVN: r112230 --- gcc/fortran/iresolve.c | 144 ++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 138 insertions(+), 6 deletions(-) (limited to 'gcc/fortran/iresolve.c') 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); } -- cgit v1.1