From patchwork Wed Sep 2 15:02:49 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1355875 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=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4BhRyW3f7hz9sRK for ; Thu, 3 Sep 2020 01:03:13 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 867063944424; Wed, 2 Sep 2020 15:03:10 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id 2906E384A40A; Wed, 2 Sep 2020 15:03:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 2906E384A40A Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=Tobias_Burnus@mentor.com IronPort-SDR: 8QtlSkiNDnDrA6b9dTerB/o2uTkwIF77M4178V0thtFCPNTdodimZUvLgUbFT/xJIoFkpKHw5S +5onmMJ28TrCbF3ztZHby+gRTPdgt+ooNrUzJc3qXLmrXrSVnWItcEegynoyd+DWU+cRbEZpT8 8NQDfLijTnqTar0sQqs3HbuRcyYaEe5RlbZMYjv9cAv/z8mS20JGnwX6B0P4BzgoYJ8hoC1WCN Z28VFfvDsmk3UYM3+rnzLCZef0TGgAlqZ2g1yT5wSQ+nJBwWCB0q/Q9Bm0mJnqEZ+Wp1W52Ptd fSM= X-IronPort-AV: E=Sophos;i="5.76,383,1592899200"; d="diff'?scan'208";a="52527276" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa2.mentor.iphmx.com with ESMTP; 02 Sep 2020 07:02:51 -0800 IronPort-SDR: 7baNTvx8bm9I1gS63C9j2osCbTDBeOcEz18+0KMTj1O34cG8dOVv9XihUb37Wm1GpMI8cvbVBc F30CDech5wjeJ+iGM/tbtkpXD8lKWuy2mS20ChsEDmBLy6I2XaPyxKEilCjnD6gJVZGOtqDGxi ILUzXo5p5m8rDY3b9wLrA7BJNT5nY8+DgdTEOIkOh7wC3+ab2H63cXFyL+LFOWV/DYXx2bohq5 UuxRXhfznjyn+gwtwgVZ1XBdJXsgZr7NGug+DCMDjNGgGYuX5ldUi78Elvfs9278Vh0y/2HC81 pww= To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] Fortran: Fixes for pointer function call as variable (PR96896) Message-ID: Date: Wed, 2 Sep 2020 17:02:49 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.11.0 MIME-Version: 1.0 Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: SVR-IES-MBX-07.mgc.mentorg.com (139.181.222.7) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-12.3 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" During some discussion such an example as attached came up: f() = 0.0 where 'f' is a function which returns a pointer to an array. This gets handled as _F.D0 => f() _F.D0 = 0.0 However, the first line did fail with a rank error as the rank was taken from the RHS. Changing this to the LHS express failed due to 'use_assoc', which added an 'extern' to the variable and 'proc_pointer' also caused problems – in principle, either problem could have also occurred for the RHS. Side effect: The error message is better for rank mismatch as for 'f() = a' no pointer assignment is involved (in terms of the user code) but before we had the error message 'Different ranks in pointer assignment'. OK? Tobias ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter Fortran: Fixes for pointer function call as variable (PR96896) gcc/fortran/ChangeLog: PR fortran/96896 * resolve.c (get_temp_from_expr): Also reset proc_pointer + use_assoc attribute. (resolve_ptr_fcn_assign): Use information from the LHS. gcc/testsuite/ChangeLog: PR fortran/96896 * gfortran.dg/ptr_func_assign_4.f08: * gfortran.dg/ptr-func-3.f90: New test. gcc/fortran/resolve.c | 4 +- gcc/testsuite/gfortran.dg/ptr-func-3.f90 | 56 +++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 | 4 +- 3 files changed, 61 insertions(+), 3 deletions(-) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e4232717e42..a3e1e427ba7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11173,9 +11173,11 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) /* Add the attributes and the arrayspec to the temporary. */ tmp->n.sym->attr = gfc_expr_attr (e); tmp->n.sym->attr.function = 0; + tmp->n.sym->attr.proc_pointer = 0; tmp->n.sym->attr.result = 0; tmp->n.sym->attr.flavor = FL_VARIABLE; tmp->n.sym->attr.dummy = 0; + tmp->n.sym->attr.use_assoc = 0; tmp->n.sym->attr.intent = INTENT_UNKNOWN; if (as) @@ -11595,7 +11597,7 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns) return false; } - tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns); + tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns); /* get_temp_from_expression is set up for ordinary assignments. To that end, where array bounds are not known, arrays are made allocatable. diff --git a/gcc/testsuite/gfortran.dg/ptr-func-3.f90 b/gcc/testsuite/gfortran.dg/ptr-func-3.f90 new file mode 100644 index 00000000000..0f1af64002a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ptr-func-3.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! PR fortran/96896 + +call test1 +call reshape_test +end + +subroutine test1 +implicit none +integer, target :: B +integer, pointer :: A(:) +allocate(A(5)) +A = 1 +B = 10 +get_A() = get_B() +if (any (A /= 10)) stop 1 +get_A() = get_A() +if (any (A /= 10)) stop 2 +deallocate(A) +contains + function get_A() + integer, pointer :: get_A(:) + get_A => A + end + function get_B() + integer, pointer :: get_B + get_B => B + end +end + +subroutine reshape_test + implicit none + real, target, dimension (1:9) :: b + integer :: i + b = 1.0 + myshape(b) = 3.0 + do i = 1, 3 + myfunc (b,i,2) = b(i) + i + b(i) = b(i) + 2.0 + end do + if (any (b /= [real::5,5,5,4,5,6,3,3,3])) stop 3 +contains + function myfunc(b,i,j) + real, target, dimension (1:9) :: b + real, pointer :: myfunc + real, pointer :: p(:,:) + integer :: i,j + p => myshape(b) + myfunc => p(i,j) + end function myfunc + function myshape(b) + real, target, dimension (1:9) :: b + real, pointer :: myshape(:,:) + myshape(1:3,1:3) => b + end function myshape +end subroutine reshape_test diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 index 46ef2ac5566..49ba9bcd3d9 100644 --- a/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 +++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 @@ -10,8 +10,8 @@ program p integer :: c c = 3 - func (b(2, 2)) = b ! { dg-error "Different ranks" } - func (c) = b ! { dg-error "Different ranks" } + func (b(2, 2)) = b ! { dg-error "Incompatible ranks 1 and 2 in assignment" } + func (c) = b ! { dg-error "Incompatible ranks 1 and 2 in assignment" } contains function func(arg) result(r)