re PR fortran/45087 (-fwhole-program: Miscompiled due to wrong decls)

2010-07-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/45087
        PR fortran/45125
        * trans-decl.c (gfc_get_extern_function_decl): Correctly handle
        external procedure declarations in modules.
        (gfc_get_symbol_decl): Modify assert.

2010-07-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/45087
        PR fortran/45125
        * gfortran.dg/whole_file_25.f90: New.
        * gfortran.dg/whole_file_26.f90: New.
        * gfortran.dg/whole_file_27.f90: New.

From-SVN: r162696

gcc/fortran/ChangeLog

+2010-07-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45087
+	PR fortran/45125
+	* trans-decl.c (gfc_get_extern_function_decl): Correctly handle
+	external procedure declarations in modules.
+	(gfc_get_symbol_decl): Modify assert.
+
 2010-07-29  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/44962

gcc/fortran/trans-decl.c

@@ -1045,7 +1045,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 
   gcc_assert (sym->attr.referenced
 		|| sym->attr.use_assoc
-		|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
+		|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
+		|| (sym->module && sym->attr.if_source != IFSRC_DECL
+		    && sym->backend_decl));
 
   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
@@ -1409,7 +1411,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
 
   if (gfc_option.flag_whole_file
-	&& !sym->attr.use_assoc
+	&& (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
 	&& !sym->backend_decl
 	&& gsym && gsym->ns
 	&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
@@ -1450,12 +1452,17 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
 	    }
 	}
       else
-	{
-	  sym->backend_decl = gsym->ns->proc_name->backend_decl;
-	}
+	sym->backend_decl = gsym->ns->proc_name->backend_decl;
 
       if (sym->backend_decl)
-	return sym->backend_decl;
+	{
+	  /* Avoid problems of double deallocation of the backend declaration
+	     later in gfc_trans_use_stmts; cf. PR 45087.  */
+	  if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
+	    sym->attr.use_assoc = 0;
+
+	  return sym->backend_decl;
+	}
     }
 
   /* See if this is a module procedure from the same file.  If so,

gcc/testsuite/ChangeLog

+2010-07-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45087
+	PR fortran/45125
+	* gfortran.dg/whole_file_25.f90: New.
+	* gfortran.dg/whole_file_26.f90: New.
+	* gfortran.dg/whole_file_27.f90: New.
+
 2010-07-29  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/44962

gcc/testsuite/gfortran.dg/whole_file_25.f90

+! { dg-do compile }
+! { dg-options "-fwhole-program" }
+!
+! PR fortran/45087
+!
+
+module ints
+   INTERFACE
+      SUBROUTINE NOZZLE()
+      END SUBROUTINE NOZZLE
+   END INTERFACE
+end module ints
+
+      SUBROUTINE NOZZLE()
+      END SUBROUTINE NOZZLE
+      program CORTESA 
+      USE INTS
+      CALL NOZZLE ()
+      END program CORTESA
+
+! { dg-final { cleanup-modules "ints" } }

gcc/testsuite/gfortran.dg/whole_file_26.f90

+! { dg-do compile }
+! { dg-options "-fwhole-program  --param ggc-min-expand=0 --param ggc-min-heapsize=0" }
+!
+! PR fortran/45087
+!
+
+module INTS
+  interface
+    subroutine NEXT
+    end subroutine NEXT
+    subroutine VALUE()
+    end subroutine VALUE
+  end interface
+end module INTS
+
+subroutine NEXT
+end subroutine NEXT
+
+subroutine VALUE()
+  use INTS, only: NEXT
+  CALL NEXT
+end subroutine VALUE
+
+end
+
+! { dg-final { cleanup-modules "ints" } }

gcc/testsuite/gfortran.dg/whole_file_27.f90

+! { dg-do compile }
+!
+! PR fortran/45125
+!
+! Contributed by Salvatore Filippone and Dominique d'Humieres.
+!
+
+module const_mod
+  ! This is the default integer
+  integer, parameter  :: ndig=8
+  integer, parameter  :: int_k_ = selected_int_kind(ndig)
+  ! This is an 8-byte  integer, and normally different from default integer. 
+  integer, parameter  :: longndig=12
+  integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
+  !
+  ! These must be the kind parameter corresponding to MPI_DOUBLE_PRECISION
+  ! and MPI_REAL
+  !
+  integer, parameter  :: dpk_ = kind(1.d0)
+  integer, parameter  :: spk_ = kind(1.e0)
+  integer, save       :: sizeof_dp, sizeof_sp
+  integer, save       :: sizeof_int, sizeof_long_int
+  integer, save       :: mpi_integer
+
+  integer, parameter :: invalid_ = -1 
+  integer, parameter :: spmat_null_=0, spmat_bld_=1
+  integer, parameter :: spmat_asb_=2, spmat_upd_=4
+
+  !
+  ! 
+  !     Error constants
+  integer, parameter, public :: success_=0
+  integer, parameter, public :: err_iarg_neg_=10
+end module const_mod
+module base_mat_mod
+  
+  use const_mod 
+
+
+  type  :: base_sparse_mat
+    integer, private     :: m, n
+    integer, private     :: state, duplicate 
+    logical, private     :: triangle, unitd, upper, sorted
+  contains 
+
+    procedure, pass(a) :: get_fmt => base_get_fmt
+    procedure, pass(a) :: set_null => base_set_null
+    procedure, pass(a) :: allocate_mnnz => base_allocate_mnnz
+    generic,   public  :: allocate => allocate_mnnz
+  end type base_sparse_mat
+
+  interface 
+    subroutine  base_allocate_mnnz(m,n,a,nz) 
+      import base_sparse_mat, long_int_k_
+      integer, intent(in) :: m,n
+      class(base_sparse_mat), intent(inout) :: a
+      integer, intent(in), optional  :: nz
+    end subroutine base_allocate_mnnz
+  end interface
+
+contains
+
+  function base_get_fmt(a) result(res)
+    implicit none 
+    class(base_sparse_mat), intent(in) :: a
+    character(len=5) :: res
+    res = 'NULL'
+  end function base_get_fmt
+
+  subroutine  base_set_null(a) 
+    implicit none 
+    class(base_sparse_mat), intent(inout) :: a
+
+    a%state = spmat_null_
+  end subroutine base_set_null
+
+
+end module base_mat_mod
+
+module d_base_mat_mod
+  
+  use base_mat_mod
+
+  type, extends(base_sparse_mat) :: d_base_sparse_mat
+  contains
+  end type d_base_sparse_mat
+  
+  
+  
+  type, extends(d_base_sparse_mat) :: d_coo_sparse_mat
+    
+    integer              :: nnz
+    integer, allocatable :: ia(:), ja(:)
+    real(dpk_), allocatable :: val(:)
+    
+  contains
+    
+    procedure, pass(a) :: get_fmt      => d_coo_get_fmt
+    procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz
+    
+  end type d_coo_sparse_mat
+  
+  
+  interface
+    subroutine  d_coo_allocate_mnnz(m,n,a,nz) 
+      import d_coo_sparse_mat
+      integer, intent(in) :: m,n
+      class(d_coo_sparse_mat), intent(inout) :: a
+      integer, intent(in), optional :: nz
+    end subroutine d_coo_allocate_mnnz
+  end interface
+  
+contains 
+  
+  function d_coo_get_fmt(a) result(res)
+    implicit none 
+    class(d_coo_sparse_mat), intent(in) :: a
+    character(len=5) :: res
+    res = 'COO'
+  end function d_coo_get_fmt
+  
+end module d_base_mat_mod
+
+subroutine  base_allocate_mnnz(m,n,a,nz) 
+  use base_mat_mod, protect_name => base_allocate_mnnz
+  implicit none 
+  integer, intent(in) :: m,n
+  class(base_sparse_mat), intent(inout) :: a
+  integer, intent(in), optional  :: nz
+  Integer :: err_act
+  character(len=20)  :: name='allocate_mnz', errfmt
+  logical, parameter :: debug=.false.
+
+  ! This is the base version. If we get here
+  ! it means the derived class is incomplete,
+  ! so we throw an error.
+  errfmt=a%get_fmt()
+  write(0,*) 'Error: Missing ovverriding impl for allocate in class ',errfmt
+
+  return
+
+end subroutine base_allocate_mnnz
+
+subroutine  d_coo_allocate_mnnz(m,n,a,nz) 
+  use d_base_mat_mod, protect_name => d_coo_allocate_mnnz
+  implicit none 
+  integer, intent(in) :: m,n
+  class(d_coo_sparse_mat), intent(inout) :: a
+  integer, intent(in), optional :: nz
+  Integer :: err_act, info, nz_
+  character(len=20)  :: name='allocate_mnz'
+  logical, parameter :: debug=.false.
+
+  info = success_
+  if (m < 0) then 
+    info = err_iarg_neg_
+  endif
+  if (n < 0) then 
+    info = err_iarg_neg_
+  endif
+  if (present(nz)) then 
+    nz_ = nz
+  else
+    nz_ = max(7*m,7*n,1)
+  end if
+  if (nz_ < 0) then 
+    info = err_iarg_neg_
+  endif
+! !$  if (info == success_) call realloc(nz_,a%ia,info)
+! !$  if (info == success_) call realloc(nz_,a%ja,info)
+! !$  if (info == success_) call realloc(nz_,a%val,info)
+  if (info == success_) then 
+! !$    call a%set_nrows(m)
+! !$    call a%set_ncols(n)
+! !$    call a%set_nzeros(0)
+! !$    call a%set_bld()
+! !$    call a%set_triangle(.false.)
+! !$    call a%set_unit(.false.)
+! !$    call a%set_dupl(dupl_def_)
+    write(0,*) 'Allocated COO succesfully, should now set components'
+  else 
+    write(0,*) 'COO allocation failed somehow. Go figure'
+  end if
+  return
+
+end subroutine d_coo_allocate_mnnz
+
+
+program d_coo_err
+  use d_base_mat_mod
+  implicit none
+
+  integer            :: ictxt, iam, np
+
+  ! solver parameters
+  type(d_coo_sparse_mat) :: acoo
+  
+  ! other variables
+  integer nnz, n
+
+  n   = 32
+  nnz = n*9
+  
+  call acoo%set_null()
+  call acoo%allocate(n,n,nz=nnz)
+
+  stop
+end program d_coo_err
+
+! { dg-final { cleanup-modules "base_mat_mod const_mod d_base_mat_mod" } }