From patchwork Sun Oct 6 15:26:03 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1172536 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-510361-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="kzDL0Tj+"; dkim=pass (2048-bit key; unprotected) header.d=netcologne.de header.i=@netcologne.de header.b="EjzA9b1x"; 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 46mSBP74Ydz9s4Y for ; Mon, 7 Oct 2019 02:26:19 +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=wfkmnWbwLc38BzJ54EEptP5XHj4XmNEwG5uo18VCyMIt1WLi6E ci2D/yrc5z63vxstddUAxirHDn7w+ebjEpkVbBKMM9v8Xt/H4fojY0GrPd0C16Q0 C4sZnrpMUn/Io++E8Y47LccSQVK48oVys+QCQ6TfK78GJpTHz6hNZpodU= 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=w9WMX1Pmh6C2Df8o+RIXYLbQzOA=; b=kzDL0Tj+zGSI5dz9kDcb l8/gv+fZ6SXl5hGlr7HIGRrBoAFnAd17H5o6wqUUlvHE00zdvPyaq171eF6+NwxM FG4vdshZajMuMJEuHUGqH+ghV29owUkFuxuOOwyfsRrQO9YSGn20HE2/2jEFDrGp mtk8vgINHTSxUMKsFbfodDM= Received: (qmail 106148 invoked by alias); 6 Oct 2019 15:26:11 -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 106130 invoked by uid 89); 6 Oct 2019 15:26:11 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.8 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.1 spammy=fulfilling, U*tkoenig, declared_at, sk:tkoenig X-HELO: cc-smtpout3.netcologne.de Received: from cc-smtpout3.netcologne.de (HELO cc-smtpout3.netcologne.de) (89.1.8.213) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sun, 06 Oct 2019 15:26:09 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id 4E4C6127E7; Sun, 6 Oct 2019 17:26:06 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1570375566; bh=lzOyZIjPlaZmnP1FNiagEFaL04GXeY/t6FG3hBXUKmY=; h=To:From:Subject:Message-ID:Date:From; b=EjzA9b1x43o7aBZ590n5AUwNEHC5wOOFEv1LRsvrgAObxNIEN+REe7d9F0LIDBpVm sfZOuzAAsK4ebPjkjySJdkKazIt9JXxATjoVxvvm7iN4VTJTpw2RY+6lVZvshqRo/E +CBe8OQ8LQoYphrOwj0CKVarfrSl6XAcn5cXn+ksMHobxvIScwEO7YMIchGT2SJ7Cu SysuWf5mxnsCMF6yW3RF9gcApOuEAxyD/Vn36XF6ZXP/qZ7ZMW+oROLPq+x77RZEAh wfJjvzH1310vUpZFBAa1WrtDF1PuMYhe1o+TRQ6IqxYER75MW5rkXLtk5/zs85GwPe Bw2oerHsEkstA== Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id 4077011ECE; Sun, 6 Oct 2019 17:26:06 +0200 (CEST) Received: from [2001:4dd4:effe:0:7285:c2ff:fe6c:992d] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.6.0) (envelope-from ) id 5d9a078e-388c-7f0000012729-7f000001db74-1 for ; Sun, 06 Oct 2019 17:26:06 +0200 Received: from [IPv6:2001:4dd4:effe:0:7285:c2ff:fe6c:992d] (2001-4dd4-effe-0-7285-c2ff-fe6c-992d.ipv6dyn.netcologne.de [IPv6:2001:4dd4:effe:0:7285:c2ff:fe6c:992d]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Sun, 6 Oct 2019 17:26:03 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Fix PR 92004, restore Lapack compilation Message-ID: Date: Sun, 6 Oct 2019 17:26:03 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.7.2 MIME-Version: 1.0 Hello world, this patch fixes an overzealous interpretation of F2018 15.5.2.4, where an idiom of passing an array element to an array was rejected. This also restores Lapack compilation without warning. Regression-tested. OK for trunk? Regards Thomas 2019-10-06 Thomas Koenig PR fortran/92004 * gfortran.h (gfc_symbol): Add maybe_array. * interface.c (maybe_dummy_array_arg): New function. (compare_parameter): If the formal argument is generated from a call, check the conditions where an array element could be passed to an array. Adjust error message for assumed-shape or pointer array. (gfc_get_formal_from_actual_arglist): Set maybe_array on the symbol if the actual argument is an array element fulfilling the conditions of 15.5.2.4. 2019-10-06 Thomas Koenig PR fortran/92004 * gfortran.dg/argument_checking_24.f90: New test. Index: gfortran.h =================================================================== --- gfortran.h (Revision 276506) +++ gfortran.h (Arbeitskopie) @@ -1614,6 +1614,9 @@ typedef struct gfc_symbol /* Set if a previous error or warning has occurred and no other should be reported. */ unsigned error:1; + /* Set if an interface to a procedure could actually be to an array + although the actual argument is scalar. */ + unsigned maybe_array:1; int refs; struct gfc_namespace *ns; /* namespace containing this symbol */ Index: interface.c =================================================================== --- interface.c (Revision 276506) +++ interface.c (Arbeitskopie) @@ -2229,6 +2229,36 @@ argument_rank_mismatch (const char *name, locus *w } +/* Under certain conditions, a scalar actual argument can be passed + to an array dummy argument - see F2018, 15.5.2.4, clause 14. This + functin returns true for these conditions so that an error or + warning for this can be suppressed later. */ + +bool +maybe_dummy_array_arg (gfc_expr *e) +{ + gfc_symbol *s; + + if (e->rank > 0) + return false; + + if (e->ts.type == BT_CHARACTER && e->ts.kind == 1) + return true; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + s = e->symtree->n.sym; + if (s->as == NULL) + return false; + + if (s->ts.type == BT_CLASS || s->as->type == AS_ASSUMED_SHAPE + || s->attr.pointer) + return false; + + return true; +} + /* Given a symbol of a formal argument list and an expression, see if the two are compatible as arguments. Returns true if compatible, false if not compatible. */ @@ -2544,7 +2574,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a || (actual->rank == 0 && formal->attr.dimension && gfc_is_coindexed (actual))) { - if (where) + if (where + && (!formal->attr.artificial || (!formal->maybe_array + && !maybe_dummy_array_arg (actual)))) { locus *where_formal; if (formal->attr.artificial) @@ -2594,9 +2626,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) { if (where) - gfc_error ("Element of assumed-shaped or pointer " - "array passed to array dummy argument %qs at %L", - formal->name, &actual->where); + { + if (formal->attr.artificial) + gfc_error ("Element of assumed-shaped or pointer array " + "as actual argument at %L can not correspond to " + "actual argument at %L ", + &actual->where, &formal->declared_at); + else + gfc_error ("Element of assumed-shaped or pointer " + "array passed to array dummy argument %qs at %L", + formal->name, &actual->where); + } return false; } @@ -2625,7 +2665,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a if (ref == NULL && actual->expr_type != EXPR_NULL) { - if (where) + if (where + && (!formal->attr.artificial || (!formal->maybe_array + && !maybe_dummy_array_arg (actual)))) { locus *where_formal; if (formal->attr.artificial) @@ -5228,6 +5270,8 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sy s->as->upper[0] = NULL; s->as->type = AS_ASSUMED_SIZE; } + else + s->maybe_array = maybe_dummy_array_arg (a->expr); } s->attr.dummy = 1; s->declared_at = a->expr->where;