Fortran: Fix calls to associate name typebound subroutines [PR98897].

2021-02-11  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/98897
	* match.c (gfc_match_call): Include associate names as possible
	entities with typebound subroutines. The target needs to be
	resolved for the type.

gcc/testsuite/
	PR fortran/98897
	* gfortran.dg/typebound_call_32.f90: New test.
This commit is contained in:
Paul Thomas 2021-02-11 13:24:50 +00:00
parent 22a6d99d0a
commit ff6903288d
2 changed files with 49 additions and 4 deletions

View File

@ -4999,10 +4999,16 @@ gfc_match_call (void)
sym = st->n.sym;
/* If this is a variable of derived-type, it probably starts a type-bound
procedure call. */
if ((sym->attr.flavor != FL_PROCEDURE
|| gfc_is_function_return_value (sym, gfc_current_ns))
&& (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
procedure call. Associate variable targets have to be resolved for the
target type. */
if (((sym->attr.flavor != FL_PROCEDURE
|| gfc_is_function_return_value (sym, gfc_current_ns))
&& (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
||
(sym->assoc && sym->assoc->target
&& gfc_resolve_expr (sym->assoc->target)
&& (sym->assoc->target->ts.type == BT_DERIVED
|| sym->assoc->target->ts.type == BT_CLASS)))
return match_typebound_call (st);
/* If it does not seem to be callable (include functions so that the

View File

@ -0,0 +1,39 @@
! { dg-do run }
!
! Test the fix for PR98897 in which typebound subroutines of associate names
! were not recognised in a call. Functions were OK but this is tested below.
!
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
!
module output_data_m
implicit none
type output_data_t
integer, private :: i = 0
contains
procedure output, return_value
end type
contains
subroutine output(self)
implicit none
class(output_data_t) self
self%i = 1234
end subroutine
integer function return_value(self)
implicit none
class(output_data_t) self
return_value = self%i
end function
end module
use output_data_m
implicit none
associate(output_data => output_data_t())
call output_data%output
if (output_data%return_value() .ne. 1234) stop 1
end associate
end