1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
! { dg-do compile }
!
! PR fortran/37336
!
! Started to fail when finalization was added.
!
! Contributed by Ian Chivers in PR fortran/44465
!
module shape_module
type shape_type
integer :: x_=0
integer :: y_=0
contains
procedure , pass(this) :: getx
procedure , pass(this) :: gety
procedure , pass(this) :: setx
procedure , pass(this) :: sety
procedure , pass(this) :: moveto
procedure , pass(this) :: draw
end type shape_type
interface assignment(=)
module procedure generic_shape_assign
end interface
contains
integer function getx(this)
implicit none
class (shape_type) , intent(in) :: this
getx=this%x_
end function getx
integer function gety(this)
implicit none
class (shape_type) , intent(in) :: this
gety=this%y_
end function gety
subroutine setx(this,x)
implicit none
class (shape_type), intent(inout) :: this
integer , intent(in) :: x
this%x_=x
end subroutine setx
subroutine sety(this,y)
implicit none
class (shape_type), intent(inout) :: this
integer , intent(in) :: y
this%y_=y
end subroutine sety
subroutine moveto(this,newx,newy)
implicit none
class (shape_type), intent(inout) :: this
integer , intent(in) :: newx
integer , intent(in) :: newy
this%x_=newx
this%y_=newy
end subroutine moveto
subroutine draw(this)
implicit none
class (shape_type), intent(in) :: this
print *,' x = ' , this%x_
print *,' y = ' , this%y_
end subroutine draw
subroutine generic_shape_assign(lhs,rhs)
implicit none
class (shape_type) , intent(out) , allocatable :: lhs
class (shape_type) , intent(in) :: rhs
print *,' In generic_shape_assign'
if ( allocated(lhs) ) then
deallocate(lhs)
end if
allocate(lhs,source=rhs)
end subroutine generic_shape_assign
end module shape_module
! Circle_p.f90
module circle_module
use shape_module
type , extends(shape_type) :: circle_type
integer :: radius_
contains
procedure , pass(this) :: getradius
procedure , pass(this) :: setradius
procedure , pass(this) :: draw => draw_circle
end type circle_type
contains
integer function getradius(this)
implicit none
class (circle_type) , intent(in) :: this
getradius=this%radius_
end function getradius
subroutine setradius(this,radius)
implicit none
class (circle_type) , intent(inout) :: this
integer , intent(in) :: radius
this%radius_=radius
end subroutine setradius
subroutine draw_circle(this)
implicit none
class (circle_type), intent(in) :: this
print *,' x = ' , this%x_
print *,' y = ' , this%y_
print *,' radius = ' , this%radius_
end subroutine draw_circle
end module circle_module
! Rectangle_p.f90
module rectangle_module
use shape_module
type , extends(shape_type) :: rectangle_type
integer :: width_
integer :: height_
contains
procedure , pass(this) :: getwidth
procedure , pass(this) :: setwidth
procedure , pass(this) :: getheight
procedure , pass(this) :: setheight
procedure , pass(this) :: draw => draw_rectangle
end type rectangle_type
contains
integer function getwidth(this)
implicit none
class (rectangle_type) , intent(in) :: this
getwidth=this%width_
end function getwidth
subroutine setwidth(this,width)
implicit none
class (rectangle_type) , intent(inout) :: this
integer , intent(in) :: width
this%width_=width
end subroutine setwidth
integer function getheight(this)
implicit none
class (rectangle_type) , intent(in) :: this
getheight=this%height_
end function getheight
subroutine setheight(this,height)
implicit none
class (rectangle_type) , intent(inout) :: this
integer , intent(in) :: height
this%height_=height
end subroutine setheight
subroutine draw_rectangle(this)
implicit none
class (rectangle_type), intent(in) :: this
print *,' x = ' , this%x_
print *,' y = ' , this%y_
print *,' width = ' , this%width_
print *,' height = ' , this%height_
end subroutine draw_rectangle
end module rectangle_module
program polymorphic
use shape_module
use circle_module
use rectangle_module
implicit none
type shape_w
class (shape_type) , allocatable :: shape_v
end type shape_w
type (shape_w) , dimension(3) :: p
print *,' shape '
p(1)%shape_v=shape_type(10,20)
call p(1)%shape_v%draw()
print *,' circle '
p(2)%shape_v=circle_type(100,200,300)
call p(2)%shape_v%draw()
print *,' rectangle '
p(3)%shape_v=rectangle_type(1000,2000,3000,4000)
call p(3)%shape_v%draw()
end program polymorphic
|
