blob: 57e8c5fc84afd7d20634ecaa9a26aa734d70924f [file] [log] [blame]
! Copyright 2021-2022 Free Software Foundation, Inc.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program. If not, see <http://www.gnu.org/licenses/>.
!
! Start of test program.
!
program test
use ISO_C_BINDING, only: C_NULL_PTR, C_SIZEOF
! Things to perform tests on.
integer, target :: array_1d (1:10) = 0
integer, target :: array_2d (1:4, 1:3) = 0
integer :: an_integer = 0
real :: a_real = 0.0
integer, pointer :: array_1d_p (:) => null ()
integer, pointer :: array_2d_p (:,:) => null ()
integer, allocatable :: allocatable_array_1d (:)
integer, allocatable :: allocatable_array_2d (:,:)
integer, parameter :: b1_o = 127 + 1
integer, parameter :: b2_o = 32767 + 3
! This test tests the GDB overflow behavior when using a KIND parameter
! too small to hold the actual output argument. This is done for 1, 2, and
! 4 byte overflow. On 32-bit machines most compilers will complain when
! trying to allocate an array with ranges outside the 4 byte integer range.
! We take the byte size of a C pointer as indication as to whether or not we
! are on a 32 bit machine an skip the 4 byte overflow tests in that case.
integer, parameter :: bytes_c_ptr = C_SIZEOF(C_NULL_PTR)
integer*8, parameter :: max_signed_4byte_int = 2147483647
integer*8 :: b4_o
logical :: is_64_bit
integer, allocatable :: array_1d_1byte_overflow (:)
integer, allocatable :: array_1d_2bytes_overflow (:)
integer, allocatable :: array_1d_4bytes_overflow (:)
integer, allocatable :: array_2d_1byte_overflow (:,:)
integer, allocatable :: array_2d_2bytes_overflow (:,:)
integer, allocatable :: array_3d_1byte_overflow (:,:,:)
! Loop counters.
integer :: s1, s2
! Set the 4 byte overflow only on 64 bit machines.
if (bytes_c_ptr < 8) then
b4_o = 0
is_64_bit = .FALSE.
else
b4_o = max_signed_4byte_int + 5
is_64_bit = .TRUE.
end if
allocate (array_1d_1byte_overflow (1:b1_o))
allocate (array_1d_2bytes_overflow (1:b2_o))
if (is_64_bit) then
allocate (array_1d_4bytes_overflow (b4_o-b2_o:b4_o))
end if
allocate (array_2d_1byte_overflow (1:b1_o, 1:b1_o))
allocate (array_2d_2bytes_overflow (b2_o-b1_o:b2_o, b2_o-b1_o:b2_o))
allocate (array_3d_1byte_overflow (1:b1_o, 1:b1_o, 1:b1_o))
! The start of the tests.
call test_size_4 (size (array_1d))
call test_size_4 (size (array_1d, 1))
do s1=1, SIZE (array_1d, 1), 1
call test_size_4 (size (array_1d (1:10:s1)))
call test_size_4 (size (array_1d (1:10:s1), 1))
call test_size_4 (size (array_1d (10:1:-s1)))
call test_size_4 (size (array_1d (10:1:-s1), 1))
end do
do s2=1, SIZE (array_2d, 2), 1
do s1=1, SIZE (array_2d, 1), 1
call test_size_4 (size (array_2d (1:4:s1, 1:3:s2)))
call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2)))
call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2)))
call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2)))
call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 1))
call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 1))
call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 1))
call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 1))
call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 2))
call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 2))
call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 2))
call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 2))
end do
end do
allocate (allocatable_array_1d (-10:-5))
call test_size_4 (size (allocatable_array_1d))
do s1=1, SIZE (allocatable_array_1d, 1), 1
call test_size_4 (size (allocatable_array_1d (-10:-5:s1)))
call test_size_4 (size (allocatable_array_1d (-5:-10:-s1)))
call test_size_4 (size (allocatable_array_1d (-10:-5:s1), 1))
call test_size_4 (size (allocatable_array_1d (-5:-10:-s1), 1))
end do
allocate (allocatable_array_2d (-3:3, 8:12))
do s2=1, SIZE (allocatable_array_2d, 2), 1
do s1=1, SIZE (allocatable_array_2d, 1), 1
call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
end do
end do
array_1d_p => array_1d
call test_size_4 (size (array_1d_p))
call test_size_4 (size (array_1d_p, 1))
array_2d_p => array_2d
call test_size_4 (size (array_2d_p))
call test_size_4 (size (array_2d_p, 1))
call test_size_4 (size (array_2d_p, 2))
! Test kind parameters - compiler requires these to be compile time constant
! so sadly there cannot be a loop over the kinds 1, 2, 4, 8.
call test_size_4 (size (array_1d_1byte_overflow))
call test_size_4 (size (array_1d_2bytes_overflow))
call test_size_4 (size (array_1d_1byte_overflow, 1))
call test_size_4 (size (array_1d_2bytes_overflow, 1))
if (is_64_bit) then
call test_size_4 (size (array_1d_4bytes_overflow))
call test_size_4 (size (array_1d_4bytes_overflow, 1))
end if
call test_size_4 (size (array_2d_1byte_overflow, 1))
call test_size_4 (size (array_2d_1byte_overflow, 2))
call test_size_4 (size (array_2d_2bytes_overflow, 1))
call test_size_4 (size (array_2d_2bytes_overflow, 2))
call test_size_4 (size (array_3d_1byte_overflow, 1))
call test_size_4 (size (array_3d_1byte_overflow, 2))
call test_size_4 (size (array_3d_1byte_overflow, 3))
! Kind 1.
call test_size_1 (size (array_1d_1byte_overflow, 1, 1))
call test_size_1 (size (array_1d_2bytes_overflow, 1, 1))
if (is_64_bit) then
call test_size_1 (size (array_1d_4bytes_overflow, 1, 1))
end if
call test_size_1 (size (array_2d_1byte_overflow, 1, 1))
call test_size_1 (size (array_2d_1byte_overflow, 2, 1))
call test_size_1 (size (array_2d_2bytes_overflow, 1, 1))
call test_size_1 (size (array_2d_2bytes_overflow, 2, 1))
call test_size_1 (size (array_3d_1byte_overflow, 1, 1))
call test_size_1 (size (array_3d_1byte_overflow, 2, 1))
call test_size_1 (size (array_3d_1byte_overflow, 3, 1))
! Kind 2.
call test_size_2 (size (array_1d_1byte_overflow, 1, 2))
call test_size_2 (size (array_1d_2bytes_overflow, 1, 2))
if (is_64_bit) then
call test_size_2 (size (array_1d_4bytes_overflow, 1, 2))
end if
call test_size_2 (size (array_2d_1byte_overflow, 1, 2))
call test_size_2 (size (array_2d_1byte_overflow, 2, 2))
call test_size_2 (size (array_2d_2bytes_overflow, 1, 2))
call test_size_2 (size (array_2d_2bytes_overflow, 2, 2))
call test_size_2 (size (array_3d_1byte_overflow, 1, 2))
call test_size_2 (size (array_3d_1byte_overflow, 2, 2))
call test_size_2 (size (array_3d_1byte_overflow, 3, 2))
! Kind 4.
call test_size_4 (size (array_1d_1byte_overflow, 1, 4))
call test_size_4 (size (array_1d_2bytes_overflow, 1, 4))
if (is_64_bit) then
call test_size_4 (size (array_1d_4bytes_overflow, 1, 4))
end if
call test_size_4 (size (array_2d_1byte_overflow, 1, 4))
call test_size_4 (size (array_2d_1byte_overflow, 2, 4))
call test_size_4 (size (array_2d_2bytes_overflow, 1, 4))
call test_size_4 (size (array_2d_2bytes_overflow, 2, 4))
call test_size_4 (size (array_3d_1byte_overflow, 1, 4))
call test_size_4 (size (array_3d_1byte_overflow, 2, 4))
call test_size_4 (size (array_3d_1byte_overflow, 3, 4))
! Kind 8.
call test_size_8 (size (array_1d_1byte_overflow, 1, 8))
call test_size_8 (size (array_1d_2bytes_overflow, 1, 8))
if (is_64_bit) then
call test_size_8 (size (array_1d_4bytes_overflow, 1, 8))
end if
call test_size_8 (size (array_2d_1byte_overflow, 1, 8))
call test_size_8 (size (array_2d_1byte_overflow, 2, 8))
call test_size_8 (size (array_2d_2bytes_overflow, 1, 8))
call test_size_8 (size (array_2d_2bytes_overflow, 2, 8))
call test_size_8 (size (array_3d_1byte_overflow, 1, 8))
call test_size_8 (size (array_3d_1byte_overflow, 2, 8))
call test_size_8 (size (array_3d_1byte_overflow, 3, 8))
print *, "" ! Breakpoint before deallocate.
deallocate (allocatable_array_1d)
deallocate (allocatable_array_2d)
deallocate (array_3d_1byte_overflow)
deallocate (array_2d_2bytes_overflow)
deallocate (array_2d_1byte_overflow)
if (is_64_bit) then
deallocate (array_1d_4bytes_overflow)
end if
deallocate (array_1d_2bytes_overflow)
deallocate (array_1d_1byte_overflow)
array_1d_p => null ()
array_2d_p => null ()
print *, "" ! Final Breakpoint
print *, an_integer
print *, a_real
print *, associated (array_1d_p)
print *, associated (array_2d_p)
print *, allocated (allocatable_array_1d)
print *, allocated (allocatable_array_2d)
contains
subroutine test_size_1 (answer)
integer*1 :: answer
print *, answer ! Test Breakpoint 1
end subroutine test_size_1
subroutine test_size_2 (answer)
integer*2 :: answer
print *, answer ! Test Breakpoint 2
end subroutine test_size_2
subroutine test_size_4 (answer)
integer*4 :: answer
print *, answer ! Test Breakpoint 3
end subroutine test_size_4
subroutine test_size_8 (answer)
integer*8 :: answer
print *, answer ! Test Breakpoint 4
end subroutine test_size_8
end program test