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) 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