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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151081 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 15881c9..16a046d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+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

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 0a917f7..79db195 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/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;
        }

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 411e2c8..3bc4c58 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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;

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3f5e76d..a5677f7 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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

diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 0b167b9..d7307df 100644 (file)
--- a/gcc/fortran/trans-stmt.h
+++ b/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 *);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 83b2daa..23f669b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_25.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_25.f90
new file mode 100644 (file)
index 0000000..cfa0d44
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_25.f90
@@ -0,0 +1,36 @@
+! { 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
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90
new file mode 100644 (file)
index 0000000..4b849b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90
@@ -0,0 +1,33 @@
+! { 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
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90
new file mode 100644 (file)
index 0000000..8027c82
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90
@@ -0,0 +1,32 @@
+! { 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
+