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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [class_48.f90] - Blame information for rev 801

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


! { dg-do run }
!
! PR fortran/51972
! Also tests fixes for PR52102
!
! Check whether DT assignment with polymorphic components works.
!
 
subroutine test1 ()
  type t
    integer :: x
  end type t
 
  type t2
    class(t), allocatable :: a
  end type t2
 
  type(t2) :: one, two
 
  one = two
  if (allocated (one%a)) call abort ()
 
  allocate (two%a)
  two%a%x = 7890
  one = two
  if (one%a%x /= 7890) call abort ()
 
  deallocate (two%a)
  one = two
  if (allocated (one%a)) call abort ()
end subroutine test1
 
subroutine test2 ()
  type t
    integer, allocatable :: x(:)
  end type t
 
  type t2
    class(t), allocatable :: a
  end type t2
 
  type(t2) :: one, two
 
  one = two
  if (allocated (one%a)) call abort ()
 
  allocate (two%a)
  one = two
  if (.not.allocated (one%a)) call abort ()
  if (allocated (one%a%x)) call abort ()
 
  allocate (two%a%x(2))
  two%a%x(:) = 7890
  one = two
  if (any (one%a%x /= 7890)) call abort ()
 
  deallocate (two%a)
  one = two
  if (allocated (one%a)) call abort ()
end subroutine test2
 
 
subroutine test3 ()
  type t
    integer :: x
  end type t
 
  type t2
    class(t), allocatable :: a(:)
  end type t2
 
  type(t2) :: one, two
 
! Test allocate with array source - PR52102
  allocate (two%a(2), source = [t(4), t(6)])
 
  if (allocated (one%a)) call abort ()
 
  one = two
  if (.not.allocated (one%a)) call abort ()
 
  if ((one%a(1)%x /= 4)) call abort ()
  if ((one%a(2)%x /= 6)) call abort ()
 
  deallocate (two%a)
  one = two
 
  if (allocated (one%a)) call abort ()
 
! Test allocate with no source followed by assignments.
  allocate (two%a(2))
  two%a(1)%x = 5
  two%a(2)%x = 7
 
  if (allocated (one%a)) call abort ()
 
  one = two
  if (.not.allocated (one%a)) call abort ()
 
  if ((one%a(1)%x /= 5)) call abort ()
  if ((one%a(2)%x /= 7)) call abort ()
 
  deallocate (two%a)
  one = two
  if (allocated (one%a)) call abort ()
end subroutine test3
 
subroutine test4 ()
  type t
    integer, allocatable :: x(:)
  end type t
 
  type t2
    class(t), allocatable :: a(:)
  end type t2
 
  type(t2) :: one, two
 
  if (allocated (one%a)) call abort ()
  if (allocated (two%a)) call abort ()
 
  allocate (two%a(2))
 
  if (allocated (two%a(1)%x)) call abort ()
  if (allocated (two%a(2)%x)) call abort ()
  allocate (two%a(1)%x(3), source=[1,2,3])
  allocate (two%a(2)%x(5), source=[5,6,7,8,9])
  one = two
  if (.not. allocated (one%a)) call abort ()
  if (.not. allocated (one%a(1)%x)) call abort ()
  if (.not. allocated (one%a(2)%x)) call abort ()
 
  if (size(one%a) /= 2) call abort()
  if (size(one%a(1)%x) /= 3) call abort()
  if (size(one%a(2)%x) /= 5) call abort()
  if (any (one%a(1)%x /= [1,2,3])) call abort ()
  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
 
  deallocate (two%a(1)%x)
  one = two
  if (.not. allocated (one%a)) call abort ()
  if (allocated (one%a(1)%x)) call abort ()
  if (.not. allocated (one%a(2)%x)) call abort ()
 
  if (size(one%a) /= 2) call abort()
  if (size(one%a(2)%x) /= 5) call abort()
  if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
 
  deallocate (two%a)
  one = two
  if (allocated (one%a)) call abort ()
  if (allocated (two%a)) call abort ()
end subroutine test4
 
 
call test1 ()
call test2 ()
call test3 ()
call test4 ()
end
 

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`!`
3			`! PR fortran/51972`
4			`! Also tests fixes for PR52102`
5			`!`
6			`! Check whether DT assignment with polymorphic components works.`
7			`!`
8
9			`subroutine test1 ()`
10			`type t`
11			`integer :: x`
12			`end type t`
13
14			`type t2`
15			`class(t), allocatable :: a`
16			`end type t2`
17
18			`type(t2) :: one, two`
19
20			`one = two`
21			`if (allocated (one%a)) call abort ()`
22
23			`allocate (two%a)`
24			`two%a%x = 7890`
25			`one = two`
26			`if (one%a%x /= 7890) call abort ()`
27
28			`deallocate (two%a)`
29			`one = two`
30			`if (allocated (one%a)) call abort ()`
31			`end subroutine test1`
32
33			`subroutine test2 ()`
34			`type t`
35			`integer, allocatable :: x(:)`
36			`end type t`
37
38			`type t2`
39			`class(t), allocatable :: a`
40			`end type t2`
41
42			`type(t2) :: one, two`
43
44			`one = two`
45			`if (allocated (one%a)) call abort ()`
46
47			`allocate (two%a)`
48			`one = two`
49			`if (.not.allocated (one%a)) call abort ()`
50			`if (allocated (one%a%x)) call abort ()`
51
52			`allocate (two%a%x(2))`
53			`two%a%x(:) = 7890`
54			`one = two`
55			`if (any (one%a%x /= 7890)) call abort ()`
56
57			`deallocate (two%a)`
58			`one = two`
59			`if (allocated (one%a)) call abort ()`
60			`end subroutine test2`
61
62
63			`subroutine test3 ()`
64			`type t`
65			`integer :: x`
66			`end type t`
67
68			`type t2`
69			`class(t), allocatable :: a(:)`
70			`end type t2`
71
72			`type(t2) :: one, two`
73
74			`! Test allocate with array source - PR52102`
75			`allocate (two%a(2), source = [t(4), t(6)])`
76
77			`if (allocated (one%a)) call abort ()`
78
79			`one = two`
80			`if (.not.allocated (one%a)) call abort ()`
81
82			`if ((one%a(1)%x /= 4)) call abort ()`
83			`if ((one%a(2)%x /= 6)) call abort ()`
84
85			`deallocate (two%a)`
86			`one = two`
87
88			`if (allocated (one%a)) call abort ()`
89
90			`! Test allocate with no source followed by assignments.`
91			`allocate (two%a(2))`
92			`two%a(1)%x = 5`
93			`two%a(2)%x = 7`
94
95			`if (allocated (one%a)) call abort ()`
96
97			`one = two`
98			`if (.not.allocated (one%a)) call abort ()`
99
100			`if ((one%a(1)%x /= 5)) call abort ()`
101			`if ((one%a(2)%x /= 7)) call abort ()`
102
103			`deallocate (two%a)`
104			`one = two`
105			`if (allocated (one%a)) call abort ()`
106			`end subroutine test3`
107
108			`subroutine test4 ()`
109			`type t`
110			`integer, allocatable :: x(:)`
111			`end type t`
112
113			`type t2`
114			`class(t), allocatable :: a(:)`
115			`end type t2`
116
117			`type(t2) :: one, two`
118
119			`if (allocated (one%a)) call abort ()`
120			`if (allocated (two%a)) call abort ()`
121
122			`allocate (two%a(2))`
123
124			`if (allocated (two%a(1)%x)) call abort ()`
125			`if (allocated (two%a(2)%x)) call abort ()`
126			`allocate (two%a(1)%x(3), source=[1,2,3])`
127			`allocate (two%a(2)%x(5), source=[5,6,7,8,9])`
128			`one = two`
129			`if (.not. allocated (one%a)) call abort ()`
130			`if (.not. allocated (one%a(1)%x)) call abort ()`
131			`if (.not. allocated (one%a(2)%x)) call abort ()`
132
133			`if (size(one%a) /= 2) call abort()`
134			`if (size(one%a(1)%x) /= 3) call abort()`
135			`if (size(one%a(2)%x) /= 5) call abort()`
136			`if (any (one%a(1)%x /= [1,2,3])) call abort ()`
137			`if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()`
138
139			`deallocate (two%a(1)%x)`
140			`one = two`
141			`if (.not. allocated (one%a)) call abort ()`
142			`if (allocated (one%a(1)%x)) call abort ()`
143			`if (.not. allocated (one%a(2)%x)) call abort ()`
144
145			`if (size(one%a) /= 2) call abort()`
146			`if (size(one%a(2)%x) /= 5) call abort()`
147			`if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()`
148
149			`deallocate (two%a)`
150			`one = two`
151			`if (allocated (one%a)) call abort ()`
152			`if (allocated (two%a)) call abort ()`
153			`end subroutine test4`
154
155
156			`call test1 ()`
157			`call test2 ()`
158			`call test3 ()`
159			`call test4 ()`
160			`end`
161

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [class_48.f90] - Blame information for rev 801