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) STOP 1 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!") STOP 2 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!") STOP 3 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!") STOP 4 151 if (trim (message2) .ne. "adieu, world!") STOP 5 152 153 call clear_messages 154 call smurf ! Checks host association of 'say_hello' 155 if (trim (message) .ne. "Hello, world!") STOP 6 156 157 call clear_messages 158 bar%greeting = "farewell " 159 call bar%farewell 160 if (trim (message) .ne. "farewell") STOP 7 161 if (trim (message2) .ne. "adieu, world!") STOP 8 162 163 if (realf(2.0) .ne. 4.0) STOP 9! Check module procedure with explicit result 164 if (intf(2) .ne. 10) STOP 10! ditto 165 if (realg(3.0) .ne. 9.0) STOP 11! Check module procedure with function declaration result 166 if (intg(3) .ne. 9) STOP 12! ditto 167 contains 168 subroutine clear_messages 169 message = "" 170 message2 = "" 171 end subroutine 172 end program 173