re PR fortran/90786 (ICE on procedure pointer assignment to function with class pointer result)

2019-06-08  Paul Thomas  <pault@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  <pault@gcc.gnu.org>

	PR fortran/90786
	* gfortran.dg/proc_ptr_51.f90 : New test.

From-SVN: r272084

4 files changed, 61 insertions, 23 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 20fe2c3..35e575a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2019-06-08  Paul Thomas  <pault@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  Thomas Koenig  <tkoenig@gcc.gnu.org>
 	Tomáš Trnka  <trnka@scm.com>
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index d23520f..dc173a0 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 a2012ae..df3d006 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-06-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/90786
+	* gfortran.dg/proc_ptr_51.f90 : New test.
+
 2019-06-08  Marek Polacek  <polacek@redhat.com>
 
 	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  <rguenther@suse.de>
 
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 0000000..62b5d71
--- /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  <abensonca@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