func_derived_2.f90, [...]: New tests.

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.

From-SVN: r101230

gcc/testsuite/ChangeLog

-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.

gcc/testsuite/gfortran.dg/func_derived_2.f90

+! { 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
+
+

gcc/testsuite/gfortran.dg/func_derived_3.f90

+! { 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