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.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index cce18d0..3432cd4 100644 (file)
--- 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 (file)
index 0000000..f82f505
--- /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