mirror/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2024-11-21 13:40:47 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran - Error compiling PDT Type-bound Procedures [PR82943/86148/86268]

Browse Source 
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. Lastly, it adds a check for deferred length parameters of
PDTs in CLASS declaration statements, and correctly throws an error if
such declarations are missing POINTER or ALLOCATABLE attributes.

2024-02-25  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.
	(resolve_pdt): Add a check for ALLOCATABLE and POINTER attributes for
	SPEC_DEFERRED parameters of PDT class symbols.  ALLOCATABLE and
	POINTER attributes for a PDT class symbol are stored in the
	'class_pointer' and 'allocatable' attributes of the '_data'
	component respectively.
	* symbol.cc (gfc_pdt_is_instance_of): New function.

gcc/testsuite/ChangeLog:
	PR fortran/82943
	PR fortran/86148
	PR fortran/86268
	* gfortran.dg/pdt_4.f03: Update modified error message.
	* 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>
This commit is contained in:
Alexander Westbrooks 2024-02-28 20:03:46 -06:00
parent fd52355aa5
commit edfe198084
9 changed files with 335 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/decl.cc
View File

@ -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 or
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)

1
gcc/fortran/gfortran.h
View File

@ -3586,6 +3586,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 *,

74
gcc/fortran/resolve.cc
View File

@ -14760,15 +14760,69 @@ resolve_typebound_procedure (gfc_symtree* stree)
goto error;
}
if (CLASS_DATA (me_arg)->ts.u.derived
!= resolve_bindings_derived)
/* 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,
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)
{
@ -15886,11 +15940,13 @@ resolve_pdt (gfc_symbol* sym)
else if (param->spec_type == SPEC_ASSUMED)
assumed_len_exprs = true;
if (param->spec_type == SPEC_DEFERRED
&& !attr->allocatable && !attr->pointer)
gfc_error ("The object %qs at %L has a deferred LEN "
"parameter %qs and is neither allocatable "
"nor a pointer", sym->name, &sym->declared_at,
if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
&& ((sym->ts.type == BT_DERIVED && !attr->pointer)
|| (sym->ts.type == BT_CLASS && !attr->class_pointer)))
gfc_error ("Entity %qs at %L has a deferred LEN "
"parameter %qs and requires either the POINTER "
"or ALLOCATABLE attribute",
sym->name, &sym->declared_at,
param->name);
}

27
gcc/fortran/symbol.cc
View File

@ -5172,6 +5172,33 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
return gfc_compare_derived_types (t1, t2);
}
/* Check if parameterized derived type t2 is an instance of pdt template t1
gfc_symbol *t1 -> pdt template to verify t2 against.
gfc_symbol *t2 -> pdt instance to be verified.
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 kind parameters. To verify if a PDT Type corresponds
to the template, this functions extracts t2's derive_type name,
and compares it to the derive_type name of t1 for compatibility.
For example:
t2->name = Pdtf_2_2; extract out the 'f' and compare with t1->name. */
bool
gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2)
{
if ( !t1->attr.pdt_template || !t2->attr.pdt_type )
return false;
/* Limit comparison to length of t1->name to ignore new kind params. */
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.

42
gcc/testsuite/gfortran.dg/pdt_34.f03 Normal file
View File

@ -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

45
gcc/testsuite/gfortran.dg/pdt_35.f03 Normal file
View File

@ -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

65
gcc/testsuite/gfortran.dg/pdt_36.f03 Normal file
View File

@ -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

74
gcc/testsuite/gfortran.dg/pdt_37.f03 Normal file
View File

@ -0,0 +1,74 @@
! { 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
implicit none
type :: param_deriv_type(a)
integer, len :: a
contains
procedure :: assumed_len_param ! Good. No error expected.
procedure :: assumed_len_param_ptr ! { dg-error "must not be POINTER" }
procedure :: assumed_len_param_alloc ! { dg-error "must not be ALLOCATABLE" }
procedure :: deferred_len_param ! { dg-error "must be ASSUMED" }
procedure :: deferred_len_param_ptr ! { dg-error "must be ASSUMED" }
procedure :: deferred_len_param_alloc ! { dg-error "must be ASSUMED" }
procedure :: fixed_len_param ! { dg-error "must be ASSUMED" }
procedure :: fixed_len_param_ptr ! { dg-error "must be ASSUMED" }
procedure :: fixed_len_param_alloc ! { dg-error "must be ASSUMED" }
end type
contains
subroutine assumed_len_param(this)
class(param_deriv_type(*)), intent(inout) :: this ! Good. No error expected.
! TYPE(param_deriv_type(*)), intent(inout) :: that ! Good. No error expected.
end subroutine
subroutine assumed_len_param_ptr(this, that)
class(param_deriv_type(*)), intent(inout), pointer :: this ! Good. No error expected.
TYPE(param_deriv_type(*)), intent(inout), allocatable :: that ! Good. No error expected.
end subroutine
subroutine assumed_len_param_alloc(this, that)
class(param_deriv_type(*)), intent(inout), allocatable :: this ! Good. No error expected.
TYPE(param_deriv_type(*)), intent(inout), allocatable :: that ! Good. No error expected.
end subroutine
subroutine deferred_len_param(this, that) ! { dg-error "requires either the POINTER or ALLOCATABLE attribute" }
class(param_deriv_type(:)), intent(inout) :: this
TYPE(param_deriv_type(:)), intent(inout) :: that ! Good. No error expected.
end subroutine
subroutine deferred_len_param_ptr(this, that)
class(param_deriv_type(:)), intent(inout), pointer :: this ! Good. No error expected.
TYPE(param_deriv_type(:)), intent(inout), pointer :: that ! Good. No error expected.
end subroutine
subroutine deferred_len_param_alloc(this, that)
class(param_deriv_type(:)), intent(inout), allocatable :: this ! Good. No error expected.
TYPE(param_deriv_type(:)), intent(inout), allocatable :: that ! Good. No error expected.
end subroutine
subroutine fixed_len_param(this, that)
class(param_deriv_type(10)), intent(inout) :: this ! Good. No error expected.
TYPE(param_deriv_type(10)), intent(inout) :: that ! Good. No error expected.
end subroutine
subroutine fixed_len_param_ptr(this, that)
class(param_deriv_type(10)), intent(inout), pointer :: this ! Good. No error expected.
TYPE(param_deriv_type(10)), intent(inout), pointer :: that ! Good. No error expected.
end subroutine
subroutine fixed_len_param_alloc(this, that)
class(param_deriv_type(10)), intent(inout), allocatable :: this ! Good. No error expected.
TYPE(param_deriv_type(10)), intent(inout), allocatable :: that ! Good. No error expected.
end subroutine
end module

2
gcc/testsuite/gfortran.dg/pdt_4.f03
View File

@ -96,7 +96,7 @@ contains
subroutine foo(arg)
type (mytype(4, *)) :: arg ! OK
end subroutine
subroutine bar(arg) ! { dg-error "is neither allocatable nor a pointer" }
subroutine bar(arg) ! { dg-error "requires either the POINTER or ALLOCATABLE attribute" }
type (thytype(8, :, 4)) :: arg
end subroutine
subroutine foobar(arg) ! OK