1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
! { 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
|
