diff options
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/func_derived_2.f90 | 42 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/func_derived_3.f90 | 125 |
3 files changed, 174 insertions, 1 deletions
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 088e10a..e452f4cd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,4 +1,10 @@ -2005-06-19 Francois-Xavier Coudert <coudert@clipper.ens.fr> +2005-06-21 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/func_derived_2.f90, gfortran.dg/func_derived_3.f90: + New tests. + +2005-06-20 Francois-Xavier Coudert <coudert@clipper.ens.fr> * gfortran.dg/backslash_1.f90: New test. * gfortran.dg/backslash_2.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/func_derived_2.f90 b/gcc/testsuite/gfortran.dg/func_derived_2.f90 new file mode 100644 index 0000000..2f3aefa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/func_derived_2.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! This tests the "virtual fix" for PR19561, where functions returning +! pointers to derived types were not generating correct code. This +! testcase is based on a simplified example in the PR discussion. +! +! Submitted by Paul Thomas pault@gcc.gnu.org +! Slightly extended by Tobias Schlüter +module mpoint + type :: mytype + integer :: i + end type mytype + +contains + + function get (a) result (b) + type (mytype), target :: a + type (mytype), pointer :: b + b => a + end function get + + function get2 (a) + type (mytype), target :: a + type (mytype), pointer :: get2 + get2 => a + end function get2 + +end module mpoint + +program func_derived_2 + use mpoint + type (mytype), target :: x + type (mytype), pointer :: y + x = mytype (42) + y => get (x) + if (y%i.ne.42) call abort () + + x = mytype (112) + y => get2 (x) + if (y%i.ne.112) call abort () +end program func_derived_2 + + diff --git a/gcc/testsuite/gfortran.dg/func_derived_3.f90 b/gcc/testsuite/gfortran.dg/func_derived_3.f90 new file mode 100644 index 0000000..a271fe9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/func_derived_3.f90 @@ -0,0 +1,125 @@ +! { dg-do run } +! This tests the "virtual fix" for PR19561, where pointers to derived +! types were not generating correct code. This testcase is based on +! the original PR example. This example not only tests the +! original problem but throughly tests derived types in modules, +! module interfaces and compound derived types. +! +! Original by Martin Reinecke martin@mpa-garching.mpg.de +! Submitted by Paul Thomas pault@gcc.gnu.org +! Slightly modified by Tobias Schlüter +module func_derived_3 + implicit none + type objA + private + integer :: i + end type objA + + interface new + module procedure oaInit + end interface + + interface print + module procedure oaPrint + end interface + + private + public objA,new,print + +contains + + subroutine oaInit(oa,i) + integer :: i + type(objA) :: oa + oa%i=i + end subroutine oaInit + + subroutine oaPrint (oa) + type (objA) :: oa + write (10, '("simple = ",i5)') oa%i + end subroutine oaPrint + +end module func_derived_3 + +module func_derived_3a + use func_derived_3 + implicit none + + type objB + private + integer :: i + type(objA), pointer :: oa + end type objB + + interface new + module procedure obInit + end interface + + interface print + module procedure obPrint + end interface + + private + public objB, new, print, getOa, getOa2 + +contains + + subroutine obInit (ob,oa,i) + integer :: i + type(objA), target :: oa + type(objB) :: ob + + ob%i=i + ob%oa=>oa + end subroutine obInit + + subroutine obPrint (ob) + type (objB) :: ob + write (10, '("derived = ",i5)') ob%i + call print (ob%oa) + end subroutine obPrint + + function getOa (ob) result (oa) + type (objB),target :: ob + type (objA), pointer :: oa + + oa=>ob%oa + end function getOa + +! without a result clause + function getOa2 (ob) + type (objB),target :: ob + type (objA), pointer :: getOa2 + + getOa2=>ob%oa + end function getOa2 + +end module func_derived_3a + + use func_derived_3 + use func_derived_3a + implicit none + type (objA),target :: oa + type (objB),target :: ob + character (len=80) :: line + + open (10, status='scratch') + + call new (oa,1) + call new (ob, oa, 2) + + call print (ob) + call print (getOa (ob)) + call print (getOa2 (ob)) + + rewind (10) + read (10, '(80a)') line + if (trim (line).ne."derived = 2") call abort () + read (10, '(80a)') line + if (trim (line).ne."simple = 1") call abort () + read (10, '(80a)') line + if (trim (line).ne."simple = 1") call abort () + read (10, '(80a)') line + if (trim (line).ne."simple = 1") call abort () + close (10) +end program |