[Bug fortran/30746] 50th Anniversary Bug - Forward reference to contained function

[pault at gcc dot gnu dot org]

------- Comment #3 from pault at gcc dot gnu dot org  2007-05-10 09:11 -------
The patch below does the job. Before submitting, I want to check how much the
compile time is hit.  If it is a lot, I will try to streamline detection of the
wrong host association.

Paul

Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h      (révision 124567)
--- gcc/fortran/gfortran.h      (copie de travail)
*************** bool gfc_check_access (gfc_access, gfc_a
*** 2160,2165 ****
--- 2160,2166 ----
  /* 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 *);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c       (révision 124567)
--- gcc/fortran/resolve.c       (copie de travail)
*************** resolve_variable (gfc_expr *e)
*** 3204,3209 ****
--- 3204,3274 ----
  }


+ /* Checks to see that the correct symbol has been host associated.
+    The only situation where this arises is that in which a 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;
+ 
+   old_sym = e->symtree->n.sym;
+   if (!old_sym->attr.use_assoc && 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);
+ 
+         gcc_assert (expr && sym == expr->symtree->n.sym);
+ 
+         *e = *expr;
+         gfc_free (expr);
+         sym->refs++;
+ 
+         /* Free the old symbol.  */
+         if (old_sym->ns->proc_name->attr.flavor != FL_MODULE)
+           {
+             old_sym->refs--;
+             if (old_sym->refs == 0)
+               gfc_free_symbol (old_sym);
+           }
+ 
+         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:
--- 3288,3303 ----
        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: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (révision 124567)
--- gcc/fortran/match.h (copie de travail)
*************** match gfc_match_volatile (void);
*** 153,159 ****

  /* 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 **);
--- 153,158 ----
Index: gcc/testsuite/gfortran.dg/host_assoc_function_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/host_assoc_function_1.f90 (révision 0)
--- gcc/testsuite/gfortran.dg/host_assoc_function_1.f90 (révision 0)
***************
*** 0 ****
--- 1,26 ----
+ ! { 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.
+ !
+ MODULE m
+   REAL :: x(3) = (/ 1.5, 2.5, 3.5 /)
+ CONTAINS
+   SUBROUTINE s
+     CALL inner
+   CONTAINS
+     SUBROUTINE inner
+       i = 7
+       if (x(7) .ne. real (7)**7) call abort ()
+     END SUBROUTINE
+     FUNCTION x(n)
+       x = REAL(n)**n
+     END FUNCTION
+   END SUBROUTINE
+ END MODULE
+   use m
+   call s()
+ end
+ ! { dg-final { cleanup-modules "m" } }



-- 

pault at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
         AssignedTo|unassigned at gcc dot gnu   |pault at gcc dot gnu dot org
                   |dot org                     |
             Status|NEW                         |ASSIGNED
   Last reconfirmed|2007-02-09 17:06:57         |2007-05-10 09:11:58
               date|                            |


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=30746