mirror of
https://github.com/bminor/binutils-gdb.git
synced 2025-12-25 00:37:38 +00:00
d01e823438
This updates the copyright headers to include 2025. I did this by running gdb/copyright.py and then manually modifying a few files as noted by the script. Approved-By: Eli Zaretskii <eliz@gnu.org>
279 lines
9.8 KiB
Fortran
279 lines
9.8 KiB
Fortran
! Copyright 2021-2025 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
|