1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
! { dg-do run }
! PR libfortran/103634 - Runtime crash with PACK on zero-sized arrays
! Exercise PACK intrinsic for cases when it calls pack_internal
program p
implicit none
type t
real :: r(24) = -99.
end type
type(t), allocatable :: new(:), old(:), vec(:)
logical, allocatable :: mask(:)
integer :: n, m
! m = 1 ! works
m = 0 ! failed with SIGSEGV in pack_internal
do m = 0, 2
print *, m
allocate (old(m), mask(m), vec(m))
if (m > 0) vec(m)% r(1) = 42
mask(:) = .true.
n = count (mask)
allocate (new(n))
mask(:) = .false.
if (size (pack (old, mask)) /= 0) stop 1
mask(:) = .true.
if (size (pack (old, mask)) /= m) stop 2
new(:) = pack (old, mask) ! this used to segfault for m=0
mask(:) = .false.
if (size (pack (old, mask, vector=vec)) /= m) stop 3
new(:) = t()
new(:) = pack (old, mask, vector=vec) ! this used to segfault for m=0
if (m > 0) then
if ( new( m )% r(1) /= 42) stop 4
if (any (new(:m-1)% r(1) /= -99)) stop 5
end if
if (m > 0) mask(m) = .true.
if (size (pack (old, mask, vector=vec)) /= m) stop 6
new(:) = t()
new(:) = pack (old, mask, vector=vec) ! this used to segfault for m=0
if (m > 0) then
if (new(1)% r(1) /= -99) stop 7
end if
if (m > 1) then
if (new(m)% r(1) /= 42) stop 8
end if
if (size (pack (old(:0), mask(:0), vector=vec)) /= m) stop 9
new(:) = t()
new(:) = pack (old(:0), mask(:0), vector=vec) ! did segfault for m=0
if (m > 0) then
if (new(m)% r(1) /= 42) stop 10
end if
deallocate (old, mask, new, vec)
end do
end
|
