[gcc r11-8469] Fortran: fix passing return value to class(*) dummy argument

[Harald Anlauf <anlauf@gcc.gnu.org>]

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

commit r11-8469-gde55a48960d2f08266cba1222e233507015dd620
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Sun May 23 20:51:14 2021 +0200

    Fortran: fix passing return value to class(*) dummy argument
    
    gcc/fortran/ChangeLog:
    
            PR fortran/100551
            * trans-expr.c (gfc_conv_procedure_call): Adjust check for
            implicit conversion of actual argument to an unlimited polymorphic
            procedure argument.
    
    gcc/testsuite/ChangeLog:
    
            PR fortran/100551
            * gfortran.dg/pr100551.f90: New test.
    
    (cherry picked from commit fe03f4fc9548b3fdbff3c8284a994feaa7d6307d)

Diff:
---
 gcc/fortran/trans-expr.c               |  4 +++-
 gcc/testsuite/gfortran.dg/pr100551.f90 | 30 ++++++++++++++++++++++++++++++
 2 files changed, 33 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a10170c7dff..9a396f539bc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5826,7 +5826,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     &derived_array);
 	}
       else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
-	       && gfc_expr_attr (e).flavor != FL_PROCEDURE)
+	       && e->ts.type != BT_PROCEDURE
+	       && (gfc_expr_attr (e).flavor != FL_PROCEDURE
+		   || gfc_expr_attr (e).proc != PROC_UNKNOWN))
 	{
 	  /* The intrinsic type needs to be converted to a temporary
 	     CLASS object for the unlimited polymorphic formal.  */
diff --git a/gcc/testsuite/gfortran.dg/pr100551.f90 b/gcc/testsuite/gfortran.dg/pr100551.f90
new file mode 100644
index 00000000000..f82f505e734
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr100551.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+! PR fortran/100551 - Passing return value to class(*) dummy argument
+
+program p
+  implicit none
+  integer :: result
+  result = 1
+  result = test (    (result)) ! works
+  if (result /= 1) stop 1
+  result = test (int (result)) ! issue 1
+! write(*,*) result
+  if (result /= 1) stop 2
+  result = test (f   (result)) ! issue 2
+! write(*,*) result
+  if (result /= 2) stop 3
+contains
+  integer function test(x)
+    class(*), intent(in) :: x
+    select type (x)
+    type is (integer)
+       test = x
+    class default
+       test = -1
+    end select
+  end function test
+  integer function f(x)
+    integer, intent(in) :: x
+    f = 2*x
+  end function f
+end program