Committed as obvious in revision 272084.
The problem was that the lhs symbol itself was not being checked as a
proc_pointer - just the expression component.
I will get on with backporting tomorrow.
Cheers
Paul
2019-06-08 Paul Thomas <pa...@gcc.gnu.org>
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 <pa...@gcc.gnu.org>
PR fortran/90786
* gfortran.dg/proc_ptr_51.f90 : New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 272076)
--- gcc/fortran/trans-expr.c (working copy)
*************** class_array_fcn:
*** 4881,4887 ****
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
/* Basically make this into
!
if (present)
{
if (contiguous)
--- 4881,4887 ----
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
/* Basically make this into
!
if (present)
{
if (contiguous)
*************** trans_caf_token_assign (gfc_se *lse, gfc
*** 8979,9001 ****
}
}
- /* 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. */
--- 8979,8984 ----
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 9048,9054 ****
tree desc;
tree tmp;
tree expr1_vptr = NULL_TREE;
! bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
gfc_start_block (&block);
--- 9031,9037 ----
tree desc;
tree tmp;
tree expr1_vptr = NULL_TREE;
! bool scalar, non_proc_ptr_assign;
gfc_ss *ss;
gfc_start_block (&block);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 9056,9062 ****
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);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
--- 9039,9047 ----
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
! 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. */
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 9066,9072 ****
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)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
--- 9051,9057 ----
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
! && 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
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 9086,9092 ****
else
gfc_conv_expr (&rse, expr2);
! if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
--- 9071,9077 ----
else
gfc_conv_expr (&rse, expr2);
! if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
Index: gcc/testsuite/gfortran.dg/proc_ptr_51.f90
===================================================================
*** gcc/testsuite/gfortran.dg/proc_ptr_51.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/proc_ptr_51.f90 (working copy)
***************
*** 0 ****
--- 1,38 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR90786.
+ !
+ ! Contributed by Andrew benson <abenso...@gmail.com>
+ !
+ 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
