From 4225af228b5d52e8d7593dea49584c91b4bc2e1f Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Wed, 27 Jan 2021 11:34:02 +0000 Subject: [PATCH] Fortran: Fix ICE due to elemental procedure pointers [PR93924/5]. 2021-01-27 Paul Thomas 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. --- gcc/fortran/trans-expr.c | 6 +- gcc/testsuite/gfortran.dg/proc_ptr_52.f90 | 72 +++++++++++++++++++++++ 2 files changed, 76 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_52.f90 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) diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 new file mode 100644 index 00000000000..cb7cf7040a9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! +! Test the fix for PRs93924 & 93925. +! +! Contributed by Martin Stein +! +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 -- 2.30.2