blob: 0f1e9b67287b62b2d8a9ef266247cbf25d0e0e15 [file] [log] [blame]
! { dg-do run }
! Test the fix for pr69011, preventing an ICE and making sure
! that the correct dynamic type is used.
!
! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
! Andre Vehreschild <vehre@gcc.gnu.org>
!
module m1
implicit none
private
public :: basetype
type:: basetype
integer :: i
contains
endtype basetype
abstract interface
endinterface
endmodule m1
module m2
use m1, only : basetype
implicit none
integer, parameter :: I_P = 4
private
public :: factory, exttype
type, extends(basetype) :: exttype
integer :: i2
contains
endtype exttype
type :: factory
integer(I_P) :: steps=-1
contains
procedure, pass(self), public :: construct
endtype factory
contains
function construct(self, previous)
class(basetype), intent(INOUT) :: previous(1:)
class(factory), intent(IN) :: self
class(basetype), pointer :: construct
allocate(construct, source=previous(self%steps))
endfunction construct
endmodule m2
use m2
use m1
class(factory), allocatable :: c1
class(exttype), allocatable :: prev(:)
class(basetype), pointer :: d
allocate(c1)
allocate(prev(2))
prev(:)%i = [ 2, 3]
prev(:)%i2 = [ 5, 6]
c1%steps= 1
d=> c1%construct(prev)
if (.not. associated(d) ) STOP 1
select type (d)
class is (exttype)
if (d%i2 /= 5) STOP 2
class default
STOP 3
end select
if (d%i /= 2) STOP 4
deallocate(c1)
deallocate(prev)
deallocate(d)
end