This patch fixes PRs 93924/5. It is another 'obvious' patch, whose
consequences are very limited.
I am trying to slip in as many small ready-to-go patches as I can before we
go too far into stage 4. It would be nice to have the patch for PR98573
(posted 23rd Jan) OK'd before the end of the week.
Cheers
Paul
Fortran: Fix ICE due to elemental procedure pointers [PR93924/5].
2021-01-27 Paul Thomas <pa...@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.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7150e48bc93..b0c8d577ca5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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)
! { dg-do run }
!
! Test the fix for PRs93924 & 93925.
!
! Contributed by Martin Stein <ms...@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
