--- Comment #2 from ian at rhymneyconsulting dot co dot uk 2010-06-08
13:21 ---
Subject: RE: [OOP] ICE with polymorphic object oriented example
I should have included them with the bug report!
Things are really progressing with the compiler.
Well done!
Out of the compilers Jane and I have access to
The only one that compiles them is the nag compiler.
Cheers
Ian Chivers
Files are
Shape_p.f90
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
> -Original Message-
> From: burnus at gcc dot gnu dot org [mailto:gcc-bugzi...@gcc.gnu.org]
> Sent: 08 June 2010 14:01
> To: i...@rhymneyconsulting.co.uk
> Subject: [Bug fortran/44465] [OOP] ICE with polymorphic object oriented
> example
>
>
>
> --- Comment #1 from burnus at gcc dot gnu dot org 2010-06-08 13:00
> ---
> (In reply to comment #0)
> > c:\document\fortran\newbook\examples\ch32>gfortran shape_p.f90
> circ
