From patchwork Sat Feb 10 23:27:45 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Alexander Westbrooks X-Patchwork-Id: 1897406 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256 header.s=20230601 header.b=DA6WfECE; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4TXRjv2Hj0z23fc for ; Sun, 11 Feb 2024 10:28:33 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 0F7033858410 for ; Sat, 10 Feb 2024 23:28:30 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-ej1-x633.google.com (mail-ej1-x633.google.com [IPv6:2a00:1450:4864:20::633]) by sourceware.org (Postfix) with ESMTPS id EDB5E3858D20; Sat, 10 Feb 2024 23:27:59 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org EDB5E3858D20 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmail.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmail.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org EDB5E3858D20 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::633 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1707607684; cv=none; b=xntJu6JGqVQ7Csmsa/RTWZZz9QwMviCVu0r3H09m/sm3k1kSkDGwZaKvfbucpL4Ww2rP5ZbwyRzOZQWTpy0fTj6rnmJShvmqqzb9Mk398Z8ulnBEvTRJN/iodaojTtpYSXwIFyhetNcEq1wVbLMqC01cgpi49BEWbwLtCdIx3NM= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1707607684; c=relaxed/simple; bh=uq73b9PWAVUm3HyLtdJ3E8zptwPmLaHXc0EA80YdaCg=; h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To; b=EJgZo36LY0AJ/WkdGC717mxebjZxgPJkg5vAhI6Gok7tqd3beSSDcd6XhsF20OPLVW9qoIam9xEjy2/mP1GUVIHzjXwB1yND+3lZczHZWyulcBqvv7KtUqAsZorJUOYyiCLFo6mew8SV7/WfmFSepImKsw40GdQyod+if8nH2lU= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-ej1-x633.google.com with SMTP id a640c23a62f3a-a3916c1f9b0so284667566b.1; Sat, 10 Feb 2024 15:27:59 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1707607678; x=1708212478; darn=gcc.gnu.org; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=T8sNjOTh9gBGJyBi69+GYga96vNxNlgsVo9Yh0Q/Vnw=; b=DA6WfECETxfwlULjV7nR/mfge8DQLl5iwC49kmtvpv+lj9ieb6Qvqn2VpyE1MKSAkq 45KY6enu6sOb+nHss/to3sSlT4fgkHOmBPzTdBa+QCvsXFjQ+pp3LvFVw4/jhH4+443D 4XXSHz6Ws0slD4dIj0kCCAKJXc9Q0qHRIBRMzv59vWUaV1Ob46/IbQ6WoDH+wtvo12Mp /gfzw75MSrrMZm/vgr0K+sgitRipbiqxTcGuEuMcV1y++aACJamXkFpbD+toBbZ70h2d 6BmvgzaE5cSQeildShGB4o3sNbE4m7vo7OV/k7MRyu1Hi9Zyu5JywMLMXr/8E3MZhg7U igjg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1707607678; x=1708212478; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=T8sNjOTh9gBGJyBi69+GYga96vNxNlgsVo9Yh0Q/Vnw=; b=le58WZIcHV82Au8cjBBoxqocphyTj+TbCSjFY4HrHy/VnK8drg27/pvWX8EIkaHGUY RkSAWBcWR2424zLRkvbXoUH0xkC/9bzuYvmwk+jlyuBZLRp4lrQ7mpEq01takrKZsHGs QG06Ye3cURVggvdt3S31TGjOmdrCIhAAGBdQ4XimZFn1rUTXIO8Ds4iHL/l+Btq3Zv8s tKoOcRhGAdrXRaCJQ8YgBKuA1DUaLU/5dRn4khMcylGrzpX8UVBejeCQzn1Qfg65k6Qi gKC3+Iw1A66G46f5paYs+8zjQbHVsbzWMUB13VE8+y7isIvLDaeLtmj54NWsZOO7a6/E 1viw== X-Gm-Message-State: AOJu0YztcyLtzj1JNg0qrEbZsaKNwq/T2pdIKDQKoXJMkl/Xh6UhpYnO GepMuxTiBMWWpKXmsax15TATR0lDctMbPydqO94n+T5hEsUSvXRRDq5pWvB6+bMPS37qdrOCYYs T/V/fjPUneBvUAub7gLVAIssiV6x7xutP X-Google-Smtp-Source: AGHT+IH74VAy+4n1ghZETiyJIcbzVwuSdztbZgpJbX/WUkJQWhjU9RVaN4/N7Doz9btZDGALEjgaJ6FLgaCAC3heRBY= X-Received: by 2002:a17:906:3395:b0:a3a:3c8c:fc06 with SMTP id v21-20020a170906339500b00a3a3c8cfc06mr2152636eja.38.1707607678019; Sat, 10 Feb 2024 15:27:58 -0800 (PST) MIME-Version: 1.0 From: Alexander Westbrooks Date: Sat, 10 Feb 2024 17:27:45 -0600 Message-ID: Subject: [PATCH] Fortran - Error compiling PDT Type-bound Procedures [PR82943/86148/86268] To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org X-Spam-Status: No, score=-6.8 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, RCVD_IN_DNSWL_NONE, SCC_5_SHORT_WORD_LINES, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Hello, I have implemented a patch that fixes compile time errors for valid PDT type-bound procedures. I wrote 4 new tests that address the test-cases in PR 82943, PR 86148, and PR 86268, since the patch fixes all three of them. All regression tests pass, including the new ones. This was tested on WSL 2, with Ubuntu 20.04 distro. Is this okay to push to the trunk? Alexander Westbrooks >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> From 100508673ae26d7fa4ae4f976b4542e115fc7b45 Mon Sep 17 00:00:00 2001 From: Alexander Westbrooks Date: Sat, 10 Feb 2024 13:19:08 -0600 Subject: [PATCH] Fortran - Error compiling PDT Type-bound Procedures [PR82943/86148/86268] This patch allows parameterized derived types to compile successfully when typebound procedures are specified in the type specification. Furthermore, it allows function calls for PDTs by setting the f2k_derived space of PDT instances to reference their original template, thereby giving it referential access to the typebound procedures of the template. 2024-02-10 Alexander Westbrooks gcc/fortran/ChangeLog: PR fortran/82943 PR fortran/86148 PR fortran/86268 * decl.cc (gfc_get_pdt_instance): Set the PDT instance field 'f2k_derived', if not set already, to point to the given PDT template 'f2k_derived' namespace in order to give the PDT instance referential access to the typebound procedures of the template. * gfortran.h (gfc_pdt_is_instance_of): Add prototype. * resolve.cc (resolve_typebound_procedure): If the derived type does not have the attribute 'pdt_template' set, compare the dummy argument to the 'resolve_bindings_derived' type like usual. If the derived type is a 'pdt_template', then check if the dummy argument is an instance of the PDT template. If the derived type is a PDT template, and the dummy argument is an instance of that template, but the dummy argument 'param_list' is not SPEC_ASSUMED, check if there are any LEN parameters in the dummy argument. If there are no LEN parameters, then this implies that there are only KIND parameters in the dummy argument. If there are LEN parameters, this would be an error, for all LEN parameters for the dummy argument MUST be assumed for typebound procedures of PDTs. * symbol.cc (gfc_pdt_is_instance_of): New function. gcc/testsuite/ChangeLog: PR fortran/82943 PR fortran/86148 PR fortran/86268 * gfortran.dg/pdt_34.f03: New test. * gfortran.dg/pdt_35.f03: New test. * gfortran.dg/pdt_36.f03: New test. * gfortran.dg/pdt_37.f03: New test. Signed-off-by: Alexander Westbrooks --- gcc/fortran/decl.cc | 15 ++++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/resolve.cc | 68 ++++++++++++++++++++++++---- gcc/fortran/symbol.cc | 29 ++++++++++++ gcc/testsuite/gfortran.dg/pdt_34.f03 | 42 +++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_35.f03 | 45 ++++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_36.f03 | 65 ++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_37.f03 | 34 ++++++++++++++ 8 files changed, 291 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_34.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_35.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_36.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_37.f03 + +end module + diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 503ecb8d9b5..c29b2bb0f45 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4083,6 +4083,21 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, continue; } + /* + Addressing PR82943, this will fix the issue where a function/subroutine is declared as not + a member of the PDT instance. The reason for this is because the PDT instance did not have + access to its template's f2k_derived namespace in order to find the typebound procedures. + + The number of references to the PDT template's f2k_derived will ensure that f2k_derived is + properly freed later on. + */ + + if (!instance->f2k_derived && pdt->f2k_derived) + { + instance->f2k_derived = pdt->f2k_derived; + instance->f2k_derived->refs++; + } + /* Set the component kind using the parameterized expression. */ if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER) && c1->kind_expr != NULL) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fd73e4ce431..25ff19a6e44 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3585,6 +3585,7 @@ void gfc_traverse_gsymbol (gfc_gsymbol *, void (*)(gfc_gsymbol *, void *), void gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*); gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *); +bool gfc_pdt_is_instance_of(gfc_symbol *, gfc_symbol *); bool gfc_type_compatible (gfc_typespec *, gfc_typespec *); void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *, diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 44f89f6afb4..6de8ac0a307 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -14760,14 +14760,66 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - if (CLASS_DATA (me_arg)->ts.u.derived - != resolve_bindings_derived) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" - " the derived-type %qs", me_arg->name, proc->name, - me_arg->name, &where, resolve_bindings_derived->name); - goto error; - } + /* The derived type is not a PDT template. Resolve as usual. */ + if ( !resolve_bindings_derived->attr.pdt_template + && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived)) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived-type %qs", me_arg->name, proc->name, + me_arg->name, &where, resolve_bindings_derived->name); + goto error; + } + + if ( resolve_bindings_derived->attr.pdt_template && + !gfc_pdt_is_instance_of(resolve_bindings_derived, + CLASS_DATA(me_arg)->ts.u.derived)) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the parametric derived-type %qs", me_arg->name, proc->name, + me_arg->name, &where, resolve_bindings_derived->name); + goto error; + } + + if ( resolve_bindings_derived->attr.pdt_template + && gfc_pdt_is_instance_of(resolve_bindings_derived, + CLASS_DATA(me_arg)->ts.u.derived) + && (me_arg->param_list != NULL) + && (gfc_spec_list_type(me_arg->param_list, CLASS_DATA(me_arg)->ts.u.derived) + != SPEC_ASSUMED)) + { + + /* + Add a check to verify if there are any LEN parameters in the first place. + If there are LEN parameters, throw this error. If there are only KIND + parameters, then don't trigger this error. + */ + gfc_component *c; + bool seen_len_param = false; + gfc_actual_arglist *me_arg_param = me_arg->param_list; + + for (; me_arg_param; me_arg_param = me_arg_param->next) + { + c = gfc_find_component( + CLASS_DATA(me_arg)->ts.u.derived, + me_arg_param->name, + true, true, NULL); + + gcc_assert (c != NULL); + if (c->attr.pdt_kind) + continue; + + // Getting here implies that there is a pdt_len parameter in the list. + seen_len_param = true; + break; + } + + if (seen_len_param) + { + gfc_error ("All LEN type parameters of the passed dummy argument %qs" + " of %qs at %L must be ASSUMED.", me_arg->name, proc->name, &where); + goto error; + } + } gcc_assert (me_arg->ts.type == BT_CLASS); if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index fddf68f8398..11f4bac0415 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5172,6 +5172,35 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) return gfc_compare_derived_types (t1, t2); } +/* Check if a parameterized derived type t2 is an instance of a PDT template t1 */ + +bool +gfc_pdt_is_instance_of(gfc_symbol *t1, gfc_symbol *t2) +{ + if ( !t1->attr.pdt_template || !t2->attr.pdt_type ) + return false; + + /* + in decl.cc, gfc_get_pdt_instance, a pdt instance is given a 3 character prefix "Pdt", followed + by an underscore list of the kind parameters, up to a maximum of 8. + + So to check if a PDT Type corresponds to the template, extract the core derive_type name, + and then see if it is type compatible by name... + + For example: + + Pdtf_2_2 -> extract out the 'f' -> see if the derived type 'f' is compatible with symbol t1 + */ + + // Starting at index 3 of the string in order to skip past the 'Pdt' prefix + // Also, here the length of the template name is used in order to avoid the + // kind parameter suffixes that are placed at the end of PDT instance names. + if ( !(strncmp(&(t2->name[3]), t1->name, strlen(t1->name)) == 0) ) + return false; + + return true; +} + /* Check if two typespecs are type compatible (F03:5.1.1.2): If ts1 is nonpolymorphic, ts2 must be the same type. diff --git a/gcc/testsuite/gfortran.dg/pdt_34.f03 b/gcc/testsuite/gfortran.dg/pdt_34.f03 new file mode 100644 index 00000000000..c601071ba3a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_34.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! Tests the fixes for PR82943. +! +! Contributed by Alexander Westbrooks +! +module m + public :: foo, bar, foobar + + type, public :: good_type(n) + integer, len :: n = 1 + contains + procedure :: foo + end type + + type, public :: good_type2(k) + integer, kind :: k = 1 + contains + procedure :: bar + end type + + type, public :: good_type3(n, k) + integer, len :: n = 1 + integer, kind :: k = 1 + contains + procedure :: foobar + end type + + contains + subroutine foo(this) + class(good_type(*)), intent(inout) :: this + end subroutine + + subroutine bar(this) + class(good_type2(2)), intent(inout) :: this + end subroutine + + subroutine foobar(this) + class(good_type3(*,2)), intent(inout) :: this + end subroutine + + end module \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/pdt_35.f03 b/gcc/testsuite/gfortran.dg/pdt_35.f03 new file mode 100644 index 00000000000..8b99948fa73 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_35.f03 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +! Tests the fixes for PR82943. +! +! This test focuses on inheritance for the type bound procedures. +! +! Contributed by Alexander Westbrooks +! +module m + + public :: foo, bar, foobar + + type, public :: goodpdt_lvl_0(a, b) + integer, kind :: a = 1 + integer, len :: b + contains + procedure :: foo + end type + + type, public, EXTENDS(goodpdt_lvl_0) :: goodpdt_lvl_1 (c) + integer, len :: c + contains + procedure :: bar + end type + + type, public, EXTENDS(goodpdt_lvl_1) :: goodpdt_lvl_2 (d) + integer, len :: d + contains + procedure :: foobar + end type + +contains + subroutine foo(this) + class(goodpdt_lvl_0(1,*)), intent(inout) :: this + end subroutine + + subroutine bar(this) + class(goodpdt_lvl_1(1,*,*)), intent(inout) :: this + end subroutine + + subroutine foobar(this) + class(goodpdt_lvl_2(1,*,*,*)), intent(inout) :: this + end subroutine + +end module \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/pdt_36.f03 b/gcc/testsuite/gfortran.dg/pdt_36.f03 new file mode 100644 index 00000000000..a351c0e4f8b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_36.f03 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Tests the fixes for PR82943. +! +! This test focuses on calling the type bound procedures in a program. +! +! Contributed by Alexander Westbrooks +! +module testmod + + public :: foo + + type, public :: tough_lvl_0(a, b) + integer, kind :: a = 1 + integer, len :: b + contains + procedure :: foo + end type + + type, public, EXTENDS(tough_lvl_0) :: tough_lvl_1 (c) + integer, len :: c + contains + procedure :: bar + end type + + type, public, EXTENDS(tough_lvl_1) :: tough_lvl_2 (d) + integer, len :: d + contains + procedure :: foobar + end type + +contains + subroutine foo(this) + class(tough_lvl_0(1,*)), intent(inout) :: this + end subroutine + + subroutine bar(this) + class(tough_lvl_1(1,*,*)), intent(inout) :: this + end subroutine + + subroutine foobar(this) + class(tough_lvl_2(1,*,*,*)), intent(inout) :: this + end subroutine + +end module + +PROGRAM testprogram + USE testmod + + TYPE(tough_lvl_0(1,5)) :: test_pdt_0 + TYPE(tough_lvl_1(1,5,6)) :: test_pdt_1 + TYPE(tough_lvl_2(1,5,6,7)) :: test_pdt_2 + + CALL test_pdt_0%foo() + + CALL test_pdt_1%foo() + CALL test_pdt_1%bar() + + CALL test_pdt_2%foo() + CALL test_pdt_2%bar() + CALL test_pdt_2%foobar() + + +END PROGRAM testprogram + \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/pdt_37.f03 b/gcc/testsuite/gfortran.dg/pdt_37.f03 new file mode 100644 index 00000000000..68d376fad25 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_37.f03 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! Tests the fixes for PR82943. +! +! This test focuses on the errors produced by incorrect LEN parameters for dummy +! arguments of PDT Typebound Procedures. +! +! Contributed by Alexander Westbrooks +! +module test_len_param + + type :: param_deriv_type(a) + integer, len :: a + contains + procedure :: assumed_len_param ! Good. No error expected. + procedure :: deferred_len_param ! { dg-error "All LEN type parameters of the passed dummy argument" } + procedure :: fixed_len_param ! { dg-error "All LEN type parameters of the passed dummy argument" } + end type + +contains + subroutine assumed_len_param(this) + class(param_deriv_type(*)), intent(inout) :: this + end subroutine + + subroutine deferred_len_param(this) + class(param_deriv_type(:)), intent(inout) :: this + end subroutine + + subroutine fixed_len_param(this) + class(param_deriv_type(10)), intent(inout) :: this + end subroutine