[testsuite/gfortran.dg] PR19561 - derived type pointers and pointerfunctions

[paulthomas2 at wanadoo dot fr]

These testcases exercise the miraculous "virtual fix" for PR19561
This involved bad code being generated for pointers functions and
pointers to derived types.

As might be devined from today's list, with one thing or another,
I am not succeeding in building from cvs on any platform. These
were tested on the snapshot of 20050522. In light of my problems,
would somebody else test on current cvs, please?

I have attached a properly tabbed version of the below.

Paul T


2005-06-17 Paul Thomas 

PR fortran/19561
* gfortran.dg/derived_pointer_1.f90: New.
* gfortran.dg/derived_pointer_2.f90: New.

! { 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
! a simplified example in the PR discussion.
!
! Submitted by Paul Thomas pault@gcc.gnu.org
!
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

end module mpoint

program derived_pointer_1
use mpoint
type (mytype), target :: x
type (mytype), pointer :: y
x = mytype (42)
y => get (x)
if (y%i.ne.42) call abort ()
end program derived_pointer_1


! { 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
!
module simpleObj
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 simpleObj

module derivedObj
use simpleObj
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

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

end module derivedObj

program derived_pointer_2
use simpleObj
use derivedObj
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))

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 ()
close (10)
end program derived_pointer_2

Attachment: derived_pointer.txt
Description: Text document