2017-04-10 11:32:00 +00:00
|
|
|
! { dg-do run }
|
|
|
|
!
|
|
|
|
! Test dummy and result arrays in module procedures
|
|
|
|
!
|
|
|
|
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
|
|
|
!
|
|
|
|
module foo_interface
|
|
|
|
implicit none
|
|
|
|
type foo
|
|
|
|
character(len=16) :: greeting = "Hello, world! "
|
|
|
|
character(len=16), private :: byebye = "adieu, world! "
|
|
|
|
end type foo
|
|
|
|
|
|
|
|
interface
|
|
|
|
module function array1(this) result (that)
|
|
|
|
type(foo), intent(in), dimension(:) :: this
|
|
|
|
type(foo), allocatable, dimension(:) :: that
|
|
|
|
end function
|
|
|
|
character(16) module function array2(this, that)
|
|
|
|
type(foo), intent(in), dimension(:) :: this
|
|
|
|
type(foo), allocatable, dimension(:) :: that
|
|
|
|
end function
|
|
|
|
module subroutine array3(this, that)
|
|
|
|
type(foo), intent(in), dimension(:) :: this
|
|
|
|
type(foo), intent(inOUT), allocatable, dimension(:) :: that
|
|
|
|
end subroutine
|
|
|
|
module subroutine array4(this, that)
|
|
|
|
type(foo), intent(in), dimension(:) :: this
|
|
|
|
type(foo), intent(inOUT), allocatable, dimension(:) :: that
|
|
|
|
end subroutine
|
|
|
|
end interface
|
|
|
|
end module
|
|
|
|
|
|
|
|
!
|
|
|
|
SUBMODULE (foo_interface) foo_interface_son
|
|
|
|
!
|
|
|
|
contains
|
|
|
|
|
|
|
|
! Test array characteristics for dummy and result are OK
|
|
|
|
module function array1 (this) result(that)
|
|
|
|
type(foo), intent(in), dimension(:) :: this
|
|
|
|
type(foo), allocatable, dimension(:) :: that
|
|
|
|
allocate (that(size(this)), source = this)
|
|
|
|
that%greeting = that%byebye
|
|
|
|
end function
|
|
|
|
|
|
|
|
! Test array characteristics for dummy and result are OK for
|
|
|
|
! abbreviated module procedure declaration.
|
|
|
|
module procedure array2
|
|
|
|
allocate (that(size(this)), source = this)
|
|
|
|
that%greeting = that%byebye
|
|
|
|
array2 = trim (that(size (that))%greeting(1:5))//", people!"
|
|
|
|
end PROCEDURE
|
|
|
|
|
|
|
|
end SUBMODULE foo_interface_son
|
|
|
|
|
|
|
|
!
|
|
|
|
SUBMODULE (foo_interface) foo_interface_daughter
|
|
|
|
!
|
|
|
|
contains
|
|
|
|
|
|
|
|
! Test array characteristics for dummies are OK
|
|
|
|
module subroutine array3(this, that)
|
|
|
|
type(foo), intent(in), dimension(:) :: this
|
|
|
|
type(foo), intent(inOUT), allocatable, dimension(:) :: that
|
|
|
|
allocate (that(size(this)), source = this)
|
|
|
|
that%greeting = that%byebye
|
|
|
|
end subroutine
|
|
|
|
|
|
|
|
! Test array characteristics for dummies are OK for
|
|
|
|
! abbreviated module procedure declaration.
|
|
|
|
module procedure array4
|
|
|
|
integer :: i
|
|
|
|
allocate (that(size(this)), source = this)
|
|
|
|
that%greeting = that%byebye
|
|
|
|
do i = 1, size (that)
|
|
|
|
that(i)%greeting = trim (that(i)%greeting(1:5))//", people!"
|
|
|
|
end do
|
|
|
|
end PROCEDURE
|
|
|
|
end SUBMODULE foo_interface_daughter
|
|
|
|
|
|
|
|
!
|
|
|
|
program try
|
|
|
|
use foo_interface
|
|
|
|
implicit none
|
|
|
|
type(foo), dimension(2) :: bar
|
|
|
|
type (foo), dimension(:), allocatable :: arg
|
|
|
|
|
|
|
|
arg = array1(bar) ! typebound call
|
2018-12-28 15:30:48 +00:00
|
|
|
if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) STOP 1
|
2017-04-10 11:32:00 +00:00
|
|
|
deallocate (arg)
|
2018-12-28 15:30:48 +00:00
|
|
|
if (trim (array2 (bar, arg)) .ne. "adieu, people!") STOP 2
|
2017-04-10 11:32:00 +00:00
|
|
|
deallocate (arg)
|
|
|
|
call array3 (bar, arg) ! typebound call
|
2018-12-28 15:30:48 +00:00
|
|
|
if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) STOP 3
|
2017-04-10 11:32:00 +00:00
|
|
|
deallocate (arg)
|
|
|
|
call array4 (bar, arg) ! typebound call
|
2018-12-28 15:30:48 +00:00
|
|
|
if (any (arg%greeting .ne. ["adieu, people!", "adieu, people!"])) STOP 4
|
2017-04-10 11:32:00 +00:00
|
|
|
contains
|
|
|
|
end program
|