gcc/testsuite/gfortran.dg/finalize_14.f90

   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 !
   9 module 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
  23 interface assignment(=)
  24   module procedure generic_shape_assign
  25 end interface
  26
  27 contains
  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
  82 end module shape_module
  83
  84 ! Circle_p.f90
  85
  86 module circle_module
  87
  88 use shape_module
  89
  90 type , 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
 100 end 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
 125 end module circle_module
 126
 127
 128 ! Rectangle_p.f90
 129
 130 module rectangle_module
 131
 132 use shape_module
 133
 134 type , 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
 147 end 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
 187 end module rectangle_module
 188
 189
 190
 191 program polymorphic
 192
 193 use shape_module
 194 use circle_module
 195 use rectangle_module
 196
 197 implicit none
 198
 199 type shape_w
 200   class (shape_type) , allocatable :: shape_v
 201 end type shape_w
 202
 203 type (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
 220 end program polymorphic