| ! { 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 |