[Patch, fortran] PR30084 - segmentation falut when compiling certain code

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

The attached patch fixes the seg fault that occurs when, in the testcase 
provided, SIZE is used in an initialization expression and then in a 
specification expression, in a procedure contained in another module.  
The segfault occurs because the latter expression winds up without a 
symtree pointing to the SIZE intrinsic.  I tried to trace this one back 
into resolve.c and decl.c but could not find anybody who had failed in 
their duty.  This fix is a bit of a kludge but I was unable to find one 
that really looked "correct".  I also dragged the fix for PR16861 and 
PR24409 into the new function fix_mio_expr.  This puts both such kludges 
in the same place, in the hope that some bright spark can eliminate both 
and the function. :-)

The fix depends on the symtree being null and the expression having a 
function name.  This being so, the function name can be used to look for 
the required symtree, which is duly attached to the expression.  The 
testcase is that of the reporter, as reduced by Steve Kargl.  I have 
added a small main programme that does the right thing, even though the 
testsuite only compiles this testcase.

Regtested on ia64/FC5 - OK for trunk and 4.2?

Paul


2006-12-19  Paul Thomas <pault@gcc.gnu.org>

	PR fortran/30084
	* module.c (mio_component_ref): Move treatment of unique name
	variables, during output, to fix_mio_expr.
	(fix_mio_expr): New function to promote to fix defective
	expressions before they are written to the module file.
	(mio_expr): Call the new function.

2006-12-19  Paul Thomas <pault@gcc.gnu.org>

	PR fortran/30084
	* gfortran.dg/nested_modules_6.f90: New test.

Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 120001)
--- gcc/fortran/module.c	(working copy)
*************** mio_symtree_ref (gfc_symtree ** stp)
*** 2194,2220 ****
  {
    pointer_info *p;
    fixup_t *f;
-   gfc_symtree * ns_st = NULL;
  
    if (iomode == IO_OUTPUT)
!     {
!       /* If this is a symtree for a symbol that came from a contained module
! 	 namespace, it has a unique name and we should look in the current
! 	 namespace to see if the required, non-contained symbol is available
! 	 yet. If so, the latter should be written.  */
!       if ((*stp)->n.sym && check_unique_name((*stp)->name))
! 	ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
! 				    (*stp)->n.sym->name);
! 
!       /* On the other hand, if the existing symbol is the module name or the
! 	 new symbol is a dummy argument, do not do the promotion.  */
!       if (ns_st && ns_st->n.sym
! 	    && ns_st->n.sym->attr.flavor != FL_MODULE
! 	    && !(*stp)->n.sym->attr.dummy)
! 	mio_symbol_ref (&ns_st->n.sym);
!       else
! 	mio_symbol_ref (&(*stp)->n.sym);
!     }
    else
      {
        require_atom (ATOM_INTEGER);
--- 2194,2202 ----
  {
    pointer_info *p;
    fixup_t *f;
  
    if (iomode == IO_OUTPUT)
!     mio_symbol_ref (&(*stp)->n.sym);
    else
      {
        require_atom (ATOM_INTEGER);
*************** static const mstring intrinsics[] =
*** 2554,2559 ****
--- 2536,2583 ----
      minit (NULL, -1)
  };
  
+ 
+ /* Remedy a couple of situations where the gfc_expr's can be defective.  */
+  
+ static void
+ fix_mio_expr (gfc_expr *e)
+ {
+   gfc_symtree *ns_st = NULL;
+   const char *fname;
+ 
+   if (iomode != IO_OUTPUT)
+     return;
+ 
+   if (e->symtree)
+     {
+       /* If this is a symtree for a symbol that came from a contained module
+ 	 namespace, it has a unique name and we should look in the current
+ 	 namespace to see if the required, non-contained symbol is available
+ 	 yet. If so, the latter should be written.  */
+       if (e->symtree->n.sym && check_unique_name(e->symtree->name))
+ 	ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
+ 				    e->symtree->n.sym->name);
+ 
+       /* On the other hand, if the existing symbol is the module name or the
+ 	 new symbol is a dummy argument, do not do the promotion.  */
+       if (ns_st && ns_st->n.sym
+ 	    && ns_st->n.sym->attr.flavor != FL_MODULE
+ 	    && !e->symtree->n.sym->attr.dummy)
+ 	e->symtree = ns_st;
+     }
+   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+     {
+       /* In some circumstances, a function used in an initialization
+ 	 expression, in one use associated module, can fail to be
+ 	 coupled to its symtree when used in a specification
+ 	 expression in another module.  */
+       fname = e->value.function.esym ? e->value.function.esym->name :
+ 				       e->value.function.isym->name;
+       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+     }
+ }
+ 
+ 
  /* Read and write expressions.  The form "()" is allowed to indicate a
     NULL expression.  */
  
*************** mio_expr (gfc_expr ** ep)
*** 2598,2603 ****
--- 2622,2629 ----
    mio_typespec (&e->ts);
    mio_integer (&e->rank);
  
+   fix_mio_expr (e);
+ 
    switch (e->expr_type)
      {
      case EXPR_OP:
Index: gcc/testsuite/gfortran.dg/nested_modules_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/nested_modules_6.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/nested_modules_6.f90	(revision 0)
***************
*** 0 ****
--- 1,35 ----
+ ! { dg-do compile }
+ ! Test the patch for PR30084 in which the reference to SIZE
+ ! in function diag caused a segfault in module.c.
+ !
+ ! Contributed by Troban Trumsko <trumsko@yahoo.com>
+ ! and reduced by Steve Kargl <kargl@gcc.gnu.org>
+ !
+ module tao_random_numbers
+   integer, dimension(10) :: s_buffer
+   integer :: s_last = size (s_buffer)
+ end module tao_random_numbers
+ 
+ module linalg
+   contains
+   function diag (a) result (d)
+     real, dimension(:,:), intent(in) :: a
+     real, dimension(min(size(a,dim=1),size(a,dim=2))) :: d
+     integer :: i
+     do i = 1, min(size(a, dim = 1), size(a, dim = 2))
+        d(i) = a(i,i)
+     end do
+   end function diag
+ end module linalg
+ 
+ module vamp_rest
+   use tao_random_numbers
+   use linalg
+ end module vamp_rest
+ 
+   use vamp_rest
+   real :: x(2, 2) = reshape ([1.,2.,3.,4.], [2,2])
+   print *, s_last
+   print *, diag (x)
+ end
+ ! { dg-final { cleanup-modules "tao_random_numbers linalg vamp_rest" } }