[Patch, fortran] PR30746 - 50th Anniversary Bug - Forward reference to contained function

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

:ADDPATCH fortran:

This represents the fourth or fifth attempt at fixing this bug.  I was
beginning to think that it was going to be necessary to split parsing
up into two steps; the first for specification expressions and the
second for the execution part.  That might be a nice project for the
future, since it would clobber a number of kludges and fix-ups.
However, it hardly seemed worth it for what is a first magnitude
corner case.

The problem arises because modules are capable of supporting doubly
contained procedures.  In this case, parse.c
(gfc_fixup_sibling_symbols) does not work for us all the time because
a reference can be made to a symbol at module level, which should be
overwritten by a procedure that is parsed later.  gfc_match_rvalue is
generating expressions that refer to the wrong symbol because the
procedure symbol, in an intermediate namespace, has not yet been
generated.

This patch works by intercepting the incorrectly associated
expressions in gfc_resolve_expr and calling gfc_match_rvalue one more.
This latter then makes the correct host association and the
expression is copied across.  Note the messing around with error
flagging; this is necessary to prevent gfc_match_name from generating
an error, when it encounters a literal actual argument.  Similarly,
care has to be taken to deallocate the bits of the expression that are
liable to be superceded.

I was concerned that this not load up compilation times too much -
even without opimization, the time increase is at the 1-2% level,
which I think is acceptable.  Once any level of optimization is turned
on, the difference becomes unmeasurable.

Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?

Paul

2007-05-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31540
	* resolve.c (check_host_association): New function that detects
	incorrect host association and corrects it.
	(gfc_resolve_expr): Call the new function for variables and
	functions.
	* match.h : Remove prototype for gfc_match_rvalue.
	* gfortran.h : Add prototype for gfc_match_rvalue.

2007-05-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31540
	* gfortran.dg/host_assoc_function_1.f90: New test.


--
"Success is the ability to go from one failure to another with no loss
of enthusiasm."  -  Winston Churchill

Index: /svn/trunk/gcc/fortran/resolve.c
===================================================================
*** /svn/trunk/gcc/fortran/resolve.c	(revision 124596)
--- /svn/trunk/gcc/fortran/resolve.c	(working copy)
*************** resolve_variable (gfc_expr *e)
*** 3204,3209 ****
--- 3204,3273 ----
  }
  
  
+ /* Checks to see that the correct symbol has been host associated.
+    The only situation where this arises is that in which a twice
+    contained function is parsed after the host association is made.
+    Therefore, on detecting this, the line is rematched, having got
+    rid of the existing references and actual_arg_list.  */
+ static bool
+ check_host_association (gfc_expr *e)
+ {
+   gfc_symbol *sym, *old_sym;
+   locus temp_locus;
+   gfc_expr *expr;
+   int n;
+ 
+   if (e->symtree == NULL || e->symtree->n.sym == NULL)
+     return e->expr_type == EXPR_FUNCTION;
+ 
+   old_sym = e->symtree->n.sym;
+   if (gfc_current_ns->parent
+ 	&& gfc_current_ns->parent->parent
+ 	&& old_sym->ns != gfc_current_ns)
+     {
+       gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
+       if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
+ 	{
+ 	  temp_locus = gfc_current_locus;
+ 	  gfc_current_locus = e->where;
+ 
+ 	  gfc_buffer_error (1);
+ 
+ 	  gfc_free_ref_list (e->ref);
+ 	  e->ref = NULL;
+ 
+ 	  if (e->expr_type == EXPR_FUNCTION)
+ 	    {
+ 	      gfc_free_actual_arglist (e->value.function.actual);
+ 	      e->value.function.actual = NULL;
+ 	    }
+ 
+ 	  if (e->shape != NULL)
+ 	    {
+ 	      for (n = 0; n < e->rank; n++)
+ 		mpz_clear (e->shape[n]);
+ 
+ 	      gfc_free (e->shape);
+ 	    }
+ 
+ 	  gfc_match_rvalue (&expr);
+ 	  gfc_clear_error ();
+ 	  gfc_buffer_error (0);
+ 
+ 	  gcc_assert (expr && sym == expr->symtree->n.sym);
+ 
+ 	  *e = *expr;
+ 	  gfc_free (expr);
+ 	  sym->refs++;
+ 
+ 	  gfc_current_locus = temp_locus;
+ 	}
+     }
+ 
+   return e->expr_type == EXPR_FUNCTION;
+ }
+ 
+ 
  /* Resolve an expression.  That is, make sure that types of operands agree
     with their operators, intrinsic operators are converted to function calls
     for overloaded types and unresolved function references are resolved.  */
*************** gfc_resolve_expr (gfc_expr *e)
*** 3223,3235 ****
        break;
  
      case EXPR_FUNCTION:
-       t = resolve_function (e);
-       break;
- 
      case EXPR_VARIABLE:
!       t = resolve_variable (e);
!       if (t == SUCCESS)
! 	expression_rank (e);
        break;
  
      case EXPR_SUBSTRING:
--- 3287,3302 ----
        break;
  
      case EXPR_FUNCTION:
      case EXPR_VARIABLE:
! 
!       if (check_host_association (e))
! 	t = resolve_function (e);
!       else
! 	{
! 	  t = resolve_variable (e);
! 	  if (t == SUCCESS)
! 	    expression_rank (e);
! 	}
        break;
  
      case EXPR_SUBSTRING:
Index: /svn/trunk/gcc/testsuite/gfortran.dg/host_assoc_function_1.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/host_assoc_function_1.f90	(revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/host_assoc_function_1.f90	(revision 0)
***************
*** 0 ****
--- 1,43 ----
+ ! { dg-do run }
+ ! Tests the fix for the bug PR30746, in which the reference to 'x'
+ ! in 'inner' wrongly host-associated with the variable 'x' rather
+ ! than the function.
+ !
+ ! Testcase is due to Malcolm Cohen, NAG.
+ !
+ real function z (i)
+   integer :: i
+   z = real (i)**i
+ end function
+ 
+ MODULE m
+   REAL :: x(3) = (/ 1.5, 2.5, 3.5 /)
+   interface
+     real function z (i)
+       integer :: i
+     end function
+   end interface
+ CONTAINS
+   SUBROUTINE s
+     if (x(2) .ne. 2.5) call abort ()
+     if (z(3) .ne. real (3)**3) call abort ()
+     CALL inner
+   CONTAINS
+     SUBROUTINE inner
+       i = 7
+       if (x(i, 7) .ne. real (7)**7) call abort ()
+       if (z(i, 7) .ne. real (7)**7) call abort ()
+     END SUBROUTINE
+     FUNCTION x(n, m)
+       x = REAL(n)**m
+     END FUNCTION
+     FUNCTION z(n, m)
+       z = REAL(n)**m
+     END FUNCTION
+ 
+   END SUBROUTINE
+ END MODULE
+   use m
+   call s()
+ end
+ ! { dg-final { cleanup-modules "m" } }