re PR fortran/41139 (a procedure pointer call as actual argument)

2009-08-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41139
	* primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for
	calls to procedure pointer components, other references to procedure
	pointer components are EXPR_VARIABLE.
	* resolve.c (resolve_actual_arglist): Bugfix (there can be calls without
	actual arglist).
	* trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp',
	removed argument 'se' and made static. Avoid inserting a temporary
	variable for calling the PPC.
	(conv_function_val): Renamed gfc_get_proc_ptr_comp.
	(gfc_conv_procedure_call): Distinguish functions returning a procedure
	pointer from calls to a procedure pointer. Distinguish calls to
	procedure pointer components from procedure pointer components as
	actual arguments.
	* trans-stmt.h (gfc_get_proc_ptr_comp): Make it static.


2009-08-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41139
	* gfortran.dg/proc_ptr_25.f90: New.
	* gfortran.dg/proc_ptr_comp_18.f90: New.
	* gfortran.dg/proc_ptr_comp_19.f90: New.

From-SVN: r151081

gcc/fortran/ChangeLog

+2009-08-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41139
+	* primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for
+	calls to procedure pointer components, other references to procedure
+	pointer components are EXPR_VARIABLE.
+	* resolve.c (resolve_actual_arglist): Bugfix (there can be calls without
+	actual arglist).
+	* trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp',
+	removed argument 'se' and made static. Avoid inserting a temporary
+	variable for calling the PPC.
+	(conv_function_val): Renamed gfc_get_proc_ptr_comp.
+	(gfc_conv_procedure_call): Distinguish functions returning a procedure
+	pointer from calls to a procedure pointer. Distinguish calls to
+	procedure pointer components from procedure pointer components as
+	actual arguments.
+	* trans-stmt.h (gfc_get_proc_ptr_comp): Make it static.
+
 2009-08-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/41162

gcc/fortran/primary.c

@@ -1839,13 +1839,12 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       if (component->attr.proc_pointer && ppc_arg
 	  && !gfc_matching_procptr_assignment)
 	{
-	  primary->expr_type = EXPR_PPC;
-	  m = gfc_match_actual_arglist (component->attr.subroutine,
+	  m = gfc_match_actual_arglist (sub_flag,
 					&primary->value.compcall.actual);
 	  if (m == MATCH_ERROR)
 	    return MATCH_ERROR;
-	  if (m == MATCH_NO)
-	    primary->value.compcall.actual = NULL;
+	  if (m == MATCH_YES)
+	    primary->expr_type = EXPR_PPC;
 
           break;
 	}

gcc/fortran/resolve.c

@@ -1279,9 +1279,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
       if (gfc_is_proc_ptr_comp (e, &comp))
 	{
 	  e->ts = comp->ts;
-	  if (e->value.compcall.actual == NULL)
-	    e->expr_type = EXPR_VARIABLE;
-	  else
+	  if (e->expr_type == EXPR_PPC)
 	    {
 	      if (comp->as != NULL)
 		e->rank = comp->as->rank;

gcc/fortran/trans-expr.c

@@ -1502,13 +1502,29 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
   return tmp;
 }
 
+
+/* Return the backend_decl for a procedure pointer component.  */
+
+static tree
+get_proc_ptr_comp (gfc_expr *e)
+{
+  gfc_se comp_se;
+  gfc_expr *e2;
+  gfc_init_se (&comp_se, NULL);
+  e2 = gfc_copy_expr (e);
+  e2->expr_type = EXPR_VARIABLE;
+  gfc_conv_expr (&comp_se, e2);
+  return build_fold_addr_expr_loc (input_location, comp_se.expr);
+}
+
+
 static void
 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
   if (gfc_is_proc_ptr_comp (expr, NULL))
-    tmp = gfc_get_proc_ptr_comp (se, expr);
+    tmp = get_proc_ptr_comp (expr);
   else if (sym->attr.dummy)
     {
       tmp = gfc_get_symbol_decl (sym);
@@ -2679,6 +2695,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 	      else if (e->expr_type == EXPR_FUNCTION
 		       && e->symtree->n.sym->result
+		       && e->symtree->n.sym->result != e->symtree->n.sym
 		       && e->symtree->n.sym->result->attr.proc_pointer)
 		{
 		  /* Functions returning procedure pointers.  */
@@ -2695,7 +2712,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			  || (fsym->attr.proc_pointer
 			      && !(e->expr_type == EXPR_VARIABLE
 			      && e->symtree->n.sym->attr.dummy))
-			  || gfc_is_proc_ptr_comp (e, NULL)))
+			  || (e->expr_type == EXPR_VARIABLE
+			      && gfc_is_proc_ptr_comp (e, NULL))))
 		    {
 		      /* Scalar pointer dummy args require an extra level of
 			 indirection. The null pointer already contains
@@ -3501,22 +3519,6 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
 }
 
 
-/* Return the backend_decl for a procedure pointer component.  */
-
-tree
-gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
-{
-  gfc_se comp_se;
-  gfc_expr *e2;
-  gfc_init_se (&comp_se, NULL);
-  e2 = gfc_copy_expr (e);
-  e2->expr_type = EXPR_VARIABLE;
-  gfc_conv_expr (&comp_se, e2);
-  comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr);
-  return gfc_evaluate_now (comp_se.expr, &se->pre);  
-}
-
-
 /* Translate a function expression.  */
 
 static void

gcc/fortran/trans-stmt.h

@@ -29,7 +29,6 @@ tree gfc_trans_code (gfc_code *);
 tree gfc_trans_assign (gfc_code *);
 tree gfc_trans_pointer_assign (gfc_code *);
 tree gfc_trans_init_assign (gfc_code *);
-tree gfc_get_proc_ptr_comp (gfc_se *, gfc_expr *);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);

gcc/testsuite/ChangeLog

+2009-08-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41139
+	* gfortran.dg/proc_ptr_25.f90: New.
+	* gfortran.dg/proc_ptr_comp_18.f90: New.
+	* gfortran.dg/proc_ptr_comp_19.f90: New.
+
 2009-08-24  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/41154

gcc/testsuite/gfortran.dg/proc_ptr_25.f90

+! { dg-do run }
+!
+! PR 41139: [4.5 Regression] a procedure pointer call as actual argument
+!
+! Original test case by Barron Bichon <barron.bichon@swri.org>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+PROGRAM test
+
+ PROCEDURE(add), POINTER :: f
+ logical :: g
+
+ ! Passing the function works
+ g=greater(4.,add(1.,2.))
+ if (.not. g) call abort()
+
+ ! Passing the procedure pointer fails
+ f => add
+ g=greater(4.,f(1.,2.))
+ if (.not. g) call abort()
+
+CONTAINS
+
+ REAL FUNCTION add(x,y)
+   REAL, INTENT(in) :: x,y
+   print *,"add:",x,y
+   add = x+y
+ END FUNCTION add
+
+ LOGICAL FUNCTION greater(x,y)
+   REAL, INTENT(in) :: x, y
+   greater = (x > y)
+ END FUNCTION greater
+
+END PROGRAM test
+

gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90

+! { dg-do run }
+!
+! PR 41139: [4.5 Regression] a procedure pointer call as actual argument
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+PROGRAM test
+
+ type :: t
+   PROCEDURE(add), POINTER, nopass :: f
+ end type
+ type(t) :: o
+ logical :: g
+
+ o%f => add
+ g=greater(4.,o%f(1.,2.))
+ if (.not. g) call abort()
+
+CONTAINS
+
+ REAL FUNCTION add(x,y)
+   REAL, INTENT(in) :: x,y
+   add = x+y
+ END FUNCTION add
+
+ LOGICAL FUNCTION greater(x,y)
+   REAL, INTENT(in) :: x, y
+   print *,"greater:",x,y
+   greater = (x > y)
+ END FUNCTION greater
+
+END PROGRAM test
+

gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90

+! { dg-do run }
+!
+! PR 41139: [4.5 Regression] a procedure pointer call as actual argument
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+PROGRAM test
+
+ type :: t
+   PROCEDURE(three), POINTER, nopass :: f
+ end type
+ type(t) :: o
+ logical :: g
+
+ o%f => three
+ g=greater(4.,o%f())
+ if (.not. g) call abort()
+
+CONTAINS
+
+ REAL FUNCTION three()
+   three = 3.
+ END FUNCTION
+
+ LOGICAL FUNCTION greater(x,y)
+   REAL, INTENT(in) :: x, y
+   print *,"greater:",x,y
+   greater = (x > y)
+ END FUNCTION greater
+
+END PROGRAM test
+