Re: PR82943 - Suggested patch to fix

[Alexander Westbrooks <ctechnodev@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 4236 bytes --]

Hello,

I have finished my testing, and updated my patch and relevant Changelogs. I
added 4 new tests and all the existing tests in the current testsuite
for gfortran passed or failed as expected. Do I need to attach the test
results here?

The platform I tested on was a Docker container running in Docker Desktop,
running the "mcr.microsoft.com/devcontainers/universal:2-linux" image.

I also made sure that my code changes followed the coding standards. Please
let me know if there is anything else that I need to do. I don't have
write-access to the repository.

Thanks,

Alexander

On Wed, Jun 28, 2023 at 4:14 PM Harald Anlauf <anlauf@gmx.de> wrote:

> Hi Alex,
>
> welcome to the gfortran community.  It is great that you are trying
> to get actively involved.
>
> You already did quite a few things right: patches shall be sent to
> the gcc-patches ML, but Fortran reviewers usually notice them only
> where they are copied to the fortran ML.
>
> There are some general recommendations on the formatting of C code,
> like indentation, of the patches, and of the commit log entries.
>
> Regarding coding standards, see https://www.gnu.org/prep/standards/ .
>
> Regarding testcases, a recommendation is to have a look at
> existing testcases, e.g. in gcc/testsuite/gfortran.dg/, and then
> decide if the testcase shall test the compile-time or run-time
> behaviour, and add the necessary dejagnu directives.
>
> You should also verify if your patch passes regression testing.
> For changes to gfortran, it is usually sufficient to run
>
> make check-fortran -j <n>
>
> where <n> is the number of parallel tests.
> You would need to report also the platform where you tested on.
>
> There is also a legal issue to consider before non-trivial patches can
> be accepted for incorporation: https://gcc.gnu.org/contribute.html#legal
>
> If your patch is accepted and if you do not have write-access to the
> repository, one of the maintainers will likely take care of it.
> If you become a regular contributor, you will probably want to consider
> getting write access.
>
> Cheers,
> Harald
>
>
>
> On 6/24/23 19:17, Alexander Westbrooks via Gcc-patches wrote:
> > Hello,
> >
> > I am new to the GFortran community. Over the past two weeks I created a
> > patch that should fix PR82943 for GFortran. I have attached it to this
> > email. The patch allows the code below to compile successfully. I am
> > working on creating test cases next, but I am new to the process so it
> may
> > take me some time. After I make test cases, do I email them to you as
> well?
> > Do I need to make a pull-request on github in order to get the patch
> > reviewed?
> >
> > Thank you,
> >
> > 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
>
>

[-- Attachment #2: 0001-Fix-fortran-PR82943-PR86148-and-PR86268.patch --]
[-- Type: application/octet-stream, Size: 16235 bytes --]

From dd6903d7a6ee75918f14ca8469bc6ec2b2e76349 Mon Sep 17 00:00:00 2001
From: Alexander Westbrooks <ctechnodev@gmail.com>
Date: Fri, 30 Jun 2023 03:27:54 +0000
Subject: [PATCH] Fix fortran/PR82943, PR86148, and PR86268

2023-06-29  Alexander Westbrooks  <ctechnodev@gmail.com>

	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_get_pdt_isntance): 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.

2023-06-29  Alexander Westbrooks  <ctechnodev@gmail.com>

	PR fortran/82943
	PR fortran/86148
	PR fortran/86268

	* gfortran.dg/pdt_33.f03: New test.
	* gfortran.dg/pdt_34.f03: Likewise.
	* gfortran.dg/pdt_35.f03: Likewise.
	* gfortran.dg/pdt_36.f03: Likewise.
---
 gcc/fortran/ChangeLog                | 27 +++++++++++
 gcc/fortran/decl.cc                  | 15 ++++++
 gcc/fortran/gfortran.h               |  1 +
 gcc/fortran/resolve.cc               | 68 ++++++++++++++++++++++++----
 gcc/fortran/symbol.cc                | 29 ++++++++++++
 gcc/testsuite/ChangeLog              | 11 +++++
 gcc/testsuite/gfortran.dg/pdt_33.f03 | 43 ++++++++++++++++++
 gcc/testsuite/gfortran.dg/pdt_34.f03 | 45 ++++++++++++++++++
 gcc/testsuite/gfortran.dg/pdt_35.f03 | 65 ++++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/pdt_36.f03 | 34 ++++++++++++++
 10 files changed, 330 insertions(+), 8 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pdt_33.f03
 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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 859bd72b22b..f7d22c6f49c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+2023-06-29  Alexander Westbrooks  <ctechnodev@gmail.com>
+
+	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_get_pdt_isntance): 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.
+
 2023-06-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* f95-lang.cc (gfc_init_builtin_functions): Add fmax() and
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index d09c8bc97d9..9043a4d427f 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4063,6 +4063,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 a58c60e9828..6854edb3467 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3536,6 +3536,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 50b49d0cb83..cb34db51be8 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -14705,14 +14705,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 37a9e8fa0ae..77f84de0989 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -5134,6 +5134,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/ChangeLog b/gcc/testsuite/ChangeLog
index 6a53230648d..82f2b85fff1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2023-06-29  Alexander Westbrooks  <ctechnodev@gmail.com>
+
+	PR fortran/82943
+	PR fortran/86148
+	PR fortran/86268
+
+	* gfortran.dg/pdt_33.f03: New test.
+	* gfortran.dg/pdt_34.f03: Likewise.
+	* gfortran.dg/pdt_35.f03: Likewise.
+	* gfortran.dg/pdt_36.f03: Likewise.
+
 2023-06-12  Gaius Mulley  <gaiusmod2@gmail.com>
 
 	PR modula2/110189
diff --git a/gcc/testsuite/gfortran.dg/pdt_33.f03 b/gcc/testsuite/gfortran.dg/pdt_33.f03
new file mode 100644
index 00000000000..068e4544db5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_33.f03
@@ -0,0 +1,43 @@
+! { dg-do compile }
+!
+! Tests the fixes for PR82943.
+!
+! Contributed by Alexander Westbrooks  <ctechnodev@gmail.com>
+!
+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_34.f03 b/gcc/testsuite/gfortran.dg/pdt_34.f03
new file mode 100644
index 00000000000..8b99948fa73
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_34.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  <ctechnodev@gmail.com>
+!
+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_35.f03 b/gcc/testsuite/gfortran.dg/pdt_35.f03
new file mode 100644
index 00000000000..a351c0e4f8b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_35.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  <ctechnodev@gmail.com>
+!
+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_36.f03 b/gcc/testsuite/gfortran.dg/pdt_36.f03
new file mode 100644
index 00000000000..751a20c1fa7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_36.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  <ctechnodev@gmail.com>
+!
+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
+
+end module
+ 
\ No newline at end of file
-- 
2.41.0