From 77e3d46ea2e35e54056b721ebcbf430fa1b34b0b Mon Sep 17 00:00:00 2001 From: Alexander Westbrooks 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