173 lines
5.4 KiB
Fortran
173 lines
5.4 KiB
Fortran
! 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/>.
|
|
|
|
#define DO_TEST(ARRAY) \
|
|
call do_test (lbound (ARRAY), ubound (ARRAY))
|
|
|
|
subroutine do_test (lb, ub)
|
|
integer*4, dimension (:) :: lb
|
|
integer*4, dimension (:) :: ub
|
|
|
|
print *, ""
|
|
print *, "Expected GDB Output:"
|
|
print *, ""
|
|
|
|
write(*, fmt="(A)", advance="no") "LBOUND = ("
|
|
do i=LBOUND (lb, 1), UBOUND (lb, 1), 1
|
|
if (i > LBOUND (lb, 1)) then
|
|
write(*, fmt="(A)", advance="no") ", "
|
|
end if
|
|
write(*, fmt="(I0)", advance="no") lb (i)
|
|
end do
|
|
write(*, fmt="(A)", advance="yes") ")"
|
|
|
|
write(*, fmt="(A)", advance="no") "UBOUND = ("
|
|
do i=LBOUND (ub, 1), UBOUND (ub, 1), 1
|
|
if (i > LBOUND (ub, 1)) then
|
|
write(*, fmt="(A)", advance="no") ", "
|
|
end if
|
|
write(*, fmt="(I0)", advance="no") ub (i)
|
|
end do
|
|
write(*, fmt="(A)", advance="yes") ")"
|
|
|
|
print *, "" ! Test Breakpoint
|
|
end subroutine do_test
|
|
|
|
!
|
|
! Start of test program.
|
|
!
|
|
program test
|
|
use ISO_C_BINDING, only: C_NULL_PTR, C_SIZEOF
|
|
|
|
interface
|
|
subroutine do_test (lb, ub)
|
|
integer*4, dimension (:) :: lb
|
|
integer*4, dimension (:) :: ub
|
|
end subroutine do_test
|
|
end interface
|
|
|
|
! Declare variables used in this test.
|
|
integer, dimension (-8:-1,-10:-2) :: neg_array
|
|
integer, dimension (2:10,1:9), target :: array
|
|
integer, allocatable :: other (:, :)
|
|
character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz"
|
|
integer, dimension (-2:2,-3:3,-1:5) :: array3d
|
|
integer, dimension (-3:3,7:10,-4:2,-10:-7) :: array4d
|
|
integer, dimension (10:20) :: array1d
|
|
integer, dimension(:,:), pointer :: pointer2d => null()
|
|
integer, dimension(-2:6,-1:9), target :: tarray
|
|
integer :: an_int
|
|
|
|
integer, dimension (:), pointer :: pointer1d => null()
|
|
|
|
integer, parameter :: b1 = 127 - 10
|
|
integer, parameter :: b1_o = 127 + 2
|
|
integer, parameter :: b2 = 32767 - 10
|
|
integer, parameter :: b2_o = 32767 + 3
|
|
|
|
! This 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, parameter :: b4 = max_signed_4byte_int - 10
|
|
integer*8 :: b4_o
|
|
logical :: is_64_bit
|
|
|
|
integer, allocatable :: array_1d_1bytes_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 (:,:,:)
|
|
|
|
! 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 or associate any variables as needed.
|
|
allocate (other (-5:4, -2:7))
|
|
pointer2d => tarray
|
|
pointer1d => array (3, 2:5)
|
|
|
|
allocate (array_1d_1bytes_overflow (-b1_o:-b1))
|
|
allocate (array_1d_2bytes_overflow (b2:b2_o))
|
|
if (is_64_bit) then
|
|
allocate (array_1d_4bytes_overflow (-b4_o:-b4))
|
|
end if
|
|
allocate (array_2d_1byte_overflow (-b1_o:-b1,b1:b1_o))
|
|
allocate (array_2d_2bytes_overflow (b2:b2_o,-b2_o:b2))
|
|
|
|
allocate (array_3d_1byte_overflow (-b1_o:-b1,b1:b1_o,-b1_o:-b1))
|
|
|
|
DO_TEST (neg_array)
|
|
DO_TEST (neg_array (-7:-3,-5:-4))
|
|
DO_TEST (array)
|
|
! The following is disabled due to a bug in gfortran:
|
|
! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99027
|
|
! gfortran generates the incorrect expected results.
|
|
! DO_TEST (array (3, 2:5))
|
|
DO_TEST (pointer1d)
|
|
DO_TEST (other)
|
|
DO_TEST (array3d)
|
|
DO_TEST (array4d)
|
|
DO_TEST (array1d)
|
|
DO_TEST (pointer2d)
|
|
DO_TEST (tarray)
|
|
|
|
DO_TEST (array_1d_1bytes_overflow)
|
|
DO_TEST (array_1d_2bytes_overflow)
|
|
|
|
if (is_64_bit) then
|
|
DO_TEST (array_1d_4bytes_overflow)
|
|
end if
|
|
DO_TEST (array_2d_1byte_overflow)
|
|
DO_TEST (array_2d_2bytes_overflow)
|
|
DO_TEST (array_3d_1byte_overflow)
|
|
|
|
! All done. Deallocate.
|
|
print *, "" ! Breakpoint before deallocate.
|
|
deallocate (other)
|
|
|
|
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_1bytes_overflow)
|
|
|
|
! GDB catches this final breakpoint to indicate the end of the test.
|
|
print *, "" ! Final Breakpoint.
|
|
|
|
! Reference otherwise unused locals in order to keep them around.
|
|
! GDB will make use of these for some tests.
|
|
print *, str_1
|
|
an_int = 1
|
|
print *, an_int
|
|
|
|
end program test
|