------- 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
> circle_p.f90
> > rectangle_p.f90 polymorph_array.f90
> > polymorph_array.f90: In function 'polymorphic':
> > polymorph_array.f90:18:0: internal compiler error: Segmentation fault
>
>
> > Do you want the shape_p.f90, circle_p.f90 and rectangle_p.f90
> > source files?
>
> Yes, please. Without it is difficult to reproduce the segfault. Please
> attach
> the modules (unless they are short, then you can also paste them) -
> probably
> best by putting all modules into a single file (rather than attaching
> them one
> by one, which is also fine).
>
> Thanks for the bug report!
>
>
> --
>
> burnus at gcc dot gnu dot org changed:
>
> What |Removed |Added
> -----------------------------------------------------------------------
> -----
> CC| |janus at gcc dot gnu
> dot org
> Summary|polymorphic object oriented |[OOP] ICE with
> polymorphic
> |example |object oriented
> example
>
>
> http://gcc.gnu.org/bugzilla/show_bug.cgi?id=44465
>
> ------- You are receiving this mail because: -------
> You reported the bug, or are watching the reporter.
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=44465
