OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fortran: Fix ICE due to elemental procedure pointers [PR93924/5].

Browse Source 
2021-01-27  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/93924
	PR fortran/93925
	* trans-expr.c (gfc_conv_procedure_call): Suppress the call to
	gfc_conv_intrinsic_to_class for unlimited polymorphic procedure
	pointers.
	(gfc_trans_assignment_1): Similarly suppress class assignment
	for class valued procedure pointers.

gcc/testsuite/
	PR fortran/93924
	PR fortran/93925
	* gfortran.dg/proc_ptr_52.f90 : New test.
This commit is contained in:
Paul Thomas 2021-01-27 11:34:02 +00:00
parent 686b1cdfdc
commit 4225af228b
2 changed files with 76 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/trans-expr.c
View File

@ -5772,7 +5772,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
}
else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
&& gfc_expr_attr (e).flavor != FL_PROCEDURE)
{
/* The intrinsic type needs to be converted to a temporary
CLASS object for the unlimited polymorphic formal. */
@ -11068,7 +11069,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_class_array_ref (expr1, NULL)
|| gfc_is_class_scalar_expr (expr1)
|| gfc_is_class_array_ref (expr2, NULL)
|| gfc_is_class_scalar_expr (expr2));
|| gfc_is_class_scalar_expr (expr2))
&& lhs_attr.flavor != FL_PROCEDURE;
realloc_flag = flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)

72
gcc/testsuite/gfortran.dg/proc_ptr_52.f90 Normal file
View File

@ -0,0 +1,72 @@
! { dg-do run }
!
! Test the fix for PRs93924 & 93925.
!
! Contributed by Martin Stein <mscfd@gmx.net>
!
module cs
implicit none
integer, target :: integer_target
abstract interface
function classStar_map_ifc(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
end function classStar_map_ifc
end interface
contains
function fun(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
select type (x)
type is (integer)
integer_target = x ! Deals with dangling target.
y => integer_target
class default
y => null()
end select
end function fun
function apply(f, x) result(y)
procedure(classStar_map_ifc) :: f
integer, intent(in) :: x
integer :: y
class(*), pointer :: p
y = 0 ! Get rid of 'y' undefined warning
p => f (x)
select type (p)
type is (integer)
y = p
end select
end function apply
function selector() result(f)
procedure(classStar_map_ifc), pointer :: f
f => fun
end function selector
end module cs
program classStar_map
use cs
implicit none
integer :: x, y
procedure(classStar_map_ifc), pointer :: f
x = 123654
f => selector () ! Fixed by second chunk in patch
y = apply (f, x) ! Fixed by first chunk in patch
if (x .ne. y) stop 1
x = 2 * x
y = apply (fun, x) ! PR93925; fixed as above
if (x .ne. y) stop 2
end program classStar_map