From patchwork Tue Apr 11 14:54:42 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 82013 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:b0ea:0:b0:3b6:4342:cba0 with SMTP id b10csp2636003vqo; Tue, 11 Apr 2023 07:56:11 -0700 (PDT) X-Google-Smtp-Source: AKy350ZjSO5mcgIyWed4IYzC0CNTCW+VM3dFPrYpf8fGzS9Mg3Dhpvuv5bZ1rjSDQy3g0SmcejvS X-Received: by 2002:a05:6402:1819:b0:4fd:1ff0:2291 with SMTP id g25-20020a056402181900b004fd1ff02291mr9243183edy.18.1681224971424; Tue, 11 Apr 2023 07:56:11 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1681224971; cv=none; d=google.com; s=arc-20160816; b=KLHbVzvIp9F+YsRTFoj3RVagLNbeOrPHnL62Xp8sb4+EU/wkfeRZIvlMctWwxwehPc YQMUpwjTyvDqKb0bRNyySJcSP/G5A1rJrgJ9ZRhKYfKS0ftB/KT4VlA48SYIIXxqOIDl C7LVNDbb/HPtSyH7j9rGHKVELvMjsNIZ6j/RzQZ3wkWa1oCMqFxkV/BARNb5l4DS1D8O S/NFcdcxeNhNHn5CcjWf1mbkMtDvd+LZaWz1rjsflLFcaHqdipKcwNukMBfC6bUEYpuk nONbCG+3RiQ94hnxHqlffbZnkwBdTO5dur/pNFQjUtBWsjCHXeO1EZTgIUSUxlkUaIZQ EoSg== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence:cc:in-reply-to :content-language:user-agent:mime-version:references:message-id:date :subject:to:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=v0DNDXho5OvwiIdrDpFljXbdv9pTDKW1cXffyL8Thr8=; b=ZxLXbv97iLSCWEHbx33rs20Uviu/8YVlEHsQvD+rcbP9qBanaaulPDXYhuK3OMp0rz 7bjrCz0M58YJN2ZhH5JFUcEvKe3Ix9xw0Bu4A13pCtLc3Zv/oX/tSli+H+Td8+lsYrY0 Nt3bzEJIQqb1OCT4jj0u1JwAqbJSoKzW28DOlpVgEuw6kCmiC1P7xrnG4gazPbtNbwAp GYeSnjBO7p6ENQ4/3cKbmjQavydujea+X5AH1wl6d/kPJymwVzg7INqyWKd8QIYsWOEt nnXKARlxzz4hEeVFjCMc7LNzdJ/0eenQx008DikQ3TXqKn1tyP5XGEAf5JSxhqt7nJmR 3/EQ== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=APSdLA7x; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id o21-20020a056402039500b00504ab514d22si3978815edv.338.2023.04.11.07.56.11 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 11 Apr 2023 07:56:11 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=APSdLA7x; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 4747A3856DC5 for ; Tue, 11 Apr 2023 14:55:35 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 4747A3856DC5 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1681224935; bh=v0DNDXho5OvwiIdrDpFljXbdv9pTDKW1cXffyL8Thr8=; h=To:Subject:Date:References:In-Reply-To:Cc:List-Id: List-Unsubscribe:List-Archive:List-Post:List-Help:List-Subscribe: From:Reply-To:From; b=APSdLA7xjsEuYBKIqQbqnFYE+06rGRfj2MWnRwVr4uWGvPRSFfMHTIwMf80iB7Ye/ r/016Am2unJtxrPrwxz4r4uc8h9Qz+zPHKJ7KCR/zXf3Jh1BcQYJeA9RkdaNjTr94F ovlETK3dK1k2U4qo1efftq4Th4k/eMPAypRG55+Y= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from ciao.gmane.io (ciao.gmane.io [116.202.254.214]) by sourceware.org (Postfix) with ESMTPS id 066663858C2C for ; Tue, 11 Apr 2023 14:54:51 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 066663858C2C Received: from list by ciao.gmane.io with local (Exim 4.92) (envelope-from ) id 1pmFOS-0003oz-U4 for gcc-patches@gcc.gnu.org; Tue, 11 Apr 2023 16:54:48 +0200 X-Injected-Via-Gmane: http://gmane.org/ To: gcc-patches@gcc.gnu.org Subject: [PATCH, v2] Fortran: resolve correct generic with TYPE(C_PTR) arguments [PR61615] Date: Tue, 11 Apr 2023 16:54:42 +0200 Message-ID: <846db39b-74ea-c10c-a686-a4aa062936d7@gmx.de> References: <32181840-acbb-3e7d-74f1-3de710ef82f8@gmail.com> Mime-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.9.1 Content-Language: en-US In-Reply-To: <32181840-acbb-3e7d-74f1-3de710ef82f8@gmail.com> Cc: fortran@gcc.gnu.org X-Spam-Status: No, score=-9.0 required=5.0 tests=BAYES_00, FREEMAIL_FORGED_FROMDOMAIN, FREEMAIL_FROM, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1762824029335902927?= X-GMAIL-MSGID: =?utf-8?q?1762892155621698707?= Hi Jerry, all, On 4/11/23 02:43, Jerry D via Gcc-patches wrote: > On 4/10/23 1:49 PM, Harald Anlauf via Fortran wrote: >> Dear all, >> >> when comparing formal and actual arguments of a procedure, there was no >> check of rank for derived types from intrinsic module ISO_C_BINDING. >> This could lead to a wrong resolution of generic procedures with dummy >> argument of related types, see PR.  This was likely an oversight. >> >> The attached fix is simple and regtests cleanly on x86_64-pc-linux-gnu. >> >> OK for mainline? >> >> Thanks, >> Harald >> > > Looks good to go. > > Jerry I actually found a flaw in the previous patch regarding the handling of rank, and also realized that a comparison of the types was missing for those from this intrinsic module (and found the related PR99982). I updated the patch accordingly and extended the testcase, see attached. Regtests cleanly on x86_64-pc-linux-gnu. Will wait for 24h for more comments. Thanks, Harald From 3fa9d2ee99afa38f42c267d17aed5266daa22dbc Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 11 Apr 2023 16:44:32 +0200 Subject: [PATCH] Fortran: resolve correct generic with TYPE(C_PTR) arguments [PR61615,PR99982] gcc/fortran/ChangeLog: PR fortran/61615 PR fortran/99982 * interface.cc (compare_parameter): Enable type and rank checks for arguments of derived type from the intrinsic module ISO_C_BINDING. gcc/testsuite/ChangeLog: PR fortran/61615 PR fortran/99982 * gfortran.dg/interface_49.f90: New test. --- gcc/fortran/interface.cc | 18 +++- gcc/testsuite/gfortran.dg/interface_49.f90 | 95 ++++++++++++++++++++++ 2 files changed, 112 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/interface_49.f90 diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index db79b104dc2..e9843e9549c 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -2361,7 +2361,23 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c && actual->ts.type == BT_DERIVED && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) - return true; + { + if (formal->ts.u.derived->intmod_sym_id + != actual->ts.u.derived->intmod_sym_id) + return false; + + if (ranks_must_agree + && symbol_rank (formal) != actual->rank + && symbol_rank (formal) != -1) + { + if (where) + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank, + NULL); + return false; + } + return true; + } if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) /* Make sure the vtab symbol is present when diff --git a/gcc/testsuite/gfortran.dg/interface_49.f90 b/gcc/testsuite/gfortran.dg/interface_49.f90 new file mode 100644 index 00000000000..aef5e0c6609 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_49.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! PR fortran/61615 - resolve correct generic with TYPE(C_PTR) arguments +! PR fortran/99982 - dto. with C_PTR and C_FUNPTR +! Contributed by Jacob Abel and Scot Breitenfeld + +MODULE foo + USE iso_c_binding, only : c_ptr, c_funptr + IMPLICIT NONE + integer :: rank = -99 + character(8) :: ctyp = "" + INTERFACE bar + MODULE PROCEDURE bar_s + MODULE PROCEDURE bar_a1d + MODULE PROCEDURE bar_a2d + MODULE PROCEDURE bar_fp + MODULE PROCEDURE bar_fp1 + MODULE PROCEDURE bar_fpx + END INTERFACE bar +CONTAINS + SUBROUTINE bar_s(a) + TYPE(c_ptr) :: a + WRITE (0, *) 'in bar_s' + rank = 0 + ctyp = "c_ptr" + END SUBROUTINE bar_s + + SUBROUTINE bar_a1d(a) + TYPE(c_ptr) :: a(:) + WRITE (0, *) 'in bar_a1d' + rank = 1 + ctyp = "c_ptr" + END SUBROUTINE bar_a1d + + SUBROUTINE bar_a2d(a) + TYPE(c_ptr) :: a(:,:) + WRITE (0, *) 'in bar_a2d' + rank = 2 + ctyp = "c_ptr" + END SUBROUTINE bar_a2d + + SUBROUTINE bar_fp(a) + TYPE(c_funptr) :: a + WRITE (0, *) 'in bar_fp' + rank = 0 + ctyp = "c_funptr" + END SUBROUTINE bar_fp + + SUBROUTINE bar_fp1(a) + TYPE(c_funptr) :: a(:) + WRITE (0, *) 'in bar_fp1' + rank = 1 + ctyp = "c_funptr" + END SUBROUTINE bar_fp1 + + SUBROUTINE bar_fpx(a, b) + TYPE(c_funptr) :: a(..) + TYPE(c_ptr) :: b + WRITE (0, *) 'in bar_fpx' + rank = -1 + ctyp = "c_funptr" + END SUBROUTINE bar_fpx +END MODULE foo + +PROGRAM cptr_array_vs_scalar_arg + USE foo + USE iso_c_binding, only : c_ptr, c_loc, c_funptr + IMPLICIT NONE + INTEGER, TARGET :: i + TYPE(c_ptr) :: a, b(1), c(1,1) + type(c_funptr) :: fp, fp1(1), fp2(1,1) + a = C_LOC(i) + b(1) = C_LOC(i) + CALL bar(a) + if (rank /= 0 .or. ctyp /= "c_ptr") stop 1 + CALL bar(b) + if (rank /= 1 .or. ctyp /= "c_ptr") stop 2 + CALL bar(c) + if (rank /= 2 .or. ctyp /= "c_ptr") stop 3 + rank = -99 + ctyp = "" + CALL bar((a)) + if (rank /= 0 .or. ctyp /= "c_ptr") stop 4 + CALL bar((b)) + if (rank /= 1 .or. ctyp /= "c_ptr") stop 5 + rank = -99 + ctyp = "" + CALL bar(fp) + if (rank /= 0 .or. ctyp /= "c_funptr") stop 6 + CALL bar(fp1) + if (rank /= 1 .or. ctyp /= "c_funptr") stop 7 + rank = -99 + ctyp = "" + CALL bar(fp2, a) + if (rank /= -1 .or. ctyp /= "c_funptr") stop 8 +END PROGRAM cptr_array_vs_scalar_arg -- 2.35.3