blob: 0a5f5fb2c96d13e483f5b0eb3f7bbfe581e62071 [file] [log] [blame]
! { dg-do run }
! { dg-require-effective-target lto }
! { dg-options "-flto" }
!
! Checks that the results of module procedures have the correct characteristics
! and that submodules use the module version of vtables (PR66762). This latter
! requires the -flto compile option.
!
! Contributed by Reinhold Bader <reinhold.bader@lrz.de>
!
module mod_a
implicit none
type, abstract :: t_a
end type t_a
interface
module subroutine p_a(this, q)
class(t_a), intent(inout) :: this
class(*), intent(in) :: q
end subroutine
module function create_a() result(r)
class(t_a), allocatable :: r
end function
module subroutine print(this)
class(t_a), intent(in) :: this
end subroutine
end interface
end module mod_a
module mod_b
implicit none
type t_b
integer, allocatable :: I(:)
end type t_b
interface
module function create_b(i) result(r)
type(t_b) :: r
integer :: i(:)
end function
end interface
end module mod_b
submodule(mod_b) imp_create
contains
module procedure create_b
if (allocated(r%i)) deallocate(r%i)
allocate(r%i, source=i)
end procedure
end submodule imp_create
submodule(mod_a) imp_p_a
use mod_b
type, extends(t_a) :: t_imp
type(t_b) :: b
end type t_imp
integer, parameter :: ii(2) = [1,2]
contains
module procedure create_a
type(t_b) :: b
b = create_b(ii)
allocate(r, source=t_imp(b))
end procedure
module procedure p_a
select type (this)
type is (t_imp)
select type (q)
type is (t_b)
this%b = q
class default
STOP 1
end select
class default
STOP 2
end select
end procedure p_a
module procedure print
select type (this)
type is (t_imp)
if (any (this%b%i .ne. [3,4,5])) STOP 3
class default
STOP 4
end select
end procedure
end submodule imp_p_a
program p
use mod_a
use mod_b
implicit none
class(t_a), allocatable :: a
allocate(a, source=create_a())
call p_a(a, create_b([3,4,5]))
call print(a)
end program p