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