1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
! { 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! "])) call abort
deallocate (arg)
if (trim (array2 (bar, arg)) .ne. "adieu, people!") call abort
deallocate (arg)
call array3 (bar, arg) ! typebound call
if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) call abort
deallocate (arg)
call array4 (bar, arg) ! typebound call
if (any (arg%greeting .ne. ["adieu, people!", "adieu, people!"])) call abort
contains
end program
|
