|
111
|
1 ! { dg-do run }
|
|
|
2 !
|
|
|
3 ! Test move_alloc for polymorphic scalars
|
|
|
4 !
|
|
|
5 ! The following checks that a move_alloc from
|
|
|
6 ! a TYPE to a CLASS works
|
|
|
7 !
|
|
|
8 module myalloc
|
|
|
9 implicit none
|
|
|
10
|
|
|
11 type :: base_type
|
|
|
12 integer :: i =2
|
|
|
13 end type base_type
|
|
|
14
|
|
|
15 type, extends(base_type) :: extended_type
|
|
|
16 integer :: j = 77
|
|
|
17 end type extended_type
|
|
|
18 contains
|
|
|
19 subroutine myallocate (a)
|
|
|
20 class(base_type), allocatable, intent(inout) :: a
|
|
|
21 type(extended_type), allocatable :: tmp
|
|
|
22
|
|
|
23 allocate (tmp)
|
|
|
24
|
|
131
|
25 if (tmp%i /= 2 .or. tmp%j /= 77) STOP 1
|
|
111
|
26 tmp%i = 5
|
|
|
27 tmp%j = 88
|
|
|
28
|
|
|
29 select type(a)
|
|
|
30 type is(base_type)
|
|
131
|
31 if (a%i /= -44) STOP 2
|
|
111
|
32 a%i = -99
|
|
|
33 class default
|
|
131
|
34 STOP 3
|
|
111
|
35 end select
|
|
|
36
|
|
|
37 call move_alloc (from=tmp, to=a)
|
|
|
38
|
|
|
39 select type(a)
|
|
|
40 type is(extended_type)
|
|
131
|
41 if (a%i /= 5) STOP 4
|
|
|
42 if (a%j /= 88) STOP 5
|
|
111
|
43 a%i = 123
|
|
|
44 a%j = 9498
|
|
|
45 class default
|
|
131
|
46 STOP 6
|
|
111
|
47 end select
|
|
|
48
|
|
131
|
49 if (allocated (tmp)) STOP 7
|
|
111
|
50 end subroutine myallocate
|
|
|
51 end module myalloc
|
|
|
52
|
|
|
53 program main
|
|
|
54 use myalloc
|
|
|
55 implicit none
|
|
|
56 class(base_type), allocatable :: a
|
|
|
57
|
|
|
58 allocate (a)
|
|
|
59
|
|
|
60 select type(a)
|
|
|
61 type is(base_type)
|
|
131
|
62 if (a%i /= 2) STOP 8
|
|
111
|
63 a%i = -44
|
|
|
64 class default
|
|
131
|
65 STOP 9
|
|
111
|
66 end select
|
|
|
67
|
|
|
68 call myallocate (a)
|
|
|
69
|
|
|
70 select type(a)
|
|
|
71 type is(extended_type)
|
|
131
|
72 if (a%i /= 123) STOP 10
|
|
|
73 if (a%j /= 9498) STOP 11
|
|
111
|
74 class default
|
|
131
|
75 STOP 12
|
|
111
|
76 end select
|
|
|
77 end program main
|
