Fortran: Fix ICE due to elemental procedure pointers [PR93924/5].

2021-01-27  Paul Thomas  <pault@gcc.gnu.org>

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.

2 files changed, 76 insertions, 2 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7150e48..b0c8d57 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 0000000..cb7cf70
--- /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  <mscfd@gmx.net>
+!
+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