+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
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;
}
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;
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);
}
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. */
|| (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
}
-/* 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
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 *);
+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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
git://gcc.gnu.org / gcc.git / commitdiff