97 lines
2.2 KiB
Fortran
97 lines
2.2 KiB
Fortran
! { dg-do run }
|
|
!
|
|
! Test the fix for PR98342.
|
|
!
|
|
! Contributed by Martin Stein <mscfd@gmx.net>
|
|
!
|
|
module mod
|
|
implicit none
|
|
private
|
|
public get_tuple, sel_rank1, sel_rank2, sel_rank3
|
|
|
|
type, public :: tuple
|
|
integer, dimension(:), allocatable :: t
|
|
end type tuple
|
|
|
|
contains
|
|
|
|
function sel_rank1(x) result(s)
|
|
character(len=:), allocatable :: s
|
|
type(tuple), dimension(..), intent(in) :: x
|
|
select rank (x)
|
|
rank (0)
|
|
s = '10'
|
|
rank (1)
|
|
s = '11'
|
|
rank default
|
|
s = '?'
|
|
end select
|
|
end function sel_rank1
|
|
|
|
function sel_rank2(x) result(s)
|
|
character(len=:), allocatable :: s
|
|
class(tuple), dimension(..), intent(in) :: x
|
|
select rank (x)
|
|
rank (0)
|
|
s = '20'
|
|
rank (1)
|
|
s = '21'
|
|
rank default
|
|
s = '?'
|
|
end select
|
|
end function sel_rank2
|
|
|
|
function sel_rank3(x) result(s)
|
|
character(len=:), allocatable :: s
|
|
class(*), dimension(..), intent(in) :: x
|
|
select rank (x)
|
|
rank (0)
|
|
s = '30'
|
|
rank (1)
|
|
s = '31'
|
|
rank default
|
|
s = '?'
|
|
end select
|
|
end function sel_rank3
|
|
|
|
function get_tuple(t) result(a)
|
|
type(tuple) :: a
|
|
integer, dimension(:), intent(in) :: t
|
|
allocate(a%t, source=t)
|
|
end function get_tuple
|
|
|
|
end module mod
|
|
|
|
|
|
program alloc_rank
|
|
use mod
|
|
implicit none
|
|
|
|
integer, dimension(1:3) :: x
|
|
character(len=:), allocatable :: output
|
|
type(tuple) :: z
|
|
|
|
x = [1,2,3]
|
|
z = get_tuple (x)
|
|
! Derived type formal arg
|
|
output = sel_rank1(get_tuple (x)) ! runtime: Error in `./alloc_rank.x':
|
|
if (output .ne. '10') stop 1
|
|
output = sel_rank1([z]) ! This worked OK
|
|
if (output .ne. '11') stop 2
|
|
|
|
! Class formal arg
|
|
output = sel_rank2(get_tuple (x)) ! runtime: Error in `./alloc_rank.x':
|
|
if (output .ne. '20') stop 3
|
|
output = sel_rank2([z]) ! This worked OK
|
|
if (output .ne. '21') stop 4
|
|
|
|
! Unlimited polymorphic formal arg
|
|
output = sel_rank3(get_tuple (x)) ! runtime: Error in `./alloc_rank.x':
|
|
if (output .ne. '30') stop 5
|
|
output = sel_rank3([z]) ! runtime: segmentation fault
|
|
if (output .ne. '31') stop 6
|
|
|
|
deallocate (output)
|
|
deallocate (z%t)
|
|
end program alloc_rank
|