gcc/testsuite/gfortran.dg/submodule_2.f08

   1 ! { dg-do run }
   2 !
   3 ! Test dummy and result arrays in module procedures
   4 !
   5 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   6 !
   7  module foo_interface
   8    implicit none
   9    type foo
  10      character(len=16) :: greeting = "Hello, world!   "
  11      character(len=16), private :: byebye = "adieu, world!   "
  12    end type foo
  13
  14    interface
  15      module function array1(this) result (that)
  16        type(foo), intent(in), dimension(:) :: this
  17        type(foo), allocatable, dimension(:) :: that
  18      end function
  19      character(16) module function array2(this, that)
  20        type(foo), intent(in), dimension(:) :: this
  21        type(foo), allocatable, dimension(:) :: that
  22      end function
  23      module subroutine array3(this, that)
  24        type(foo), intent(in), dimension(:) :: this
  25        type(foo), intent(inOUT), allocatable, dimension(:) :: that
  26      end subroutine
  27      module subroutine array4(this, that)
  28        type(foo), intent(in), dimension(:) :: this
  29        type(foo), intent(inOUT), allocatable, dimension(:) :: that
  30      end subroutine
  31    end interface
  32  end module
  33
  34 !
  35   SUBMODULE (foo_interface) foo_interface_son
  36 !
  37   contains
  38
  39 ! Test array characteristics for dummy and result are OK
  40      module function array1 (this) result(that)
  41        type(foo), intent(in), dimension(:) :: this
  42        type(foo), allocatable, dimension(:) :: that
  43        allocate (that(size(this)), source = this)
  44        that%greeting = that%byebye
  45      end function
  46
  47 ! Test array characteristics for dummy and result are OK for
  48 ! abbreviated module procedure declaration.
  49      module procedure array2
  50        allocate (that(size(this)), source = this)
  51        that%greeting = that%byebye
  52        array2 = trim (that(size (that))%greeting(1:5))//", people!"
  53      end PROCEDURE
  54
  55   end SUBMODULE foo_interface_son
  56
  57 !
  58   SUBMODULE (foo_interface) foo_interface_daughter
  59 !
  60   contains
  61
  62 ! Test array characteristics for dummies are OK
  63      module subroutine array3(this, that)
  64        type(foo), intent(in), dimension(:) :: this
  65        type(foo), intent(inOUT), allocatable, dimension(:) :: that
  66        allocate (that(size(this)), source = this)
  67        that%greeting = that%byebye
  68      end subroutine
  69
  70 ! Test array characteristics for dummies are OK for
  71 ! abbreviated module procedure declaration.
  72      module procedure array4
  73        integer :: i
  74        allocate (that(size(this)), source = this)
  75        that%greeting = that%byebye
  76        do i = 1, size (that)
  77          that(i)%greeting = trim (that(i)%greeting(1:5))//", people!"
  78        end do
  79      end PROCEDURE
  80   end SUBMODULE foo_interface_daughter
  81
  82 !
  83  program try
  84    use foo_interface
  85    implicit none
  86    type(foo), dimension(2) :: bar
  87    type (foo), dimension(:), allocatable :: arg
  88
  89    arg = array1(bar) ! typebound call
  90    if (any (arg%greeting .ne. ["adieu, world!   ", "adieu, world!   "])) STOP 1
  91    deallocate (arg)
  92    if (trim (array2 (bar, arg)) .ne. "adieu, people!") STOP 2
  93    deallocate (arg)
  94    call array3 (bar, arg) ! typebound call
  95    if (any (arg%greeting .ne. ["adieu, world!   ", "adieu, world!   "])) STOP 3
  96    deallocate (arg)
  97    call array4 (bar, arg) ! typebound call
  98    if (any (arg%greeting .ne. ["adieu, people!", "adieu, people!"])) STOP 4
  99  contains
 100  end program