URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [class_allocate_1.f03] - Blame information for rev 720

Go to most recent revision | Details | Compare with Previous | View Log


! { dg-do run }
!
! Allocating CLASS variables.
!
! Contributed by Janus Weil 
 
 implicit none
 
 type t1
   integer :: comp = 5
   class(t1),pointer :: cc
 end type
 
 type, extends(t1) :: t2
   integer :: j
 end type
 
 type, extends(t2) :: t3
   integer :: k
 end type
 
 class(t1),pointer :: cp, cp2
 type(t2),pointer :: cp3
 type(t3) :: x
 integer :: i
 
 
 ! (1) check that vindex is set correctly (for different cases)
 
 i = 0
 allocate(cp)
 select type (cp)
 type is (t1)
   i = 1
 type is (t2)
   i = 2
 type is (t3)
   i = 3
 end select
 deallocate(cp)
 if (i /= 1) call abort()
 
 i = 0
 allocate(t2 :: cp)
 select type (cp)
 type is (t1)
   i = 1
 type is (t2)
   i = 2
 type is (t3)
   i = 3
 end select
 deallocate(cp)
 if (i /= 2) call abort()
 
 i = 0
 allocate(cp, source = x)
 select type (cp)
 type is (t1)
   i = 1
 type is (t2)
   i = 2
 type is (t3)
   i = 3
 end select
 deallocate(cp)
 if (i /= 3) call abort()
 
 i = 0
 allocate(t2 :: cp2)
 allocate(cp, source = cp2)
 allocate(t2 :: cp3)
 allocate(cp, source=cp3)
 select type (cp)
 type is (t1)
   i = 1
 type is (t2)
   i = 2
 type is (t3)
   i = 3
 end select
 deallocate(cp)
 deallocate(cp2)
 if (i /= 2) call abort()
 
 
 ! (2) check initialization (default initialization vs. SOURCE)
 
 allocate(cp)
 if (cp%comp /= 5) call abort()
 deallocate(cp)
 
 x%comp = 4
 allocate(cp, source=x)
 if (cp%comp /= 4) call abort()
 deallocate(cp)
 
end

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`!`
3			`! Allocating CLASS variables.`
4			`!`
5			`! Contributed by Janus Weil`
6
7			`implicit none`
8
9			`type t1`
10			`integer :: comp = 5`
11			`class(t1),pointer :: cc`
12			`end type`
13
14			`type, extends(t1) :: t2`
15			`integer :: j`
16			`end type`
17
18			`type, extends(t2) :: t3`
19			`integer :: k`
20			`end type`
21
22			`class(t1),pointer :: cp, cp2`
23			`type(t2),pointer :: cp3`
24			`type(t3) :: x`
25			`integer :: i`
26
27
28			`! (1) check that vindex is set correctly (for different cases)`
29
30			`i = 0`
31			`allocate(cp)`
32			`select type (cp)`
33			`type is (t1)`
34			`i = 1`
35			`type is (t2)`
36			`i = 2`
37			`type is (t3)`
38			`i = 3`
39			`end select`
40			`deallocate(cp)`
41			`if (i /= 1) call abort()`
42
43			`i = 0`
44			`allocate(t2 :: cp)`
45			`select type (cp)`
46			`type is (t1)`
47			`i = 1`
48			`type is (t2)`
49			`i = 2`
50			`type is (t3)`
51			`i = 3`
52			`end select`
53			`deallocate(cp)`
54			`if (i /= 2) call abort()`
55
56			`i = 0`
57			`allocate(cp, source = x)`
58			`select type (cp)`
59			`type is (t1)`
60			`i = 1`
61			`type is (t2)`
62			`i = 2`
63			`type is (t3)`
64			`i = 3`
65			`end select`
66			`deallocate(cp)`
67			`if (i /= 3) call abort()`
68
69			`i = 0`
70			`allocate(t2 :: cp2)`
71			`allocate(cp, source = cp2)`
72			`allocate(t2 :: cp3)`
73			`allocate(cp, source=cp3)`
74			`select type (cp)`
75			`type is (t1)`
76			`i = 1`
77			`type is (t2)`
78			`i = 2`
79			`type is (t3)`
80			`i = 3`
81			`end select`
82			`deallocate(cp)`
83			`deallocate(cp2)`
84			`if (i /= 2) call abort()`
85
86
87			`! (2) check initialization (default initialization vs. SOURCE)`
88
89			`allocate(cp)`
90			`if (cp%comp /= 5) call abort()`
91			`deallocate(cp)`
92
93			`x%comp = 4`
94			`allocate(cp, source=x)`
95			`if (cp%comp /= 4) call abort()`
96			`deallocate(cp)`
97
98			`end`

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [class_allocate_1.f03] - Blame information for rev 720