diff options
author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
---|---|---|
committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/gfortran.dg/typebound_proc_20.f90 | |
download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/gfortran.dg/typebound_proc_20.f90')
-rw-r--r-- | gcc/testsuite/gfortran.dg/typebound_proc_20.f90 | 68 |
1 files changed, 68 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 new file mode 100644 index 000000000..4fee2f3ba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! TODO: make runtime testcase once bug is fixed +! +! PR fortran/47455 +! +! Based on an example by Thomas Henlich +! + +module class_t + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type :: t + type(tx), pointer :: x + type(tx) :: y + contains + procedure :: calc + procedure :: find_x + procedure :: find_y + end type t +contains + subroutine calc(this) + class(t), target :: this + type(tx), target :: that + that%i = [1,2] + this%x => this%find_x(that, .true.) + if (associated (this%x)) call abort() + this%x => this%find_x(that, .false.) + if(any (this%x%i /= [5, 7])) call abort() + if (.not.associated (this%x,that)) call abort() + allocate(this%x) + if (associated (this%x,that)) call abort() + if (allocated(this%x%i)) call abort() + this%x = this%find_x(that, .false.) + that%i = [3,4] + if(any (this%x%i /= [5, 7])) call abort() ! FAILS + + if (allocated (this%y%i)) call abort() + this%y = this%find_y() ! FAILS + if (.not.allocated (this%y%i)) call abort() + if(any (this%y%i /= [6, 8])) call abort() + end subroutine calc + function find_x(this, that, l_null) + class(t), intent(in) :: this + type(tx), target :: that + type(tx), pointer :: find_x + logical :: l_null + if (l_null) then + find_x => null() + else + find_x => that + that%i = [5, 7] + end if + end function find_x + function find_y(this) result(res) + class(t), intent(in) :: this + type(tx), allocatable :: res + allocate(res) + res%i = [6, 8] + end function find_y +end module class_t + +use class_t +type(t) :: x +call x%calc() +end + +! { dg-final { cleanup-modules "class_t" } } |