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

gcc/fortran/ChangeLog

 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
 	* resolve.c (resolve_fl_variable): Handle polymorphic allocatables.

gcc/fortran/module.c

@@ -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++;

gcc/fortran/trans-expr.c

@@ -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);

gcc/testsuite/ChangeLog

+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>
 

gcc/testsuite/gfortran.dg/class_37.f03

+! { 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
+
+