From patchwork Thu Dec 19 07:23:02 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1213029 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-516281-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=pass (p=quarantine dis=none) header.from=netcologne.de Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="BGBsxQ5f"; dkim=pass (2048-bit key; unprotected) header.d=netcologne.de header.i=@netcologne.de header.b="EiokxTVm"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 47djz132kkz9sPJ for ; Thu, 19 Dec 2019 18:23:23 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=Mguem0PN9bpEdCakMjBizYSh7j49fPV1eyvMAusynGJP5kpgAc RMeHFFQDIIm2iqNpmhDvuc4rmShqIOZCVZvcCrG7uqymrnR1ktm96CnBUXpO8l4f c8zBfx8LopfuENjWHoaLhoGpXXzjLIQpbEbj+unODIeShmRAotmekGi6A= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=laqbzx5ho8v91YEiR+zZp+usFVw=; b=BGBsxQ5fFh5uaxGrTvIQ TwqzAHEzyZUCHUfVQ5cNjNUVfNCweuxD+hDFbTe+joZNQHzQ+t0K96mtT2FinMmO V+pXwkE1DaAljb6oZCapG8JYrDWU730nE7oGzHN2KQGrwE9yOXnQDMbYbRZBQH36 XZfnGiv82gqDFuiRyNsBq6M= Received: (qmail 127716 invoked by alias); 19 Dec 2019 07:23:15 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 127699 invoked by uid 89); 19 Dec 2019 07:23:15 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-15.3 required=5.0 tests=BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.1 spammy= X-HELO: cc-smtpout1.netcologne.de Received: from cc-smtpout1.netcologne.de (HELO cc-smtpout1.netcologne.de) (89.1.8.211) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 19 Dec 2019 07:23:12 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout1.netcologne.de (Postfix) with ESMTP id 2C6DB13341; Thu, 19 Dec 2019 08:23:10 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1576740190; bh=i1oUIuQbIXZ94XFY1H+gswTeLfANCzsj3boFaVf2Lr4=; h=To:From:Subject:Message-ID:Date:From; b=EiokxTVm0o3/TuB/Q6pEzG6jeimSEjMEIfxtV+4tYZsTPx+wCkK1zBGhin89GRRzx k0Bi1Zm4sJYNC/xPGoXM+rtYjOqoygSBPqFe/zisWpSvttPjpcXK+xhoLNJc8e9hVO +nhSwnFpHEXamnaLZF7vCAePrWdll3eBwx1vm+y6Qy9sH+0BTSo9+aBN9AOFdf+50n hMFaQRtuF+AQp3plM5cFfyUPrFKvT9yTJw81dvxc5UJWz5Gu+39eo5YiGszP3pwb0+ /sEcNXp27fJwISbyDtuHIVfsb/PX0rgtIG8t6+NqGSc3Ue/GkuP+6HYytaL5Fsh6dq 7NTkhG4q6dYCQ== Received: from localhost (localhost [127.0.0.1]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id 1C9CC11F00; Thu, 19 Dec 2019 08:23:10 +0100 (CET) Received: from [2001:4dd4:de16:0:7285:c2ff:fe6c:992d] (helo=cc-smtpin1.netcologne.de) by localhost with ESMTP (eXpurgate 4.11.6) (envelope-from ) id 5dfb255e-45d8-7f0000012729-7f000001d83e-1 for ; Thu, 19 Dec 2019 08:23:10 +0100 Received: from [IPv6:2001:4dd4:de16:0:7285:c2ff:fe6c:992d] (2001-4dd4-de16-0-7285-c2ff-fe6c-992d.ipv6dyn.netcologne.de [IPv6:2001:4dd4:de16:0:7285:c2ff:fe6c:992d]) (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; Thu, 19 Dec 2019 08:23:07 +0100 (CET) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Fix PR 91541, ICE on valid for INDEX Message-ID: <2acc66d5-2061-1dd2-ee45-265abb0ab551@netcologne.de> Date: Thu, 19 Dec 2019 08:23:02 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.7.2 MIME-Version: 1.0 Hello world, the attached patch fixes an ICE on valid for INDEX (see test case). The problem was that the KIND argument was still present during scalarization, which caused the ICE. The fix is to remove the KIND argument, and the best place to do this is in resolution. I did try to do this in gfc_conv_intrinsic_index_scan_verify, but it is too late by then. Removing the KIND argument required changing the call signature of gfc_resolve_index_func, which in turn required the rest of the changes (including the one in trans-decl.c - I am not convinced that what we are doing there is right, but for this bug fix, I left the functionality as is). Regression-tested. OK for trunk? Regards Thomas 2019-12-19 Thomas Koenig PR fortran/91541 * intrinsic.c (add_sym_4ind): New function. (add_functions): Use it for INDEX. (resolve_intrinsic): Also call f1m for INDEX. * intrinsic.h (gfc_resolve_index_func): Adjust prototype to take a gfc_arglist instead of individual arguments. * iresolve.c (gfc_resolve_index_func): Adjust arguments. Remove KIND argument if present, and make sure this is not done twice. * trans-decl.c: Include "intrinsic.h". (gfc_get_extern_function_decl): Special case for resolving INDEX. 2019-12-19 Thomas Koenig PR fortran/91541 * gfortran.dg/index_3.f90: New test. Index: intrinsic.c =================================================================== --- intrinsic.c (Revision 279405) +++ intrinsic.c (Arbeitskopie) @@ -851,7 +851,40 @@ add_sym_4 (const char *name, gfc_isym_id id, enum (void *) 0); } +/* Add a symbol to the function list where the function takes 4 + arguments and resolution may need to change the number or + arrangement of arguments. This is the case for INDEX, which needs + its KIND argument removed. */ +static void +add_sym_4ind (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + void (*resolve) (gfc_expr *, gfc_actual_arglist *), + 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 *a4, bt type4, int kind4, int optional4 ) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f4 = check; + sf.f4 = simplify; + rf.f1m = 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); +} + + /* Add a symbol to the subroutine list where the subroutine takes 4 arguments. */ @@ -2153,11 +2186,11 @@ add_functions (void) /* The resolution function for INDEX is called gfc_resolve_index_func because the name gfc_resolve_index is already used in resolve.c. */ - add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, - BT_INTEGER, di, GFC_STD_F77, - gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, - stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, - bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); + add_sym_4ind ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, + BT_INTEGER, di, GFC_STD_F77, + gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, + stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, + bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77); @@ -4434,9 +4467,10 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gf arg = e->value.function.actual; - /* Special case hacks for MIN and MAX. */ + /* Special case hacks for MIN, MAX and INDEX. */ if (specific->resolve.f1m == gfc_resolve_max - || specific->resolve.f1m == gfc_resolve_min) + || specific->resolve.f1m == gfc_resolve_min + || specific->resolve.f1m == gfc_resolve_index_func) { (*specific->resolve.f1m) (e, arg); return; Index: intrinsic.h =================================================================== --- intrinsic.h (Revision 279405) +++ intrinsic.h (Arbeitskopie) @@ -517,8 +517,7 @@ void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gf void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *); +void gfc_resolve_index_func (gfc_expr *, gfc_actual_arglist *); void gfc_resolve_ierrno (gfc_expr *); void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *); Index: iresolve.c =================================================================== --- iresolve.c (Revision 279405) +++ iresolve.c (Arbeitskopie) @@ -1352,16 +1352,31 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_exp void -gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, - gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back, - gfc_expr *kind) +gfc_resolve_index_func (gfc_expr *f, gfc_actual_arglist *a) { gfc_typespec ts; gfc_clear_ts (&ts); + gfc_expr *str, *back, *kind; + gfc_actual_arglist *a_sub_str, *a_back, *a_kind; + if (f->do_not_resolve_again) + return; + + a_sub_str = a->next; + a_back = a_sub_str->next; + a_kind = a_back->next; + + str = a->expr; + back = a_back->expr; + kind = a_kind->expr; + f->ts.type = BT_INTEGER; if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); + { + f->ts.kind = mpz_get_si ((kind)->value.integer); + a_back->next = NULL; + gfc_free_actual_arglist (a_kind); + } else f->ts.kind = gfc_default_integer_kind; @@ -1376,6 +1391,8 @@ void f->value.function.name = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind); + + f->do_not_resolve_again = 1; } Index: trans-decl.c =================================================================== --- trans-decl.c (Revision 279405) +++ trans-decl.c (Arbeitskopie) @@ -42,6 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-types.h" #include "trans-array.h" #include "trans-const.h" +#include "intrinsic.h" /* For gfc_resolve_index_func. */ /* Only for gfc_trans_code. Shouldn't need to include this. */ #include "trans-stmt.h" #include "gomp-constants.h" @@ -2210,7 +2211,28 @@ module_sym: { /* All specific intrinsics take less than 5 arguments. */ gcc_assert (isym->formal->next->next->next->next == NULL); - isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); + if (isym->resolve.f1m == gfc_resolve_index_func) + { + /* gfc_resolve_index_func is special because it takes a + gfc_actual_arglist instead of individual arguments. */ + gfc_actual_arglist *a, *n; + int i; + a = gfc_get_actual_arglist(); + n = a; + + for (i = 0; i < 4; i++) + { + n->next = gfc_get_actual_arglist(); + n = n->next; + } + + a->expr = &argexpr; + isym->resolve.f1m (&e, a); + a->expr = NULL; + gfc_free_actual_arglist (a); + } + else + isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); } } }