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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101230 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 088e10a..e452f4c 100644 (file)
--- 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 (file)
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 (file)
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