xref: /haiku-buildtools/gcc/gcc/testsuite/gfortran.dg/finalize_14.f90

! { 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