gcc/testsuite/gfortran.dg/submodule_6.f08

   1 ! { dg-do run }
   2 ! { dg-require-effective-target lto }
   3 ! { dg-options "-flto" }
   4 !
   5 ! Checks that the results of module procedures have the correct characteristics
   6 ! and that submodules use the module version of vtables (PR66762). This latter
   7 ! requires the -flto compile option.
   8 !
   9 ! Contributed by Reinhold Bader  <reinhold.bader@lrz.de>
  10 !
  11 module mod_a
  12   implicit none
  13   type, abstract :: t_a
  14   end type t_a
  15   interface
  16     module subroutine p_a(this, q)
  17       class(t_a), intent(inout) :: this
  18       class(*), intent(in) :: q
  19     end subroutine
  20     module function create_a() result(r)
  21       class(t_a), allocatable :: r
  22     end function
  23     module subroutine print(this)
  24       class(t_a), intent(in) :: this
  25     end subroutine
  26   end interface
  27 end module mod_a
  28
  29 module mod_b
  30   implicit none
  31   type t_b
  32     integer, allocatable :: I(:)
  33   end type t_b
  34   interface
  35     module function create_b(i) result(r)
  36       type(t_b) :: r
  37       integer :: i(:)
  38     end function
  39   end interface
  40 end module mod_b
  41
  42 submodule(mod_b) imp_create
  43 contains
  44   module procedure create_b
  45     if (allocated(r%i)) deallocate(r%i)
  46     allocate(r%i, source=i)
  47   end procedure
  48 end submodule imp_create
  49
  50 submodule(mod_a) imp_p_a
  51   use mod_b
  52   type, extends(t_a) :: t_imp
  53     type(t_b) :: b
  54   end type t_imp
  55   integer, parameter :: ii(2) = [1,2]
  56 contains
  57   module procedure create_a
  58     type(t_b) :: b
  59     b = create_b(ii)
  60     allocate(r, source=t_imp(b))
  61   end procedure
  62
  63   module procedure  p_a
  64     select type (this)
  65       type is (t_imp)
  66         select type (q)
  67           type is (t_b)
  68             this%b = q
  69           class default
  70             STOP 1
  71          end select
  72       class default
  73         STOP 2
  74       end select
  75   end procedure p_a
  76   module procedure print
  77     select type (this)
  78       type is (t_imp)
  79         if (any (this%b%i .ne. [3,4,5])) STOP 3
  80       class default
  81         STOP 4
  82     end select
  83   end procedure
  84 end submodule imp_p_a
  85
  86 program p
  87   use mod_a
  88   use mod_b
  89   implicit none
  90   class(t_a), allocatable :: a
  91   allocate(a, source=create_a())
  92   call p_a(a, create_b([3,4,5]))
  93   call print(a)
  94 end program p