re PR fortran/30746 (50th Anniversary Bug - Forward reference to contained function)

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

	PR fortran/30746
	* 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-12  Paul Thomas  <pault@gcc.gnu.org>

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

From-SVN: r124633

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 531e4da969fa6624c4719390f061847520006cca..4046c881b41c50b82974ccb5c3065d3e78ab34c4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2007-05-12  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/30746
+       * 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-11 Paul Thomas <pault@gcc.gnu.org>
 
        PR fortran/30876

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2030ec29bb286d7752a90c0e5cfbbe4f85ecbd3d..38ef1a6d31906497e32299c738fc6033619b658d 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2160,6 +2160,7 @@ bool gfc_check_access (gfc_access, gfc_access);
 /* primary.c */
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
 symbol_attribute gfc_expr_attr (gfc_expr *);
+match gfc_match_rvalue (gfc_expr **);
 
 /* trans.c */
 void gfc_generate_code (gfc_namespace *);

diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 3c8089af5662f5140def48fcb5824612c1891a80..3ed673f0679b397b75f07d6382c9de5a8b9ccefd 100644 (file)
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -153,7 +153,6 @@ match gfc_match_volatile (void);
 
 /* primary.c */
 match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
-match gfc_match_rvalue (gfc_expr **);
 match gfc_match_variable (gfc_expr **, int);
 match gfc_match_equiv_variable (gfc_expr **);
 match gfc_match_actual_arglist (int, gfc_actual_arglist **);

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index dbb36d37b3595589219900311ad9b2cd0890a175..b6d1f3b97321d02ce75041acf574dab043b6887b 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3204,6 +3204,70 @@ resolve_variable (gfc_expr *e)
 }
 
 
+/* 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.  */
@@ -3223,13 +3287,16 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_FUNCTION:
-      t = resolve_function (e);
-      break;
-
     case EXPR_VARIABLE:
-      t = resolve_variable (e);
-      if (t == SUCCESS)
-       expression_rank (e);
+
+      if (check_host_association (e))
+       t = resolve_function (e);
+      else
+       {
+         t = resolve_variable (e);
+         if (t == SUCCESS)
+           expression_rank (e);
+       }
       break;
 
     case EXPR_SUBSTRING:

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 64c6be31a235d17a4cddd3b4c26a65dd2c4bb952..3109938e70241a07d7174991147887a1ec109a4d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-05-12  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/30746
+       * gfortran.dg/host_assoc_function_1.f90: New test.
+
 2007-05-11  Steve Ellcey  <sje@cup.hp.com>
 
        PR c++/31829

diff --git a/gcc/testsuite/gfortran.dg/host_assoc_function_1.f90 b/gcc/testsuite/gfortran.dg/host_assoc_function_1.f90
new file mode 100644 (file)
index 0000000..019fc61
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/host_assoc_function_1.f90
@@ -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" } }