[gcc r10-10077] Fortran: Fix ICE due to elemental procedure pointers [PR93924/5].

[gcc r10-10077] Fortran: Fix ICE due to elemental procedure pointers [PR93924/5].

[Harald Anlauf]

https://gcc.gnu.org/g:bf22e268b5c2a03216503254cfcb828016a7d998

commit r10-10077-gbf22e268b5c2a03216503254cfcb828016a7d998
Author: Paul Thomas <pault@gcc.gnu.org>
Date:   Wed Jan 27 11:34:02 2021 +0000

    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.
    
    (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  <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