1! Copyright (c) 2010, NVIDIA CORPORATION.  All rights reserved.
2!
3! Licensed under the Apache License, Version 2.0 (the "License");
4! you may not use this file except in compliance with the License.
5! You may obtain a copy of the License at
6!
7!     http://www.apache.org/licenses/LICENSE-2.0
8!
9! Unless required by applicable law or agreed to in writing, software
10! distributed under the License is distributed on an "AS IS" BASIS,
11! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12! See the License for the specific language governing permissions and
13! limitations under the License.
14!
15
16module shape_mod
17
18type shape
19        integer :: color
20        logical :: filled
21        integer :: x
22        integer :: y
23contains
24	procedure :: write => write_shape
25	procedure :: draw => draw_shape
26	procedure :: func => shape_func
27end type shape
28
29type, EXTENDS ( shape ) :: rectangle
30        integer :: the_length
31        integer :: the_width
32contains
33        procedure,pass(this) :: write => write_rec
34	procedure :: draw => draw_rectangle
35	procedure :: func => rec_func
36end type rectangle
37
38type, extends (rectangle) :: square
39contains
40        procedure :: draw => draw_sq
41	procedure :: write => write_sq
42	procedure,pass(this) :: write2 => write_sq2
43	procedure :: write3 => write_sq3
44	procedure :: func => sq_func
45
46end type square
47contains
48
49  subroutine write_shape(this,results,i)
50   class (shape) :: this
51   logical results(:)
52   integer i
53   type(shape) :: sh
54   !results(i) = same_type_as(sh,this)
55   select type(this)
56   type is (shape)
57   results(i) = .true.
58   class default
59   results(i) = .false.
60   end select
61   end subroutine write_shape
62
63   subroutine write_rec(this,results,i)
64   class (rectangle) :: this
65   logical results(:)
66   integer i
67   type(shape) :: sh
68   !results(i) = same_type_as(sh,this)
69   select type(this)
70   type is (rectangle)
71   results(i) = .true.
72   class default
73   results(i) = .false.
74   end select
75   end subroutine write_rec
76
77   subroutine draw_shape(this,results,i)
78   class (shape) :: this
79   logical results(:)
80   integer i
81   print *, 'draw shape!'
82   results(i) = .true.
83   end subroutine draw_shape
84
85   subroutine draw_rectangle(this,results,i)
86   class (rectangle) :: this
87   logical results(:)
88   integer i
89   type(rectangle) :: rec
90   !results(i) = extends_type_of(this,rec)
91   select type(this)
92   class is (rectangle)
93   results(i) = .true.
94   class default
95   results(i) = .false.
96   end select
97   end subroutine draw_rectangle
98
99   subroutine write_sq(this,results,i)
100   class (square) :: this
101   logical results(:)
102   integer i
103   type(rectangle) :: rec
104   !results(i) = extends_type_of(this,rec)
105   select type(this)
106   class is (square)
107   results(i) = .true.
108   class default
109   results(i) = .false.
110   end select
111   end subroutine write_sq
112
113   subroutine draw_sq(this,results,i)
114   class (square) :: this
115   logical results(:)
116   integer i
117   type(rectangle) :: rec
118   !results(i) = extends_type_of(this,rec)
119   select type(this)
120   class is (square)
121   results(i) = .true.
122   class default
123   results(i) = .false.
124   end select
125   end subroutine draw_sq
126
127   subroutine write_sq2(i,this,results)
128   class (square) :: this
129   integer i
130   logical results(:)
131   type(rectangle) :: rec
132   !results(i) = extends_type_of(this,rec)
133   select type(this)
134   class is (square)
135   results(i) = .true.
136   class default
137   results(i) = .false.
138   end select
139   end subroutine write_sq2
140
141   logical function write_sq3(this)
142   class (square) :: this
143   type(rectangle) :: rec
144   !write_sq3 = extends_type_of(this,rec)
145   select type(this)
146   class is (square)
147   write_sq3 = .true.
148   class default
149   write_sq3 = .false.
150   end select
151   end function
152
153   logical function sq_func(this)
154   class (square) :: this
155   sq_func = .false.
156   end function
157
158   logical function rec_func(this)
159   class (rectangle) :: this
160   type(square) :: sq
161   select type(this)
162   type is (rectangle)
163   rec_func = .true.
164   class default
165   rec_func = .false.
166   end select
167
168   end function
169
170   logical function shape_func(this)
171   class (shape) :: this
172   shape_func = .false.
173   end function
174
175end module shape_mod
176
177program p
178USE CHECK_MOD
179use shape_mod
180
181logical l
182logical results(6)
183logical expect(6)
184class(square),allocatable :: s
185class(shape),allocatable :: sh
186type(rectangle) :: r
187type(square),allocatable :: sq
188
189expect = .true.
190results = .false.
191
192allocate(s)
193call s%write2(1,results)
194call s%write(results,2)
195call s%draw(results,3)
196
197allocate(sq)
198results(5) = sq%write3()
199
200allocate(sh)
201call write_shape(sh,results,4)
202
203results(6) = s%rectangle%func()
204
205call check(results,expect,6)
206
207
208end
209
210
211