gcc/testsuite/gfortran.dg/submodule_1.f08

   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