diff options
author | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
---|---|---|
committer | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
commit | 1bc5aee63eb72b341f506ad058502cd0361f0d10 (patch) | |
tree | c607e8252f3405424ff15bc2d00aa38dadbb2518 /gcc-4.9/gcc/testsuite/gfortran.dg/finalize_14.f90 | |
parent | 283a0bf58fcf333c58a2a92c3ebbc41fb9eb1fdb (diff) | |
download | toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.gz toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.bz2 toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.zip |
Initial checkin of GCC 4.9.0 from trunk (r208799).
Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba
Diffstat (limited to 'gcc-4.9/gcc/testsuite/gfortran.dg/finalize_14.f90')
-rw-r--r-- | gcc-4.9/gcc/testsuite/gfortran.dg/finalize_14.f90 | 220 |
1 files changed, 220 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/gfortran.dg/finalize_14.f90 b/gcc-4.9/gcc/testsuite/gfortran.dg/finalize_14.f90 new file mode 100644 index 000000000..edec8841e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.dg/finalize_14.f90 @@ -0,0 +1,220 @@ +! { 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 |