re PR fortran/36704 (Procedure pointer as function result)

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

	PR fortran/36704
	* decl.c (add_hidden_procptr_result): New function for handling
	procedure pointer return values by adding a hidden result variable.
	(variable_decl,match_procedure_decl,gfc_match_function_decl,
	gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
	return values.
	* parse.c (parse_interface): Add EXTERNAL attribute only after
	FUNCTION/SUBROUTINE declaration is complete.
	* primary.c (replace_hidden_procptr_result): New function for replacing
	function symbol by hidden result variable.
	(gfc_match_rvalue,match_variable): Replace symbol by hidden result
	variable.
	* resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
	resolve_symbol): Allow for procedure pointer function results.
	(resolve_fl_procedure): Conflict detection moved here from
	'check_conflict'.
	* symbol.c (gfc_check_function_type): Allow for procedure pointer
	function results.
	(check_conflict): Move some conflict detection to resolution stage.
	* trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
	result variables.


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

	PR fortran/36704
	* gfortran.dg/external_procedures_1.f90: Modified.
	* gfortran.dg/proc_ptr_result_1.f90: New.
	* gfortran.dg/proc_ptr_result_2.f90: New.
	* gfortran.dg/proc_ptr_result_3.f90: New.

From-SVN: r145815

1 files changed, 30 insertions, 1 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index cb6f988..cab8f82 100644
--- 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 */