From: Thomas Koenig Date: Sat, 4 Nov 2017 13:20:32 +0000 (+0000) Subject: re PR fortran/29600 ([F03] MINLOC and MAXLOC take an optional KIND argument) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9a3d38f6dcacbfb9c8ced01d870f35864d765ba7;p=gcc.git re PR fortran/29600 ([F03] MINLOC and MAXLOC take an optional KIND argument) 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. From-SVN: r254405 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index aa43ff4ebff..0b2ca315605 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +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 Paul Thomas PR fortran/81735 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 759c15adaec..914dbf957fd 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3179,7 +3179,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) bool gfc_check_minloc_maxloc (gfc_actual_arglist *ap) { - gfc_expr *a, *m, *d; + gfc_expr *a, *m, *d, *k; a = ap->expr; if (!int_or_real_check (a, 0) || !array_check (a, 0)) @@ -3187,6 +3187,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) d = ap->next->expr; m = ap->next->next->expr; + k = ap->next->next->next->expr; if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL && ap->next->name == NULL) @@ -3214,6 +3215,9 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) gfc_current_intrinsic)) return false; + if (!kind_check (k, 1, BT_INTEGER)) + return false; + return true; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 2c2fc636708..213c5da56f7 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1989,7 +1989,7 @@ gfc_intrinsic_arg; argument lists of intrinsic functions. fX with X an integer refer to check functions of intrinsics with X arguments. f1m is used for the MAX and MIN intrinsics which can have an arbitrary number of - arguments, f3ml is used for the MINLOC and MAXLOC intrinsics as + arguments, f4ml is used for the MINLOC and MAXLOC intrinsics as these have special semantics. */ typedef union @@ -1999,7 +1999,7 @@ typedef union bool (*f1m)(gfc_actual_arglist *); bool (*f2)(struct gfc_expr *, struct gfc_expr *); bool (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); - bool (*f3ml)(gfc_actual_arglist *); + bool (*f4ml)(gfc_actual_arglist *); bool (*f3red)(gfc_actual_arglist *); bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index da96e8ff30c..cb18b21a90d 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -687,27 +687,29 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty might have to be reordered. */ static void -add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, +add_sym_4ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1, const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3) + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4) { gfc_check_f cf; gfc_simplify_f sf; gfc_resolve_f rf; - cf.f3ml = check; - sf.f3 = simplify; - rf.f3 = resolve; + cf.f4ml = check; + sf.f4 = simplify; + rf.f4 = resolve; add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, a1, type1, kind1, optional1, INTENT_IN, a2, type2, kind2, optional2, INTENT_IN, a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, (void *) 0); } @@ -2455,10 +2457,10 @@ add_functions (void) make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95); - add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + add_sym_4ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); + msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); @@ -2531,10 +2533,10 @@ add_functions (void) make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95); - add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + add_sym_4ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); + msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); @@ -4498,7 +4500,7 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) if (!do_ts29113_check (specific, *ap)) return false; - if (specific->check.f3ml == gfc_check_minloc_maxloc) + if (specific->check.f4ml == gfc_check_minloc_maxloc) /* This is special because we might have to reorder the argument list. */ t = gfc_check_minloc_maxloc (*ap); else if (specific->check.f3red == gfc_check_minval_maxval) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index e8280f6f2ac..62827887b3c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -537,7 +537,7 @@ void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lstat (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_matmul (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_max (gfc_expr *, gfc_actual_arglist *); -void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_mclock (gfc_expr *); void gfc_resolve_mclock8 (gfc_expr *); @@ -545,7 +545,7 @@ void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *); -void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *); 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); + } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 10331b39929..3997311bdd4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-11-04 Thomas Koenig + + PR fortran/29600 + * gfortran.dg/minmaxloc_8.f90: New test. + 2017-11-04 Paul Thomas PR fortran/81735 diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_8.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_8.f90 new file mode 100644 index 00000000000..e9f37f2b689 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_8.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! Test that minloc and maxloc using KINDs return the right +! kind, by using unformatted I/O for a specific kind. +program main + implicit none + real, dimension(3) :: a + integer :: r1, r2, r4, r8 + integer :: k + character(len=30) :: l1, l2 + + ! Check via I/O if the KIND is used correctly + a = [ 1.0, 3.0, 2.0] + write (unit=l1,fmt=*) 2_1 + write (unit=l2,fmt=*) maxloc(a,kind=1) + if (l1 /= l2) call abort + + write (unit=l1,fmt=*) 2_2 + write (unit=l2,fmt=*) maxloc(a,kind=2) + if (l1 /= l2) call abort + + write (unit=l1,fmt=*) 2_4 + write (unit=l2,fmt=*) maxloc(a,kind=4) + if (l1 /= l2) call abort + + write (unit=l1,fmt=*) 2_8 + write (unit=l2,fmt=*) maxloc(a,kind=8) + if (l1 /= l2) call abort + + a = [ 3.0, -1.0, 2.0] + + write (unit=l1,fmt=*) 2_1 + write (unit=l2,fmt=*) minloc(a,kind=1) + if (l1 /= l2) call abort + + write (unit=l1,fmt=*) 2_2 + write (unit=l2,fmt=*) minloc(a,kind=2) + if (l1 /= l2) call abort + + write (unit=l1,fmt=*) 2_4 + write (unit=l2,fmt=*) minloc(a,kind=4) + if (l1 /= l2) call abort + + write (unit=l1,fmt=*) 2_8 + write (unit=l2,fmt=*) minloc(a,kind=8) + if (l1 /= l2) call abort + +end program main