re PR fortran/47082 ([OOP] ICE in gfc_conv_component_ref)
2011-02-02 Janus Weil <janus@gcc.gnu.org> Paul Thomas <pault@gcc.gnu.org> PR fortran/47082 * trans-expr.c (gfc_trans_class_init_assign): Add call to gfc_get_derived_type. * module.c (read_cleanup): Do not use unique_symtrees for vtabs or vtypes. 2011-02-02 Janus Weil <janus@gcc.gnu.org> Paul Thomas <pault@gcc.gnu.org> PR fortran/47082 * gfortran.dg/class_37.f03 : New test. Co-Authored-By: Paul Thomas <pault@gcc.gnu.org> From-SVN: r169767
This commit is contained in:
Janus Weil
Paul Thomas
parent
932e32375a
commit
8e2bc95be5
|
|
@ -1,3 +1,12 @@
|
|||
2011-02-02 Janus Weil <janus@gcc.gnu.org>
|
||||
Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/47082
|
||||
* trans-expr.c (gfc_trans_class_init_assign): Add call to
|
||||
gfc_get_derived_type.
|
||||
* module.c (read_cleanup): Do not use unique_symtrees for vtabs
|
||||
or vtypes.
|
||||
|
||||
2011-02-02 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/47572
|
||||
|
|
|
|||
|
|
@ -4219,9 +4219,23 @@ read_cleanup (pointer_info *p)
|
|||
|
||||
if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
|
||||
{
|
||||
gfc_namespace *ns;
|
||||
/* Add hidden symbols to the symtree. */
|
||||
q = get_integer (p->u.rsym.ns);
|
||||
st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
|
||||
ns = (gfc_namespace *) q->u.pointer;
|
||||
|
||||
if (!p->u.rsym.sym->attr.vtype
|
||||
&& !p->u.rsym.sym->attr.vtab)
|
||||
st = gfc_get_unique_symtree (ns);
|
||||
else
|
||||
{
|
||||
/* There is no reason to use 'unique_symtrees' for vtabs or
|
||||
vtypes - their name is fine for a symtree and reduces the
|
||||
namespace pollution. */
|
||||
st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
|
||||
if (!st)
|
||||
st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
|
||||
}
|
||||
|
||||
st->n.sym = p->u.rsym.sym;
|
||||
st->n.sym->refs++;
|
||||
|
|
|
|||
|
|
@ -6300,6 +6300,11 @@ gfc_trans_class_init_assign (gfc_code *code)
|
|||
|
||||
rhs = gfc_copy_expr (code->expr1);
|
||||
gfc_add_vptr_component (rhs);
|
||||
|
||||
/* Make sure that the component backend_decls have been built, which
|
||||
will not have happened if the derived types concerned have not
|
||||
been referenced. */
|
||||
gfc_get_derived_type (rhs->ts.u.derived);
|
||||
gfc_add_def_init_component (rhs);
|
||||
|
||||
sz = gfc_copy_expr (code->expr1);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2011-02-02 Janus Weil <janus@gcc.gnu.org>
|
||||
Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/47082
|
||||
* gfortran.dg/class_37.f03 : New test.
|
||||
|
||||
2011-02-02 Sebastian Pop <sebastian.pop@amd.com>
|
||||
Richard Guenther <rguenther@suse.de>
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,263 @@
|
|||
! { dg-do compile }
|
||||
! Test fix for PR47082, in which an ICE in the ALLOCATE at line 248.
|
||||
!
|
||||
! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
|
||||
!
|
||||
module psb_penv_mod
|
||||
|
||||
interface psb_init
|
||||
module procedure psb_init
|
||||
end interface
|
||||
|
||||
interface psb_exit
|
||||
module procedure psb_exit
|
||||
end interface
|
||||
|
||||
interface psb_info
|
||||
module procedure psb_info
|
||||
end interface
|
||||
|
||||
integer, private, save :: nctxt=0
|
||||
|
||||
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine psb_init(ictxt,np,basectxt,ids)
|
||||
implicit none
|
||||
integer, intent(out) :: ictxt
|
||||
integer, intent(in), optional :: np, basectxt, ids(:)
|
||||
|
||||
|
||||
ictxt = nctxt
|
||||
nctxt = nctxt + 1
|
||||
|
||||
end subroutine psb_init
|
||||
|
||||
subroutine psb_exit(ictxt,close)
|
||||
implicit none
|
||||
integer, intent(inout) :: ictxt
|
||||
logical, intent(in), optional :: close
|
||||
|
||||
nctxt = max(0, nctxt - 1)
|
||||
|
||||
end subroutine psb_exit
|
||||
|
||||
|
||||
subroutine psb_info(ictxt,iam,np)
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(out) :: iam, np
|
||||
|
||||
iam = 0
|
||||
np = 1
|
||||
|
||||
end subroutine psb_info
|
||||
|
||||
|
||||
end module psb_penv_mod
|
||||
|
||||
|
||||
module psb_indx_map_mod
|
||||
|
||||
type :: psb_indx_map
|
||||
|
||||
integer :: state = -1
|
||||
integer :: ictxt = -1
|
||||
integer :: mpic = -1
|
||||
integer :: global_rows = -1
|
||||
integer :: global_cols = -1
|
||||
integer :: local_rows = -1
|
||||
integer :: local_cols = -1
|
||||
|
||||
|
||||
end type psb_indx_map
|
||||
|
||||
end module psb_indx_map_mod
|
||||
|
||||
|
||||
|
||||
module psb_gen_block_map_mod
|
||||
use psb_indx_map_mod
|
||||
|
||||
type, extends(psb_indx_map) :: psb_gen_block_map
|
||||
integer :: min_glob_row = -1
|
||||
integer :: max_glob_row = -1
|
||||
integer, allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:)
|
||||
contains
|
||||
|
||||
procedure, pass(idxmap) :: gen_block_map_init => block_init
|
||||
|
||||
end type psb_gen_block_map
|
||||
|
||||
private :: block_init
|
||||
|
||||
contains
|
||||
|
||||
subroutine block_init(idxmap,ictxt,nl,info)
|
||||
use psb_penv_mod
|
||||
implicit none
|
||||
class(psb_gen_block_map), intent(inout) :: idxmap
|
||||
integer, intent(in) :: ictxt, nl
|
||||
integer, intent(out) :: info
|
||||
! To be implemented
|
||||
integer :: iam, np, i, j, ntot
|
||||
integer, allocatable :: vnl(:)
|
||||
|
||||
info = 0
|
||||
call psb_info(ictxt,iam,np)
|
||||
if (np < 0) then
|
||||
info = -1
|
||||
return
|
||||
end if
|
||||
|
||||
allocate(vnl(0:np),stat=info)
|
||||
if (info /= 0) then
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
|
||||
vnl(:) = 0
|
||||
vnl(iam) = nl
|
||||
ntot = sum(vnl)
|
||||
vnl(1:np) = vnl(0:np-1)
|
||||
vnl(0) = 0
|
||||
do i=1,np
|
||||
vnl(i) = vnl(i) + vnl(i-1)
|
||||
end do
|
||||
if (ntot /= vnl(np)) then
|
||||
! !$ write(0,*) ' Mismatch in block_init ',ntot,vnl(np)
|
||||
end if
|
||||
|
||||
idxmap%global_rows = ntot
|
||||
idxmap%global_cols = ntot
|
||||
idxmap%local_rows = nl
|
||||
idxmap%local_cols = nl
|
||||
idxmap%ictxt = ictxt
|
||||
idxmap%state = 1
|
||||
|
||||
idxmap%min_glob_row = vnl(iam)+1
|
||||
idxmap%max_glob_row = vnl(iam+1)
|
||||
call move_alloc(vnl,idxmap%vnl)
|
||||
allocate(idxmap%loc_to_glob(nl),stat=info)
|
||||
if (info /= 0) then
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine block_init
|
||||
|
||||
end module psb_gen_block_map_mod
|
||||
|
||||
|
||||
module psb_descriptor_type
|
||||
use psb_indx_map_mod
|
||||
|
||||
implicit none
|
||||
|
||||
|
||||
type psb_desc_type
|
||||
integer, allocatable :: matrix_data(:)
|
||||
integer, allocatable :: halo_index(:)
|
||||
integer, allocatable :: ext_index(:)
|
||||
integer, allocatable :: ovrlap_index(:)
|
||||
integer, allocatable :: ovrlap_elem(:,:)
|
||||
integer, allocatable :: ovr_mst_idx(:)
|
||||
integer, allocatable :: bnd_elem(:)
|
||||
class(psb_indx_map), allocatable :: indxmap
|
||||
integer, allocatable :: lprm(:)
|
||||
type(psb_desc_type), pointer :: base_desc => null()
|
||||
integer, allocatable :: idx_space(:)
|
||||
end type psb_desc_type
|
||||
|
||||
|
||||
end module psb_descriptor_type
|
||||
|
||||
module psb_cd_if_tools_mod
|
||||
|
||||
use psb_descriptor_type
|
||||
use psb_gen_block_map_mod
|
||||
|
||||
interface psb_cdcpy
|
||||
subroutine psb_cdcpy(desc_in, desc_out, info)
|
||||
use psb_descriptor_type
|
||||
|
||||
implicit none
|
||||
!....parameters...
|
||||
|
||||
type(psb_desc_type), intent(in) :: desc_in
|
||||
type(psb_desc_type), intent(out) :: desc_out
|
||||
integer, intent(out) :: info
|
||||
end subroutine psb_cdcpy
|
||||
end interface
|
||||
|
||||
|
||||
end module psb_cd_if_tools_mod
|
||||
|
||||
module psb_cd_tools_mod
|
||||
|
||||
use psb_cd_if_tools_mod
|
||||
|
||||
interface psb_cdall
|
||||
|
||||
subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck)
|
||||
use psb_descriptor_type
|
||||
implicit None
|
||||
Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl
|
||||
integer, intent(in) :: flag
|
||||
logical, intent(in) :: repl, globalcheck
|
||||
integer, intent(out) :: info
|
||||
type(psb_desc_type), intent(out) :: desc
|
||||
|
||||
optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck
|
||||
end subroutine psb_cdall
|
||||
|
||||
end interface
|
||||
|
||||
end module psb_cd_tools_mod
|
||||
module psb_base_tools_mod
|
||||
use psb_cd_tools_mod
|
||||
end module psb_base_tools_mod
|
||||
|
||||
subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck)
|
||||
use psb_descriptor_type
|
||||
use psb_gen_block_map_mod
|
||||
use psb_base_tools_mod, psb_protect_name => psb_cdall
|
||||
implicit None
|
||||
Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl
|
||||
integer, intent(in) :: flag
|
||||
logical, intent(in) :: repl, globalcheck
|
||||
integer, intent(out) :: info
|
||||
type(psb_desc_type), intent(out) :: desc
|
||||
|
||||
optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck
|
||||
integer :: err_act, n_, flag_, i, me, np, nlp, nnv, lr
|
||||
integer, allocatable :: itmpsz(:)
|
||||
|
||||
|
||||
|
||||
info = 0
|
||||
desc%base_desc => null()
|
||||
if (allocated(desc%indxmap)) then
|
||||
write(0,*) 'Allocated on an intent(OUT) var?'
|
||||
end if
|
||||
|
||||
allocate(psb_gen_block_map :: desc%indxmap, stat=info)
|
||||
if (info == 0) then
|
||||
select type(aa => desc%indxmap)
|
||||
type is (psb_gen_block_map)
|
||||
call aa%gen_block_map_init(ictxt,nl,info)
|
||||
class default
|
||||
! This cannot happen
|
||||
info = -1
|
||||
end select
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_cdall
|
||||
|
||||
|
||||
Loading…
Reference in New Issue