mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-10 16:17:24 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Tobias Burnus 2010-07-29 23:07:34 +02:00 committed by Tobias Burnus
parent 6a68e29dc5
commit 6a0184955c
6 changed files with 286 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
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

19
gcc/fortran/trans-decl.c
View File

@ -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,

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
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

21
gcc/testsuite/gfortran.dg/whole_file_25.f90 Normal file
View File

@ -0,0 +1,21 @@
! { 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" } }

26
gcc/testsuite/gfortran.dg/whole_file_26.f90 Normal file
View File

@ -0,0 +1,26 @@
! { 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" } }

210
gcc/testsuite/gfortran.dg/whole_file_27.f90 Normal file
View File

@ -0,0 +1,210 @@
! { 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" } }