mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
76 lines
1.6 KiB
Fortran
76 lines
1.6 KiB
Fortran
! { dg-do run }
|
|
!
|
|
! Test the fix for PR57116 as part of the overall fix for PR34640.
|
|
!
|
|
! Contributed by Reinhold Bader <Bader@lrz.de>
|
|
!
|
|
module mod_rtti_ptr
|
|
implicit none
|
|
type :: foo
|
|
real :: v
|
|
integer :: i
|
|
end type foo
|
|
contains
|
|
subroutine extract(this, v, ic)
|
|
class(*), target :: this(:)
|
|
real, pointer :: v(:)
|
|
integer :: ic
|
|
select type (this)
|
|
type is (real)
|
|
v => this(ic:)
|
|
class is (foo)
|
|
v => this(ic:)%v
|
|
end select
|
|
end subroutine extract
|
|
end module
|
|
|
|
program prog_rtti_ptr
|
|
use mod_rtti_ptr
|
|
class(*), allocatable, target :: o(:)
|
|
real, pointer :: v(:)
|
|
|
|
allocate(o(3), source=[1.0, 2.0, 3.0])
|
|
call extract(o, v, 2)
|
|
if (size(v) == 2 .and. all (v == [2.0, 3.0])) then
|
|
deallocate(o)
|
|
else
|
|
STOP 1
|
|
end if
|
|
|
|
allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)])
|
|
call extract(o, v, 2)
|
|
if (size(v) == 2 .and. all (v == [4.0, 5.0])) then
|
|
deallocate(o)
|
|
else
|
|
STOP 2
|
|
end if
|
|
|
|
! The rest tests the case in comment 2 <janus@gcc.gnu.org>
|
|
|
|
call extract1 (v, 1)
|
|
if (any (v /= [1.0, 2.0])) STOP 3
|
|
call extract1 (v, 2) ! Call to deallocate pointer.
|
|
|
|
contains
|
|
subroutine extract1(v, flag)
|
|
type :: foo
|
|
real :: v
|
|
character(4) :: str
|
|
end type
|
|
class(foo), pointer, save :: this(:)
|
|
real, pointer :: v(:)
|
|
integer :: flag
|
|
|
|
if (flag == 1) then
|
|
allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")])
|
|
select type (this)
|
|
class is (foo)
|
|
v => this(1:2)%v
|
|
end select
|
|
else
|
|
deallocate (this)
|
|
end if
|
|
end subroutine
|
|
|
|
end program prog_rtti_ptr
|