re PR fortran/26107 (ICE after error message on invalid code)

2006-03-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26107
	* resolve.c (resolve_function): Add name after test for pureness.

	PR fortran/19546
	* trans-expr.c (gfc_conv_variable): Detect reference to parent result,
	store current_function_decl, replace with parent, whilst calls are
	made to gfc_get_fake_result_decl, and restore afterwards. Signal this
	to gfc_get_fake_result_decl with a new argument, parent_flag.
	* trans-stmt.c (gfc_trans_return): gfc_get_fake_result_decl 2nd arg
	is set to zero.
	* trans.h: Add parent_flag to gfc_get_fake_result_decl prototype.
	* trans-decl.c (gfc_get_fake_result_decl): On parent_flag, being set,
	add decl to parent function. Replace refs to current_fake_result_decl
	with refs to this_result_decl.
	(gfc_generate_function_code): Null parent_fake_result_decl before the
	translation of code for contained procedures. Set parent_flag to zero
	in call to gfc_get_fake_result_decl.
	* trans-intrinsic.c (gfc_conv_intrinsic_len): The same.

2006-03-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26107
	* pure_dummy_length_1.f90: New test.

	PR fortran/19546
	* gfortran.dg/parent_result_ref_1.f90: New test.
	* gfortran.dg/parent_result_ref_2.f90: New test.
	* gfortran.dg/parent_result_ref_3.f90: New test.
	* gfortran.dg/parent_result_ref_4.f90: New test.

From-SVN: r111793

1 files changed, 36 insertions, 12 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1fc7f06..4be5459 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -296,6 +296,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 {
   gfc_ref *ref;
   gfc_symbol *sym;
+  tree parent_decl;
+  int parent_flag;
+  bool return_value;
+  bool alternate_entry;
+  bool entry_master;
 
   sym = expr->symtree->n.sym;
   if (se->ss != NULL)
@@ -317,32 +322,51 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 
       se->expr = gfc_get_symbol_decl (sym);
 
+      /* Deal with references to a parent results or entries by storing
+	 the current_function_decl and moving to the parent_decl.  */
+      parent_flag = 0;
+
+      return_value = sym->attr.function && sym->result == sym;
+      alternate_entry = sym->attr.function && sym->attr.entry
+			  && sym->result == sym;
+      entry_master = sym->attr.result
+			&& sym->ns->proc_name->attr.entry_master
+			&& !gfc_return_by_reference (sym->ns->proc_name);
+      parent_decl = DECL_CONTEXT (current_function_decl);
+
+      if ((se->expr == parent_decl && return_value)
+	    || (sym->ns  && sym->ns->proc_name
+		  && sym->ns->proc_name->backend_decl == parent_decl
+		  && (alternate_entry || entry_master)))
+	parent_flag = 1;
+      else
+	parent_flag = 0;
+
       /* Special case for assigning the return value of a function.
 	 Self recursive functions must have an explicit return value.  */
-      if (se->expr == current_function_decl && sym->attr.function
-	  && (sym->result == sym))
-	se_expr = gfc_get_fake_result_decl (sym);
+      if (sym->attr.function && sym->result == sym
+	    && (se->expr == current_function_decl || parent_flag))
+	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
 
       /* Similarly for alternate entry points.  */
-      else if (sym->attr.function && sym->attr.entry
-	       && (sym->result == sym)
-	       && sym->ns->proc_name->backend_decl == current_function_decl)
+      else if (alternate_entry 
+		 && (sym->ns->proc_name->backend_decl == current_function_decl
+		        || parent_flag))
 	{
 	  gfc_entry_list *el = NULL;
 
 	  for (el = sym->ns->entries; el; el = el->next)
 	    if (sym == el->sym)
 	      {
-		se_expr = gfc_get_fake_result_decl (sym);
+		se_expr = gfc_get_fake_result_decl (sym, parent_flag);
 		break;
 	      }
 	}
 
-      else if (sym->attr.result
-	       && sym->ns->proc_name->backend_decl == current_function_decl
-	       && sym->ns->proc_name->attr.entry_master
-	       && !gfc_return_by_reference (sym->ns->proc_name))
-	se_expr = gfc_get_fake_result_decl (sym);
+      else if (entry_master
+		 && (sym->ns->proc_name->backend_decl == current_function_decl
+			|| parent_flag))
+	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
 
       if (se_expr)
 	se->expr = se_expr;