2009-04-09 Janus Weil <janus@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / primary.c

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index cb6f988..cab8f82 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2358,6 +2358,30 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
 }
 
 
+/* Procedure pointer as function result: Replace the function symbol by the
+   auto-generated hidden result variable named "ppr@".  */
+
+static gfc_try
+replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
+{
+  /* Check for procedure pointer result variable.  */
+  if ((*sym)->attr.function && !(*sym)->attr.external
+      && (*sym)->result && (*sym)->result != *sym
+      && (*sym)->result->attr.proc_pointer
+      && (*sym) == gfc_current_ns->proc_name
+      && (*sym) == (*sym)->result->ns->proc_name
+      && strcmp ("ppr@", (*sym)->result->name) == 0)
+    {
+      /* Automatic replacement with "hidden" result variable.  */
+      (*sym)->result->attr.referenced = (*sym)->attr.referenced;
+      *sym = (*sym)->result;
+      *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
+      return SUCCESS;
+    }
+  return FAILURE;
+}
+
+
 /* Matches a variable name followed by anything that might follow it--
    array reference, argument list of a function, etc.  */
 
@@ -2394,6 +2418,8 @@ gfc_match_rvalue (gfc_expr **result)
   e = NULL;
   where = gfc_current_locus;
 
+  replace_hidden_procptr_result (&sym, &symtree);
+
   /* If this is an implicit do loop index and implicitly typed,
      it should not be host associated.  */
   m = check_for_implicit_index (&symtree, &sym);
@@ -2583,6 +2609,8 @@ gfc_match_rvalue (gfc_expr **result)
       gfc_get_ha_sym_tree (name, &symtree);    /* Can't fail */
       sym = symtree->n.sym;
 
+      replace_hidden_procptr_result (&sym, &symtree);
+
       e = gfc_get_expr ();
       e->symtree = symtree;
       e->expr_type = EXPR_FUNCTION;
@@ -2912,7 +2940,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
          break;
        }
 
-      if (sym->attr.proc_pointer)
+      if (sym->attr.proc_pointer
+         || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
        break;
 
       /* Fall through to error */