Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/submodule_2.f08 @ 158:494b0b89df80 default tip
...
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Mon, 25 May 2020 18:13:55 +0900 |
parents | 84e7813d76e9 |
children |
line wrap: on
line source
! { 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 if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) STOP 1 deallocate (arg) if (trim (array2 (bar, arg)) .ne. "adieu, people!") STOP 2 deallocate (arg) call array3 (bar, arg) ! typebound call if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) STOP 3 deallocate (arg) call array4 (bar, arg) ! typebound call if (any (arg%greeting .ne. ["adieu, people!", "adieu, people!"])) STOP 4 contains end program