re PR fortran/40593 (Proc-pointer returning function as actual argument)

2009-07-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40593
	* interface.c (compare_actual_formal): Take care of proc-pointer-valued
	functions as actual arguments.
	* trans-expr.c (gfc_conv_procedure_call): Ditto.
	* resolve.c (resolve_specific_f0): Use the correct ts.


2009-07-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40593
	* gfortran.dg/proc_ptr_result_6.f90: New.

From-SVN: r149227

gcc/fortran/ChangeLog

+2009-07-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40593
+	* interface.c (compare_actual_formal): Take care of proc-pointer-valued
+	functions as actual arguments.
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* resolve.c (resolve_specific_f0): Use the correct ts.
+
 2009-07-02  Michael Matz  <matz@suse.de>
 
 	PR fortran/32131

gcc/fortran/interface.c

@@ -1911,7 +1911,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
 	 is provided for a procedure pointer formal argument.  */
       if (f->sym->attr.proc_pointer
-	  && !(a->expr->symtree->n.sym->attr.proc_pointer
+	  && !((a->expr->expr_type == EXPR_VARIABLE
+		&& a->expr->symtree->n.sym->attr.proc_pointer)
+	       || (a->expr->expr_type == EXPR_FUNCTION
+		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
 	       || is_proc_ptr_comp (a->expr, NULL)))
 	{
 	  if (where)

gcc/fortran/resolve.c

@@ -1828,7 +1828,10 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
 found:
   gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
 
-  expr->ts = sym->ts;
+  if (sym->result)
+    expr->ts = sym->result->ts;
+  else
+    expr->ts = sym->ts;
   expr->value.function.name = sym->name;
   expr->value.function.esym = sym;
   if (sym->as != NULL)

gcc/fortran/trans-expr.c

@@ -2640,6 +2640,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  gfc_conv_expr (&parmse, e);
 		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
 		}
+	      else if (e->expr_type == EXPR_FUNCTION
+		       && e->symtree->n.sym->result
+		       && e->symtree->n.sym->result->attr.proc_pointer)
+		{
+		  /* Functions returning procedure pointers.  */
+		  gfc_conv_expr (&parmse, e);
+		  if (fsym && fsym->attr.proc_pointer)
+		    parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		}
 	      else
 		{
 		  gfc_conv_expr_reference (&parmse, e);

gcc/testsuite/ChangeLog

+2009-07-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40593
+	* gfortran.dg/proc_ptr_result_6.f90: New.
+
 2009-07-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* gcc.dg/framework-2.c: Adjust testcase to pass.

gcc/testsuite/gfortran.dg/proc_ptr_result_6.f90

+! { dg-do run }
+!
+! PR 40593: Proc-pointer returning function as actual argument
+!
+! Original test case by Tobias Burnus <burnus@gcc.gnu.org>
+! Modified by Janus Weil
+
+module m
+contains
+  subroutine sub(a)
+    integer :: a
+    a = 42
+  end subroutine
+  integer function func()
+    func = 42
+  end function
+end module m
+
+program test
+  use m
+  implicit none
+  call caller1(getPtr1())
+  call caller2(getPtr2())
+  call caller3(getPtr2())
+contains
+  subroutine caller1(s)
+    procedure(sub) :: s
+    integer :: b
+    call s(b)
+    if (b /= 42)  call abort()
+  end subroutine
+  subroutine caller2(f)
+    procedure(integer) :: f
+    if (f() /= 42)  call abort()
+  end subroutine
+  subroutine caller3(f)
+    procedure(func),pointer :: f
+    if (f() /= 42) call abort()
+  end subroutine
+  function getPtr1()
+    procedure(sub), pointer :: getPtr1
+    getPtr1 => sub
+  end function
+  function getPtr2()
+    procedure(func), pointer :: getPtr2
+    getPtr2 => func
+  end function
+end program test
+
+! { dg-final { cleanup-modules "m" } }
+