From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 92957 invoked by alias); 28 Oct 2017 21:57:17 -0000 Mailing-List: contact fortran-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Subscribe: List-Post: List-Help: , Sender: fortran-owner@gcc.gnu.org Received: (qmail 92830 invoked by uid 89); 28 Oct 2017 21:57:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.2 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_2,GIT_PATCH_3,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_LOW,RP_MATCHES_RCVD,SPF_PASS autolearn=ham version=3.3.2 spammy=frankly, 31877 X-Spam-User: qpsmtpd, 2 recipients X-HELO: cc-smtpout2.netcologne.de Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sat, 28 Oct 2017 21:57:12 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id EBF1012678; Sat, 28 Oct 2017 23:57:07 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id DE7BF11DBC; Sat, 28 Oct 2017 23:57:07 +0200 (CEST) Received: from [78.35.155.138] (helo=cc-smtpin1.netcologne.de) by localhost with ESMTP (eXpurgate 4.1.9) (envelope-from ) id 59f4fd33-029d-7f0000012729-7f000001a297-1 for ; Sat, 28 Oct 2017 23:57:07 +0200 Received: from [192.168.178.20] (xdsl-78-35-155-138.netcologne.de [78.35.155.138]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA; Sat, 28 Oct 2017 23:57:06 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] KIND arguments for MINLOC and MAXLOC Message-ID: <1861eba6-30d7-32f5-d926-b618f5b1324f@netcologne.de> Date: Sat, 28 Oct 2017 21:57:00 -0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.4.0 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------9A86B3699263C7BC7B55229C" X-SW-Source: 2017-10/txt/msg00120.txt.bz2 This is a multi-part message in MIME format. --------------9A86B3699263C7BC7B55229C Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit Content-length: 2348 Hello world, the attached patch allows KIND arguments to MINLOC and MAXLOC. There was a bit of a choice to make here. Originally, I wanted to run the calculation using index_type only and convert to another integer kind if that was required. This ran into the issue that bounds checking fails for this approach if there is a conversion ( https://gcc.gnu.org/bugzilla/show_bug.cgi?id=82660 ), and I got regressions for that. On the other hand, I wanted to avoid adding kind=1 and kind=2 versions to the library. This approach had been rejected some time ago, in 2009. So, I chose a third path by using only pre-existing library functions for kind=4, kind=8 and kind=16 and by doing a conversion if the user specified kind=1 or kind=2. This introduces a bug (array bounds violation not caught) if the user - specifies bounds checking - choses kind=1 or kind=2 for minloc or maxloc (it escapes me why anybody would want to do that) - uses an array as return value whose bounds cannot be determined at compile-time, and gets the dimension of that array wrong Frankly, if anybody would do this, the expression "deserves to lose" comes to mind. This would not be a regression, because kind=1 and kind=2 are not supported at the moment. This bug would be fixed together with 82660. Regression-tested. OK for trunk? Regards Thomas 2017-10-28 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-10-28 Thomas Koenig PR fortran/29600 * gfortran.dg/minmaxloc_8.f90: New test. --------------9A86B3699263C7BC7B55229C Content-Type: text/x-patch; name="p4.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="p4.diff" Content-length: 9279 Index: gfortran.h =================================================================== --- gfortran.h (Revision 253768) +++ gfortran.h (Arbeitskopie) @@ -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 *); Index: intrinsic.h =================================================================== --- intrinsic.h (Revision 253768) +++ intrinsic.h (Arbeitskopie) @@ -537,7 +537,7 @@ void gfc_resolve_logical (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 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 *); Index: check.c =================================================================== --- check.c (Revision 253768) +++ check.c (Arbeitskopie) @@ -3179,7 +3179,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *ma 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; } Index: intrinsic.c =================================================================== --- intrinsic.c (Revision 253768) +++ intrinsic.c (Arbeitskopie) @@ -687,27 +687,29 @@ add_sym_3 (const char *name, gfc_isym_id id, enum 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_e 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) Index: iresolve.c =================================================================== --- iresolve.c (Revision 253768) +++ iresolve.c (Arbeitskopie) @@ -1691,17 +1691,32 @@ gfc_resolve_max (gfc_expr *f, gfc_actual_arglist * 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) { f->rank = 1; @@ -1740,6 +1755,21 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, 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,14 +1891,26 @@ gfc_resolve_min (gfc_expr *f, gfc_actual_arglist * 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) { f->rank = 1; @@ -1907,6 +1949,16 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, 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); + } } --------------9A86B3699263C7BC7B55229C Content-Type: text/x-fortran; name="minmaxloc_8.f90" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="minmaxloc_8.f90" Content-length: 1188 ! { 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 --------------9A86B3699263C7BC7B55229C--