1! { dg-do run } 2! 3! Basic test of submodule functionality. 4! 5! Contributed by Paul Thomas <pault@gcc.gnu.org> 6! 7 module foo_interface 8 implicit none 9 character(len = 100) :: message 10 character(len = 100) :: message2 11 12 type foo 13 character(len=15) :: greeting = "Hello, world! " 14 character(len=15), private :: byebye = "adieu, world! " 15 contains 16 procedure :: greet => say_hello 17 procedure :: farewell => bye 18 procedure, private :: adieu => byebye 19 end type foo 20 21 interface 22 module subroutine say_hello(this) 23 class(foo), intent(in) :: this 24 end subroutine 25 26 module subroutine bye(this) 27 class(foo), intent(in) :: this 28 end subroutine 29 30 module subroutine byebye(this, that) 31 class(foo), intent(in) :: this 32 class(foo), intent(inOUT), allocatable :: that 33 end subroutine 34 35 module function realf (arg) result (res) 36 real :: arg, res 37 end function 38 39 integer module function intf (arg) 40 integer :: arg 41 end function 42 43 real module function realg (arg) 44 real :: arg 45 end function 46 47 integer module function intg (arg) 48 integer :: arg 49 end function 50 51 end interface 52 53 integer :: factor = 5 54 55 contains 56 57 subroutine smurf 58 class(foo), allocatable :: this 59 allocate (this) 60 message = "say_hello from SMURF --->" 61 call say_hello (this) 62 end subroutine 63 end module 64 65! 66 SUBMODULE (foo_interface) foo_interface_son 67! 68 contains 69! Test module procedure with conventional specification part for dummies 70 module subroutine say_hello(this) 71 class(foo), intent(in) :: this 72 class(foo), allocatable :: that 73 allocate (that, source = this) 74! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time 75! due to recursion through the call to this procedure from 76! say hello. 77 message = that%greeting 78 79! Check that descendant module procedure is correctly processed 80 if (intf (77) .ne. factor*77) call abort 81 end subroutine 82 83 module function realf (arg) result (res) 84 real :: arg, res 85 res = 2*arg 86 end function 87 88 end SUBMODULE foo_interface_son 89 90! 91! Check that multiple generations of submodules are OK 92 SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson 93! 94 contains 95 96 module procedure intf 97 intf = factor*arg 98 end PROCEDURE 99 100 end SUBMODULE foo_interface_grandson 101 102! 103 SUBMODULE (foo_interface) foo_interface_daughter 104! 105 contains 106! Test module procedure with abbreviated declaration and no specification of dummies 107 module procedure bye 108 class(foo), allocatable :: that 109 call say_hello (this) 110! check access to a PRIVATE procedure pointer that accesses a private component 111 call this%adieu (that) 112 message2 = that%greeting 113 end PROCEDURE 114 115! Test module procedure pointed to by PRIVATE component of foo 116 module procedure byebye 117 allocate (that, source = this) 118! Access a PRIVATE component of foo 119 that%greeting = that%byebye 120 end PROCEDURE 121 122 module procedure intg 123 intg = 3*arg 124 end PROCEDURE 125 126 module procedure realg 127 realg = 3*arg 128 end PROCEDURE 129 130 end SUBMODULE foo_interface_daughter 131 132! 133 program try 134 use foo_interface 135 implicit none 136 type(foo) :: bar 137 138 call clear_messages 139 call bar%greet ! typebound call 140 if (trim (message) .ne. "Hello, world!") call abort 141 142 call clear_messages 143 bar%greeting = "G'day, world!" 144 call say_hello(bar) ! Checks use association of 'say_hello' 145 if (trim (message) .ne. "G'day, world!") call abort 146 147 call clear_messages 148 bar%greeting = "Hi, world!" 149 call bye(bar) ! Checks use association in another submodule 150 if (trim (message) .ne. "Hi, world!") call abort 151 if (trim (message2) .ne. "adieu, world!") call abort 152 153 call clear_messages 154 call smurf ! Checks host association of 'say_hello' 155 if (trim (message) .ne. "Hello, world!") call abort 156 157 call clear_messages 158 bar%greeting = "farewell " 159 call bar%farewell 160 if (trim (message) .ne. "farewell") call abort 161 if (trim (message2) .ne. "adieu, world!") call abort 162 163 if (realf(2.0) .ne. 4.0) call abort ! Check module procedure with explicit result 164 if (intf(2) .ne. 10) call abort ! ditto 165 if (realg(3.0) .ne. 9.0) call abort ! Check module procedure with function declaration result 166 if (intg(3) .ne. 9) call abort ! ditto 167 contains 168 subroutine clear_messages 169 message = "" 170 message2 = "" 171 end subroutine 172 end program 173! { dg-final { cleanup-submodules "foo_interface@foo_interface_son" } } 174! { dg-final { cleanup-submodules "foo_interface@foo_interface_grandson" } } 175! { dg-final { cleanup-submodules "foo_interface@foo_interface_daughter" } } 176