From 8e73afcf40a43a88c9e2ca5406570f0189e6d903 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 8 Jun 2019 15:52:38 +0000 Subject: [PATCH] re PR fortran/90786 (ICE on procedure pointer assignment to function with class pointer result) 2019-06-08 Paul Thomas PR fortran/90786 * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as it is very simple and only called from one place. (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign as non_proc_ptr_assign. Assign to it directly, rather than call to above, deleted function and use gfc_expr_attr instead of only checking the reference chain. 2019-06-08 Paul Thomas PR fortran/90786 * gfortran.dg/proc_ptr_51.f90 : New test. From-SVN: r272084 --- gcc/fortran/ChangeLog | 10 ++++++ gcc/fortran/trans-expr.c | 29 +++++------------ gcc/testsuite/ChangeLog | 7 ++++- gcc/testsuite/gfortran.dg/proc_ptr_51.f90 | 38 +++++++++++++++++++++++ 4 files changed, 61 insertions(+), 23 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_51.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 20fe2c38245..35e575a8d70 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2019-06-08 Paul Thomas + + PR fortran/90786 + * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as + it is very simple and only called from one place. + (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign + as non_proc_ptr_assign. Assign to it directly, rather than call + to above, deleted function and use gfc_expr_attr instead of + only checking the reference chain. + 2019-06-08 Thomas Koenig Tomáš Trnka diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d23520fdbaa..dc173a00b11 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4881,7 +4881,7 @@ class_array_fcn: parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); /* Basically make this into - + if (present) { if (contiguous) @@ -8979,23 +8979,6 @@ trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1, } } -/* Indentify class valued proc_pointer assignments. */ - -static bool -pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2) -{ - gfc_ref * ref; - - ref = expr1->ref; - while (ref && ref->next) - ref = ref->next; - - return ref && ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer - && expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE; -} - /* Do everything that is needed for a CLASS function expr2. */ @@ -9048,7 +9031,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) tree desc; tree tmp; tree expr1_vptr = NULL_TREE; - bool scalar, non_proc_pointer_assign; + bool scalar, non_proc_ptr_assign; gfc_ss *ss; gfc_start_block (&block); @@ -9056,7 +9039,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&lse, NULL); /* Usually testing whether this is not a proc pointer assignment. */ - non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2); + non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer + && expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE); /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ @@ -9066,7 +9051,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_free_ss_chain (ss); if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS - && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign) + && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign) { gfc_add_data_component (expr2); /* The following is required as gfc_add_data_component doesn't @@ -9086,7 +9071,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) else gfc_conv_expr (&rse, expr2); - if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS) + if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS) { trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a2012ae73af..df3d0061b50 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-06-08 Paul Thomas + + PR fortran/90786 + * gfortran.dg/proc_ptr_51.f90 : New test. + 2019-06-08 Marek Polacek PR c++/52269 @@ -57,7 +62,7 @@ * gfortran.dg/fmt_f_default_field_width_3.f90: Modify dg-error to allow use when kind=16 is not supported. * gfortran.dg/fmt_g_default_field_width_3.f90: Modify dg-error - to allow use when kind=16 is not supported. + to allow use when kind=16 is not supported. 2019-06-07 Richard Biener diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_51.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_51.f90 new file mode 100644 index 00000000000..62b5d71e30b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_51.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR90786. +! +! Contributed by Andrew benson +! +module f +procedure(c), pointer :: c_ + + type :: s + integer :: i = 42 + end type s + class(s), pointer :: res, tgt + +contains + + function c() + implicit none + class(s), pointer :: c + c => tgt + return + end function c + + subroutine fs() + implicit none + c_ => c ! This used to ICE + return + end subroutine fs + +end module f + + use f + allocate (tgt, source = s(99)) + call fs() + res => c_() + if (res%i .ne. 99) stop 1 + deallocate (tgt) +end -- 2.30.2