public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed
* PR82943 - Suggested patch to fix
@ 2023-06-24 17:17 Alexander Westbrooks
  2023-06-28 21:14 ` Harald Anlauf
  0 siblings, 1 reply; 19+ messages in thread
From: Alexander Westbrooks @ 2023-06-24 17:17 UTC (permalink / raw)
  To: fortran, gcc-patches


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

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-bug-patch-PR82943.patch --]
[-- Type: application/octet-stream, Size: 5842 bytes --]

From 77e3d46ea2e35e54056b721ebcbf430fa1b34b0b Mon Sep 17 00:00:00 2001
From: Alexander Westbrooks <ctechnodev@gmail.com>
Date: Sat, 24 Jun 2023 17:04:32 +0000
Subject: [PATCH] bug-patch - PR82943

This patch allows parameterized derived types to compile successfully
when typebound procedures are specified in the type specification.

This patch also 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.
---
 gcc/fortran/decl.cc    | 15 +++++++++++++++
 gcc/fortran/gfortran.h |  1 +
 gcc/fortran/resolve.cc | 36 ++++++++++++++++++++++++++++--------
 gcc/fortran/symbol.cc  | 29 +++++++++++++++++++++++++++++
 4 files changed, 73 insertions(+), 8 deletions(-)

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..6af55760321 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -14705,14 +14705,34 @@ 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))
+  {
+    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.
-- 
2.41.0


^ permalink raw reply	[flat|nested] 19+ messages in thread

end of thread, other threads:[~2024-01-21 20:55 UTC | newest]

Thread overview: 19+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-24 17:17 PR82943 - Suggested patch to fix Alexander Westbrooks
2023-06-28 21:14 ` Harald Anlauf
2023-06-28 21:14   ` Harald Anlauf
2023-06-30  3:38   ` Alexander Westbrooks
2023-06-30  4:42     ` Steve Kargl
2023-06-30  6:40       ` Paul Richard Thomas
2023-06-30  9:08         ` Paul Richard Thomas
2023-07-17 15:56     ` Alexander Westbrooks
2024-01-20 18:46     ` Alexander Westbrooks
2024-01-20 19:08       ` Jerry D
2024-01-20 19:52         ` Jerry D
2024-01-20 20:08         ` Harald Anlauf
2024-01-20 20:08           ` Harald Anlauf
2024-01-20 20:37           ` Jerry D
2024-01-20 21:40             ` Harald Anlauf
2024-01-20 21:40               ` Harald Anlauf
2024-01-20 22:42               ` Alexander Westbrooks
2024-01-21 20:55                 ` Harald Anlauf
2024-01-21 20:55                   ` Harald Anlauf

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