|
111
|
1 ! { dg-do run }
|
|
|
2 !
|
|
|
3 ! Test the fix for PR57116 as part of the overall fix for PR34640.
|
|
|
4 !
|
|
|
5 ! Contributed by Reinhold Bader <Bader@lrz.de>
|
|
|
6 !
|
|
|
7 module mod_rtti_ptr
|
|
|
8 implicit none
|
|
|
9 type :: foo
|
|
|
10 real :: v
|
|
|
11 integer :: i
|
|
|
12 end type foo
|
|
|
13 contains
|
|
|
14 subroutine extract(this, v, ic)
|
|
|
15 class(*), target :: this(:)
|
|
|
16 real, pointer :: v(:)
|
|
|
17 integer :: ic
|
|
|
18 select type (this)
|
|
|
19 type is (real)
|
|
|
20 v => this(ic:)
|
|
|
21 class is (foo)
|
|
|
22 v => this(ic:)%v
|
|
|
23 end select
|
|
|
24 end subroutine extract
|
|
|
25 end module
|
|
|
26
|
|
|
27 program prog_rtti_ptr
|
|
|
28 use mod_rtti_ptr
|
|
|
29 class(*), allocatable, target :: o(:)
|
|
|
30 real, pointer :: v(:)
|
|
|
31
|
|
|
32 allocate(o(3), source=[1.0, 2.0, 3.0])
|
|
|
33 call extract(o, v, 2)
|
|
|
34 if (size(v) == 2 .and. all (v == [2.0, 3.0])) then
|
|
|
35 deallocate(o)
|
|
|
36 else
|
|
131
|
37 STOP 1
|
|
111
|
38 end if
|
|
|
39
|
|
|
40 allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)])
|
|
|
41 call extract(o, v, 2)
|
|
|
42 if (size(v) == 2 .and. all (v == [4.0, 5.0])) then
|
|
|
43 deallocate(o)
|
|
|
44 else
|
|
131
|
45 STOP 2
|
|
111
|
46 end if
|
|
|
47
|
|
|
48 ! The rest tests the case in comment 2 <janus@gcc.gnu.org>
|
|
|
49
|
|
|
50 call extract1 (v, 1)
|
|
131
|
51 if (any (v /= [1.0, 2.0])) STOP 3
|
|
111
|
52 call extract1 (v, 2) ! Call to deallocate pointer.
|
|
|
53
|
|
|
54 contains
|
|
|
55 subroutine extract1(v, flag)
|
|
|
56 type :: foo
|
|
|
57 real :: v
|
|
|
58 character(4) :: str
|
|
|
59 end type
|
|
|
60 class(foo), pointer, save :: this(:)
|
|
|
61 real, pointer :: v(:)
|
|
|
62 integer :: flag
|
|
|
63
|
|
|
64 if (flag == 1) then
|
|
|
65 allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")])
|
|
|
66 select type (this)
|
|
|
67 class is (foo)
|
|
|
68 v => this(1:2)%v
|
|
|
69 end select
|
|
|
70 else
|
|
|
71 deallocate (this)
|
|
|
72 end if
|
|
|
73 end subroutine
|
|
|
74
|
|
|
75 end program prog_rtti_ptr
|
