gcc/testsuite/gfortran.dg/submodule_1.f08

! { dg-do run }
!
! Basic test of submodule functionality.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
 module foo_interface
   implicit none
   character(len = 100) :: message
   character(len = 100) :: message2

   type foo
     character(len=15) :: greeting = "Hello, world!  "
     character(len=15), private :: byebye = "adieu, world!  "
   contains
     procedure :: greet => say_hello
     procedure :: farewell => bye
     procedure, private :: adieu => byebye
   end type foo

   interface
     module subroutine say_hello(this)
       class(foo), intent(in) :: this
     end subroutine

     module subroutine bye(this)
       class(foo), intent(in) :: this
     end subroutine

     module subroutine byebye(this, that)
       class(foo), intent(in) :: this
       class(foo), intent(inOUT), allocatable :: that
     end subroutine

     module function realf (arg) result (res)
       real :: arg, res
     end function

     integer module function intf (arg)
       integer :: arg
     end function

     real module function realg (arg)
       real :: arg
     end function

     integer module function intg (arg)
       integer :: arg
     end function

   end interface

   integer :: factor = 5

 contains

   subroutine smurf
     class(foo), allocatable :: this
     allocate (this)
     message = "say_hello from SMURF --->"
     call say_hello (this)
   end subroutine
 end module

!
  SUBMODULE (foo_interface) foo_interface_son
!
  contains
! Test module procedure with conventional specification part for dummies
     module subroutine say_hello(this)
       class(foo), intent(in) :: this
       class(foo), allocatable :: that
       allocate (that, source = this)
!       call this%farewell         ! NOTE WELL: This compiles and causes a crash in run-time
!                                               due to recursion through the call to this procedure from
!                                               say hello.
       message = that%greeting

! Check that descendant module procedure is correctly processed
       if (intf (77) .ne. factor*77) STOP 1
     end subroutine

     module function realf (arg) result (res)
       real :: arg, res
       res = 2*arg
     end function

  end SUBMODULE foo_interface_son

!
! Check that multiple generations of submodules are OK
  SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson
!
  contains

     module procedure intf
       intf = factor*arg
     end PROCEDURE

  end SUBMODULE foo_interface_grandson

!
  SUBMODULE (foo_interface) foo_interface_daughter
!
  contains
! Test module procedure with abbreviated declaration and no specification of dummies
     module procedure bye
       class(foo), allocatable :: that
       call say_hello (this)
! check access to a PRIVATE procedure pointer that accesses a private component
       call this%adieu (that)
       message2 = that%greeting
     end PROCEDURE

! Test module procedure pointed to by PRIVATE component of foo
     module procedure byebye
       allocate (that, source = this)
! Access a PRIVATE component of foo
       that%greeting = that%byebye
     end PROCEDURE

     module procedure intg
       intg = 3*arg
     end PROCEDURE

     module procedure realg
       realg = 3*arg
     end PROCEDURE

  end SUBMODULE foo_interface_daughter

!
 program try
   use foo_interface
   implicit none
   type(foo) :: bar

   call clear_messages
   call bar%greet ! typebound call
   if (trim (message) .ne. "Hello, world!") STOP 2

   call clear_messages
   bar%greeting = "G'day, world!"
   call say_hello(bar) ! Checks use association of 'say_hello'
   if (trim (message) .ne. "G'day, world!") STOP 3

   call clear_messages
   bar%greeting = "Hi, world!"
   call bye(bar) ! Checks use association in another submodule
   if (trim (message) .ne. "Hi, world!") STOP 4
   if (trim (message2) .ne. "adieu, world!") STOP 5

   call clear_messages
   call smurf ! Checks host association of 'say_hello'
   if (trim (message) .ne. "Hello, world!") STOP 6

   call clear_messages
   bar%greeting = "farewell     "
   call bar%farewell
   if (trim (message) .ne. "farewell") STOP 7
   if (trim (message2) .ne. "adieu, world!") STOP 8

   if (realf(2.0) .ne. 4.0) STOP 9! Check module procedure with explicit result
   if (intf(2) .ne. 10) STOP 10! ditto
   if (realg(3.0) .ne. 9.0) STOP 11! Check module procedure with function declaration result
   if (intg(3) .ne. 9) STOP 12! ditto
 contains
   subroutine clear_messages
     message = ""
     message2 = ""
   end subroutine
 end program