gfortran.h (gfc_get_proc_ptr_comp): New prototype.

fortran/
	* gfortran.h (gfc_get_proc_ptr_comp): New prototype.
	(gfc_is_proc_ptr_comp): Update prototype.
	* expr.c (gfc_get_proc_ptr_comp): New function based on the old
	gfc_is_proc_ptr_comp.
	(gfc_is_proc_ptr_comp): Call gfc_get_proc_ptr_comp.
	(gfc_specification_expr, gfc_check_pointer_assign): Use
	gfc_get_proc_ptr_comp.
	* trans-array.c (gfc_walk_function_expr): Likewise.
	* resolve.c (resolve_structure_cons, update_ppc_arglist,
	resolve_ppc_call, resolve_expr_ppc): Likewise.
	(resolve_function): Update call to gfc_is_proc_ptr_comp.
	* dump-parse-tree.c (show_expr): Likewise.
	* interface.c (compare_actual_formal): Likewise.
	* match.c (gfc_match_pointer_assignment): Likewise.
	* primary.c (gfc_match_varspec): Likewise.
	* trans-io.c (gfc_trans_transfer): Likewise.
	* trans-expr.c (gfc_conv_variable, conv_function_val,
	conv_isocbinding_procedure, gfc_conv_procedure_call,
	gfc_trans_pointer_assignment): Likewise.
	(gfc_conv_procedure_call, gfc_trans_array_func_assign):
	Use gfc_get_proc_ptr_comp.

From-SVN: r190391

11 files changed, 80 insertions, 49 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 039c1c3..6309b5a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+2012-08-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	* gfortran.h (gfc_get_proc_ptr_comp): New prototype.
+	(gfc_is_proc_ptr_comp): Update prototype.
+	* expr.c (gfc_get_proc_ptr_comp): New function based on the old
+	gfc_is_proc_ptr_comp.
+	(gfc_is_proc_ptr_comp): Call gfc_get_proc_ptr_comp.
+	(gfc_specification_expr, gfc_check_pointer_assign): Use
+	gfc_get_proc_ptr_comp.
+	* trans-array.c (gfc_walk_function_expr): Likewise.
+	* resolve.c (resolve_structure_cons, update_ppc_arglist,
+	resolve_ppc_call, resolve_expr_ppc): Likewise.
+	(resolve_function): Update call to gfc_is_proc_ptr_comp.
+	* dump-parse-tree.c (show_expr): Likewise.
+	* interface.c (compare_actual_formal): Likewise.
+	* match.c (gfc_match_pointer_assignment): Likewise.
+	* primary.c (gfc_match_varspec): Likewise.
+	* trans-io.c (gfc_trans_transfer): Likewise.
+	* trans-expr.c (gfc_conv_variable, conv_function_val,
+	conv_isocbinding_procedure, gfc_conv_procedure_call,
+	gfc_trans_pointer_assignment): Likewise.
+	(gfc_conv_procedure_call, gfc_trans_array_func_assign):
+	Use gfc_get_proc_ptr_comp.
+
 2012-08-14  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40881
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 681dc8d..cb8fab4 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -569,7 +569,7 @@ show_expr (gfc_expr *p)
       if (p->value.function.name == NULL)
 	{
 	  fprintf (dumpfile, "%s", p->symtree->n.sym->name);
-	  if (gfc_is_proc_ptr_comp (p, NULL))
+	  if (gfc_is_proc_ptr_comp (p))
 	    show_ref (p->ref);
 	  fputc ('[', dumpfile);
 	  show_actual_arglist (p->value.function.actual);
@@ -578,7 +578,7 @@ show_expr (gfc_expr *p)
       else
 	{
 	  fprintf (dumpfile, "%s", p->value.function.name);
-	  if (gfc_is_proc_ptr_comp (p, NULL))
+	  if (gfc_is_proc_ptr_comp (p))
 	    show_ref (p->ref);
 	  fputc ('[', dumpfile);
 	  fputc ('[', dumpfile);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index aeb224f..7d74528 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2962,12 +2962,12 @@ gfc_specification_expr (gfc_expr *e)
       return FAILURE;
     }
 
+  comp = gfc_get_proc_ptr_comp (e);
   if (e->expr_type == EXPR_FUNCTION
-	  && !e->value.function.isym
-	  && !e->value.function.esym
-	  && !gfc_pure (e->symtree->n.sym)
-	  && (!gfc_is_proc_ptr_comp (e, &comp)
-	      || !comp->attr.pure))
+      && !e->value.function.isym
+      && !e->value.function.esym
+      && !gfc_pure (e->symtree->n.sym)
+      && (!comp || !comp->attr.pure))
     {
       gfc_error ("Function '%s' at %L must be PURE",
 		 e->symtree->n.sym->name, &e->where);
@@ -3495,12 +3495,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	    }
 	}
 
-      if (gfc_is_proc_ptr_comp (lvalue, &comp))
+      comp = gfc_get_proc_ptr_comp (lvalue);
+      if (comp)
 	s1 = comp->ts.interface;
       else
 	s1 = lvalue->symtree->n.sym;
 
-      if (gfc_is_proc_ptr_comp (rvalue, &comp))
+      comp = gfc_get_proc_ptr_comp (rvalue);
+      if (comp)
 	{
 	  s2 = comp->ts.interface;
 	  name = comp->name;
@@ -4075,31 +4077,35 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
 }
 
 
-/* Determine if an expression is a procedure pointer component. If yes, the
-   argument 'comp' will point to the component (provided that 'comp' was
-   provided).  */
+/* Determine if an expression is a procedure pointer component and return
+   the component in that case.  Otherwise return NULL.  */
 
-bool
-gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+gfc_component *
+gfc_get_proc_ptr_comp (gfc_expr *expr)
 {
   gfc_ref *ref;
-  bool ppc = false;
 
   if (!expr || !expr->ref)
-    return false;
+    return NULL;
 
   ref = expr->ref;
   while (ref->next)
     ref = ref->next;
 
-  if (ref->type == REF_COMPONENT)
-    {
-      ppc = ref->u.c.component->attr.proc_pointer;
-      if (ppc && comp)
-	*comp = ref->u.c.component;
-    }
+  if (ref->type == REF_COMPONENT
+      && ref->u.c.component->attr.proc_pointer)
+    return ref->u.c.component;
+
+  return NULL;
+}
+
 
-  return ppc;
+/* Determine if an expression is a procedure pointer component.  */
+
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr)
+{
+  return (gfc_get_proc_ptr_comp (expr) != NULL);
 }
 
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0e2130f..7c4c0a4 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2766,7 +2766,8 @@ gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
 void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 
-bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
+gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
+bool gfc_is_proc_ptr_comp (gfc_expr *);
 
 bool gfc_ref_this_image (gfc_ref *ref);
 bool gfc_is_coindexed (gfc_expr *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 473cfd1..482c294 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2558,7 +2558,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		&& a->expr->symtree->n.sym->attr.proc_pointer)
 	       || (a->expr->expr_type == EXPR_FUNCTION
 		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
-	       || gfc_is_proc_ptr_comp (a->expr, NULL)))
+	       || gfc_is_proc_ptr_comp (a->expr)))
 	{
 	  if (where)
 	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
@@ -2568,7 +2568,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
 	 provided for a procedure formal argument.  */
-      if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
+      if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr)
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && f->sym->attr.flavor == FL_PROCEDURE)
 	{
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 5ab07e5..0b1cf5a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1344,7 +1344,7 @@ gfc_match_pointer_assignment (void)
     }
 
   if (lvalue->symtree->n.sym->attr.proc_pointer
-      || gfc_is_proc_ptr_comp (lvalue, NULL))
+      || gfc_is_proc_ptr_comp (lvalue))
     gfc_matching_procptr_assignment = 1;
   else
     gfc_matching_ptr_assignment = 1;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 29d2789..cadc20c 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1862,7 +1862,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
       || (sym->attr.dimension && sym->ts.type != BT_CLASS
-	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL)
+	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
 	  && !(gfc_matching_procptr_assignment
 	       && sym->attr.flavor == FL_PROCEDURE))
       || (sym->ts.type == BT_CLASS && sym->attr.class_ok
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9b8033d..c706b89 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1195,7 +1195,8 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	  const char *name;
 	  char err[200];
 
-	  if (gfc_is_proc_ptr_comp (cons->expr, &c2))
+	  c2 = gfc_get_proc_ptr_comp (cons->expr);
+	  if (c2)
 	    {
 	      s2 = c2->ts.interface;
 	      name = c2->name;
@@ -3093,9 +3094,9 @@ resolve_function (gfc_expr *expr)
     sym = expr->symtree->n.sym;
 
   /* If this is a procedure pointer component, it has already been resolved.  */
-  if (gfc_is_proc_ptr_comp (expr, NULL))
+  if (gfc_is_proc_ptr_comp (expr))
     return SUCCESS;
-  
+
   if (sym && sym->attr.intrinsic
       && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
     return FAILURE;
@@ -5740,7 +5741,8 @@ update_ppc_arglist (gfc_expr* e)
   gfc_component *ppc;
   gfc_typebound_proc* tb;
 
-  if (!gfc_is_proc_ptr_comp (e, &ppc))
+  ppc = gfc_get_proc_ptr_comp (e);
+  if (!ppc)
     return FAILURE;
 
   tb = ppc->tb;
@@ -6363,10 +6365,9 @@ static gfc_try
 resolve_ppc_call (gfc_code* c)
 {
   gfc_component *comp;
-  bool b;
 
-  b = gfc_is_proc_ptr_comp (c->expr1, &comp);
-  gcc_assert (b);
+  comp = gfc_get_proc_ptr_comp (c->expr1);
+  gcc_assert (comp != NULL);
 
   c->resolved_sym = c->expr1->symtree->n.sym;
   c->expr1->expr_type = EXPR_VARIABLE;
@@ -6398,10 +6399,9 @@ static gfc_try
 resolve_expr_ppc (gfc_expr* e)
 {
   gfc_component *comp;
-  bool b;
 
-  b = gfc_is_proc_ptr_comp (e, &comp);
-  gcc_assert (b);
+  comp = gfc_get_proc_ptr_comp (e);
+  gcc_assert (comp != NULL);
 
   /* Convert to EXPR_FUNCTION.  */
   e->expr_type = EXPR_FUNCTION;
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ef25a36..8c254dd 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8666,7 +8666,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
     sym = expr->symtree->n.sym;
 
   /* A function that returns arrays.  */
-  gfc_is_proc_ptr_comp (expr, &comp);
+  comp = gfc_get_proc_ptr_comp (expr);
   if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
       || (comp && comp->attr.dimension))
     return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2603995..12a75d0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1512,9 +1512,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
      separately.  */
   if (se->want_pointer)
     {
-      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
+      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
 	gfc_conv_string_parameter (se);
-      else 
+      else
 	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
     }
 }
@@ -2438,7 +2438,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
-  if (gfc_is_proc_ptr_comp (expr, NULL))
+  if (gfc_is_proc_ptr_comp (expr))
     tmp = get_proc_ptr_comp (expr);
   else if (sym->attr.dummy)
     {
@@ -3447,7 +3447,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
       if (arg->next->expr->rank == 0)
 	{
 	  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
-	      || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
+	      || gfc_is_proc_ptr_comp (arg->next->expr))
 	    fptrse.want_pointer = 1;
 
 	  gfc_conv_expr (&fptrse, arg->next->expr);
@@ -3649,7 +3649,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       && conv_isocbinding_procedure (se, sym, args))
     return 0;
 
-  gfc_is_proc_ptr_comp (expr, &comp);
+  comp = gfc_get_proc_ptr_comp (expr);
 
   if (se->ss != NULL)
     {
@@ -3958,7 +3958,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				   && e->symtree->n.sym->attr.dummy))
 			  || (fsym->attr.proc_pointer
 			      && e->expr_type == EXPR_VARIABLE
-			      && gfc_is_proc_ptr_comp (e, NULL))
+			      && gfc_is_proc_ptr_comp (e))
 			  || (fsym->attr.allocatable
 			      && fsym->attr.flavor != FL_PROCEDURE)))
 		    {
@@ -6007,7 +6007,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
 	  && !expr1->ts.deferred
 	  && !expr1->symtree->n.sym->attr.proc_pointer
-	  && !gfc_is_proc_ptr_comp (expr1, NULL))
+	  && !gfc_is_proc_ptr_comp (expr1))
 	{
 	  gcc_assert (expr2->ts.type == BT_CHARACTER);
 	  gcc_assert (lse.string_length && rse.string_length);
@@ -6700,9 +6700,9 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
+  comp = gfc_get_proc_ptr_comp (expr2);
   gcc_assert (expr2->value.function.isym
-	      || (gfc_is_proc_ptr_comp (expr2, &comp)
-		  && comp && comp->attr.dimension)
+	      || (comp && comp->attr.dimension)
 	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
 		  && expr2->value.function.esym->result->attr.dimension));
 
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 8218f85..9d7d5b6 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -2252,7 +2252,7 @@ gfc_trans_transfer (gfc_code * code)
       /* Transfer an array. If it is an array of an intrinsic
 	 type, pass the descriptor to the library.  Otherwise
 	 scalarize the transfer.  */
-      if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
+      if (expr->ref && !gfc_is_proc_ptr_comp (expr))
 	{
 	  for (ref = expr->ref; ref && ref->type != REF_ARRAY;
 		 ref = ref->next);