From b22755743186cb09c6cdd90d46f8c1462fa84544 Mon Sep 17 00:00:00 2001 From: tkoenig Date: Sat, 4 Nov 2017 13:20:32 +0000 Subject: 2017-11-04 Thomas Koenig PR fortran/29600 * gfortran.h (gfc_check_f): Replace fm3l with fm4l. * intrinsic.h (gfc_resolve_maxloc): Add gfc_expr * to argument list in protoytpe. (gfc_resolve_minloc): Likewise. * check.c (gfc_check_minloc_maxloc): Handle kind argument. * intrinsic.c (add_sym_3_ml): Rename to (add_sym_4_ml): and handle kind argument. (add_function): Replace add_sym_3ml with add_sym_4ml and add extra arguments for maxloc and minloc. (check_specific): Change use of check.f3ml with check.f4ml. * iresolve.c (gfc_resolve_maxloc): Handle kind argument. If the kind is smaller than the smallest library version available, use gfc_default_integer_kind and convert afterwards. (gfc_resolve_minloc): Likewise. 2017-11-04 Thomas Koenig PR fortran/29600 * gfortran.dg/minmaxloc_8.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@254405 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/iresolve.c | 60 ++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 56 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/iresolve.c') diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index b784ac339e9..a54ed2295b5 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1691,16 +1691,31 @@ gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args) gfc_resolve_minmax ("__max_%c%d", f, args); } +/* The smallest kind for which a minloc and maxloc implementation exists. */ + +#define MINMAXLOC_MIN_KIND 4 void gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) + gfc_expr *mask, gfc_expr *kind) { const char *name; int i, j, idim; + int fkind; f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + + /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, + we do a type conversion further down. */ + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind < MINMAXLOC_MIN_KIND) + f->ts.kind = MINMAXLOC_MIN_KIND; + else + f->ts.kind = fkind; if (dim == NULL) { @@ -1740,6 +1755,21 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); + + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind != f->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } } @@ -1861,13 +1891,25 @@ gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args) void gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) + gfc_expr *mask, gfc_expr *kind) { const char *name; int i, j, idim; + int fkind; f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + + /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, + we do a type conversion further down. */ + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind < MINMAXLOC_MIN_KIND) + f->ts.kind = MINMAXLOC_MIN_KIND; + else + f->ts.kind = fkind; if (dim == NULL) { @@ -1907,6 +1949,16 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 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); + + if (fkind != f->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } } -- cgit v1.2.1