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.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 039c1c3..6309b5a 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);