diff options
Diffstat (limited to 'gcc/fortran/iresolve.c')
| -rw-r--r-- | gcc/fortran/iresolve.c | 140 |
1 files changed, 43 insertions, 97 deletions
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 9c388c57781..32ed6da5645 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -72,6 +72,41 @@ check_charlen_present (gfc_expr *source) } } +/* Helper function for resolving the "mask" argument. */ + +static void +resolve_mask_arg (gfc_expr *mask) +{ + int newkind; + + /* The mask can be kind 4 or 8 for the array case. + For the scalar case, coerce it to kind=4 unconditionally + (because this is the only kind we have a library function + for). */ + + newkind = 0; + + if (mask->rank == 0) + { + if (mask->ts.kind != 4) + newkind = 4; + } + else + { + if (mask->ts.kind < 4) + newkind = gfc_default_logical_kind; + } + + if (newkind) + { + gfc_typespec ts; + + ts.type = BT_LOGICAL; + ts.kind = newkind; + gfc_convert_type (mask, &ts, 2); + } +} + /********************** Resolution functions **********************/ @@ -1232,16 +1267,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); - } + resolve_mask_arg (mask); } else name = "maxloc"; @@ -1286,16 +1312,7 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); - } + resolve_mask_arg (mask); } else name = "maxval"; @@ -1386,16 +1403,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); - } + resolve_mask_arg (mask); } else name = "minloc"; @@ -1440,16 +1448,7 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); - } + resolve_mask_arg (mask); } else name = "minval"; @@ -1555,35 +1554,10 @@ void gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, gfc_expr *vector ATTRIBUTE_UNUSED) { - int newkind; - f->ts = array->ts; f->rank = 1; - /* The mask can be kind 4 or 8 for the array case. For the scalar - case, coerce it to kind=4 unconditionally (because this is the only - kind we have a library function for). */ - - newkind = 0; - if (mask->rank == 0) - { - if (mask->ts.kind != 4) - newkind = 4; - } - else - { - if (mask->ts.kind < 4) - newkind = gfc_default_logical_kind; - } - - if (newkind) - { - gfc_typespec ts; - - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type (mask, &ts, 2); - } + resolve_mask_arg (mask); if (mask->rank != 0) f->value.function.name = (array->ts.type == BT_CHARACTER @@ -1615,16 +1589,7 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); - } + resolve_mask_arg (mask); } else name = "product"; @@ -2112,16 +2077,7 @@ gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 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); - } + resolve_mask_arg (mask); } else name = "sum"; @@ -2350,17 +2306,7 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask, { f->ts = vector->ts; f->rank = mask->rank; - - /* Coerce the mask to default logical kind if it has kind < 4. */ - - if (mask->ts.kind < 4) - { - gfc_typespec ts; - - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type (mask, &ts, 2); - } + resolve_mask_arg (mask); f->value.function.name = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0, |