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