[Patch, Fortran] SELECT TYPE via ASSOCIATE

[Salvatore Filippone]

Il giorno gio, 26/08/2010 alle 17.25 +0200, Daniel Kraft ha scritto:
> Hi Salvatore,
> 
> thanks for your input ;)
> Is this something that worked before?  I'd be very grateful for a small 
> and self-contained example, and then I hope that I can figure out what 
> the problem with my patch is :)
> 
> Thanks a lot,
> Daniel
> 

Here you go; I've been able to tseal 10 mins (while waiting for a
colleague). 
It's a variation of the original test case, and produces: 
[sfilippo@donald bug20]$ ./bug20_dx 
 Dynamic type on entry: XBASE   
 Not implemented yet 
 Dynamic type CLASS DEFAULT clause: DBASE   

which is pure nonsense :-) 

Salvatore 


-------------------------------
module base_mat_mod

  type  :: base_sparse_mat
  contains
    procedure, pass(a) :: get_fmt => base_get_fmt
  end type base_sparse_mat

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

end module base_mat_mod

module d_base_mat_mod
  
  use base_mat_mod
  type, extends(base_sparse_mat) :: d_base_sparse_mat
    integer, allocatable :: v(:)
  contains
    procedure, pass(a) :: get_fmt => d_base_get_fmt
  end type d_base_sparse_mat

  type, extends(d_base_sparse_mat) :: x_base_sparse_mat
  contains
    procedure, pass(a) :: get_fmt => x_base_get_fmt
  end type x_base_sparse_mat

contains
  function d_base_get_fmt(a) result(res)
    implicit none 
    class(d_base_sparse_mat), intent(in) :: a
    character(len=5) :: res
    res = 'DBASE'
  end function d_base_get_fmt
  function x_base_get_fmt(a) result(res)
    implicit none 
    class(x_base_sparse_mat), intent(in) :: a
    character(len=5) :: res
    res = 'XBASE'
  end function x_base_get_fmt

end module d_base_mat_mod

module d_mat_mod

  use d_base_mat_mod

  type :: d_sparse_mat

    class(d_base_sparse_mat), allocatable  :: a 

  end type d_sparse_mat


contains

  subroutine doit(a)
    type(d_sparse_mat), intent(in) :: a
    integer :: i , nv
    character(len=8) :: string

    string=a%a%get_fmt()
    write(0,*) 'Dynamic type on entry: ',string
    select type(aa => a%a)
    type is (d_base_sparse_mat)
      nv = size(aa%v)
      write(0,*) 'NV = ',nv
      string=aa%get_fmt()
      write(0,*) 'Dynamic type TYPE IS clause: ',string
   
    class default 
      write(0,*) 'Not implemented yet '
      string=aa%get_fmt()
      write(0,*) 'Dynamic type CLASS DEFAULT clause: ',string
    end select
  end subroutine doit

end module d_mat_mod


program bug20
  use d_mat_mod
  type(d_sparse_mat) :: a
  integer, parameter :: nv=10
  integer :: i

  allocate(x_base_sparse_mat :: a%a)
  allocate(a%a%v(nv))
  a%a%v(:) = (/ (i, i=1,nv) /)
  call doit(a)
end program bug20