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