From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id 6EF7A3858D34; Sat, 28 Aug 2021 19:57:20 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 6EF7A3858D34 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r10-10077] Fortran: Fix ICE due to elemental procedure pointers [PR93924/5]. X-Act-Checkin: gcc X-Git-Author: Paul Thomas X-Git-Refname: refs/heads/releases/gcc-10 X-Git-Oldrev: 803918dc6da9b7c88cc97635fc8a21bbd805a120 X-Git-Newrev: bf22e268b5c2a03216503254cfcb828016a7d998 Message-Id: <20210828195720.6EF7A3858D34@sourceware.org> Date: Sat, 28 Aug 2021 19:57:20 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 28 Aug 2021 19:57:20 -0000 https://gcc.gnu.org/g:bf22e268b5c2a03216503254cfcb828016a7d998 commit r10-10077-gbf22e268b5c2a03216503254cfcb828016a7d998 Author: Paul Thomas Date: Wed Jan 27 11:34:02 2021 +0000 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. (cherry picked from commit 4225af228b5d52e8d7593dea49584c91b4bc2e1f) Diff: --- gcc/fortran/trans-expr.c | 6 ++- gcc/testsuite/gfortran.dg/proc_ptr_52.f90 | 72 +++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 2 deletions(-) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index dbe6344db99..e2e0946bf09 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5771,7 +5771,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. */ @@ -11045,7 +11046,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