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
23	!integer,pointer :: p=>null()
24contains
25	procedure :: write => write_shape
26	procedure :: draw => draw_shape
27	procedure :: func => shape_func
28end type shape
29
30type, EXTENDS ( shape ) :: rectangle
31        integer :: the_length
32        integer :: the_width
33contains
34        procedure,pass(this) :: write => write_rec
35	procedure :: draw => draw_rectangle
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
45end type square
46
47type poly_data
48      class(shape),allocatable :: data
49end type poly_data
50
51contains
52
53  subroutine write_shape(this,results,i)
54   class (shape) :: this
55   logical results(:)
56   integer i
57   type(shape) :: sh
58   !results(i) = same_type_as(sh,this)
59   select type(this)
60   type is(shape)
61   results(i) = .true.
62   class default
63   results(i) = .false.
64   end select
65   end subroutine write_shape
66
67   subroutine write_rec(this,results,i)
68   class (rectangle) :: this
69   logical results(:)
70   integer i
71   type(shape) :: sh
72   !results(i) = same_type_as(sh,this)
73   select type(this)
74   type is(rectangle)
75   results(i) = .false.
76   class default
77   results(i) = .true.
78   end select
79   end subroutine write_rec
80
81   subroutine draw_shape(this,results,i)
82   class (shape) :: this
83   logical results(:)
84   integer i
85   print *, 'draw shape!'
86   end subroutine draw_shape
87
88   subroutine draw_rectangle(this,results,i)
89   class (rectangle) :: this
90   logical results(:)
91   integer i
92   type(rectangle) :: rec
93   !results(i) = extends_type_of(this,rec)
94   select type (this)
95   class is (rectangle)
96   results(i) = .true.
97   class default
98   results(i) = .false.
99   end select
100   end subroutine draw_rectangle
101
102   subroutine write_sq(this,results,i)
103   class (square) :: this
104   logical results(:)
105   integer i
106   type(rectangle) :: rec
107   !results(i) = extends_type_of(this,rec)
108   select type (this)
109   type is (square)
110   results(i) = .true.
111   class default
112   results(i) = .false.
113   end select
114   end subroutine write_sq
115
116   subroutine draw_sq(this,results,i)
117   class (square) :: this
118   logical results(:)
119   integer i
120   type(rectangle) :: rec
121	print *, 'draw sq'
122   !results(i) = extends_type_of(this,rec)
123   select type (this)
124   class is (square)
125   results(i) = .true.
126   class default
127   results(i) = .false.
128   end select
129   end subroutine draw_sq
130
131   subroutine write_sq2(i,this,results)
132   class (square) :: this
133   integer i
134   logical results(:)
135   type(rectangle) :: rec
136   !results(i) = extends_type_of(this,rec)
137   select type (this)
138   class is (square)
139   results(i) = .true.
140   class default
141   results(i) = .false.
142   end select
143   end subroutine write_sq2
144
145   logical function write_sq3(this)
146   class (square) :: this
147   type(rectangle) :: rec
148   !write_sq3 = extends_type_of(this,rec)
149	print *, 'write_sq3'
150   select type (this)
151   class is (square)
152   write_sq3 = .true.
153   class default
154   write_sq3 = .false.
155   end select
156   end function
157
158   logical function shape_func(this) result(RSLT)
159    class(shape) :: this
160   print *, 'shape func',this%color
161
162   select type (z=>this)
163   class is (rectangle)
164   z%color = -1
165   z%the_width = 66
166   rslt = .true.
167   class default
168   rslt = .false.
169   end select
170
171   print *, 'shape func',this%color
172   end function
173
174
175end module shape_mod
176
177program p
178USE CHECK_MOD
179use shape_mod
180
181logical l
182logical results(8)
183logical expect(8)
184class(square),allocatable :: s
185class(shape),allocatable :: sh
186type(rectangle) :: r
187type(square),allocatable :: sq
188type(poly_data) :: pd
189
190results = .false.
191expect = .true.
192
193allocate(s)
194call s%write2(1,results)
195call s%write(results,2)
196call s%draw(results,3)
197
198allocate(sq)
199results(5) = sq%write3()
200
201allocate(sh)
202call write_shape(sh,results,4)
203
204
205allocate(square::pd%data)
206
207pd%data%y = 99
208select type(pds => pd%data)
209class is (rectangle)
210pds%y = 101
211results(6) = .true.
212class default
213results(6) = .false.
214end select
215
216pd%data%color = 77
217results(8) = pd%data%func()
218
219select type(pds => pd%data)
220type is (square)
221results(7) = pds%write3()
222end select
223
224call check(results,expect,8)
225
226end
227
228
229