public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* [PATCH] Fortran - Error compiling PDT Type-bound Procedures [PR82943/86148/86268]
@ 2024-02-10 23:27 Alexander Westbrooks
  2024-02-11 20:11 ` Harald Anlauf
  0 siblings, 1 reply; 7+ messages in thread
From: Alexander Westbrooks @ 2024-02-10 23:27 UTC (permalink / raw)
  To: gcc-patches, fortran

[-- Attachment #1: Type: text/plain, Size: 15012 bytes --]

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 <alexanderw@gcc.gnu.org>
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  <alexanderw@gcc.gnu.org>

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 <alexanderw@gcc.gnu.org>
---
 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

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  <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_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  <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_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  <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_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  <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
+
-- 
2.25.1

^ permalink raw reply	[flat|nested] 7+ messages in thread
end of thread, other threads:[~2024-02-29  2:49 UTC | newest]

Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-02-10 23:27 [PATCH] Fortran - Error compiling PDT Type-bound Procedures [PR82943/86148/86268] Alexander Westbrooks
2024-02-11 20:11 ` Harald Anlauf
2024-02-25 20:40   ` Alexander Westbrooks
2024-02-28  6:24     ` Alexander Westbrooks
2024-02-28 19:55       ` Harald Anlauf
2024-02-29  2:24         ` Alexander Westbrooks
2024-02-29  2:48           ` Alexander Westbrooks

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).