blob: 101839290b19c7999a14717f89d7ed31596f4ff0 [file] [log] [blame]
! Copyright 2019-2021 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/>.
subroutine show_elem (array)
integer :: array
print *, ""
print *, "Expected GDB Output:"
print *, ""
write(*, fmt="(A)", advance="no") "GDB = "
write(*, fmt="(I0)", advance="no") array
write(*, fmt="(A)", advance="yes") ""
print *, "" ! Display Element
end subroutine show_elem
subroutine show_str (array)
character (len=*) :: array
print *, ""
print *, "Expected GDB Output:"
print *, ""
write (*, fmt="(A)", advance="no") "GDB = '"
write (*, fmt="(A)", advance="no") array
write (*, fmt="(A)", advance="yes") "'"
print *, "" ! Display String
end subroutine show_str
subroutine show_1d (array)
integer, dimension (:) :: array
print *, "Array Contents:"
print *, ""
do i=LBOUND (array, 1), UBOUND (array, 1), 1
write(*, fmt="(i4)", advance="no") array (i)
end do
print *, ""
print *, "Expected GDB Output:"
print *, ""
write(*, fmt="(A)", advance="no") "GDB = ("
do i=LBOUND (array, 1), UBOUND (array, 1), 1
if (i > LBOUND (array, 1)) then
write(*, fmt="(A)", advance="no") ", "
end if
write(*, fmt="(I0)", advance="no") array (i)
end do
write(*, fmt="(A)", advance="no") ")"
print *, "" ! Display Array Slice 1D
end subroutine show_1d
subroutine show_2d (array)
integer, dimension (:,:) :: array
print *, "Array Contents:"
print *, ""
do i=LBOUND (array, 2), UBOUND (array, 2), 1
do j=LBOUND (array, 1), UBOUND (array, 1), 1
write(*, fmt="(i4)", advance="no") array (j, i)
end do
print *, ""
end do
print *, ""
print *, "Expected GDB Output:"
print *, ""
write(*, fmt="(A)", advance="no") "GDB = ("
do i=LBOUND (array, 2), UBOUND (array, 2), 1
if (i > LBOUND (array, 2)) then
write(*, fmt="(A)", advance="no") " "
end if
write(*, fmt="(A)", advance="no") "("
do j=LBOUND (array, 1), UBOUND (array, 1), 1
if (j > LBOUND (array, 1)) then
write(*, fmt="(A)", advance="no") ", "
end if
write(*, fmt="(I0)", advance="no") array (j, i)
end do
write(*, fmt="(A)", advance="no") ")"
end do
write(*, fmt="(A)", advance="yes") ")"
print *, "" ! Display Array Slice 2D
end subroutine show_2d
subroutine show_3d (array)
integer, dimension (:,:,:) :: array
print *, ""
print *, "Expected GDB Output:"
print *, ""
write(*, fmt="(A)", advance="no") "GDB = ("
do i=LBOUND (array, 3), UBOUND (array, 3), 1
if (i > LBOUND (array, 3)) then
write(*, fmt="(A)", advance="no") " "
end if
write(*, fmt="(A)", advance="no") "("
do j=LBOUND (array, 2), UBOUND (array, 2), 1
if (j > LBOUND (array, 2)) then
write(*, fmt="(A)", advance="no") " "
end if
write(*, fmt="(A)", advance="no") "("
do k=LBOUND (array, 1), UBOUND (array, 1), 1
if (k > LBOUND (array, 1)) then
write(*, fmt="(A)", advance="no") ", "
end if
write(*, fmt="(I0)", advance="no") array (k, j, i)
end do
write(*, fmt="(A)", advance="no") ")"
end do
write(*, fmt="(A)", advance="no") ")"
end do
write(*, fmt="(A)", advance="yes") ")"
print *, "" ! Display Array Slice 3D
end subroutine show_3d
subroutine show_4d (array)
integer, dimension (:,:,:,:) :: array
print *, ""
print *, "Expected GDB Output:"
print *, ""
write(*, fmt="(A)", advance="no") "GDB = ("
do i=LBOUND (array, 4), UBOUND (array, 4), 1
if (i > LBOUND (array, 4)) then
write(*, fmt="(A)", advance="no") " "
end if
write(*, fmt="(A)", advance="no") "("
do j=LBOUND (array, 3), UBOUND (array, 3), 1
if (j > LBOUND (array, 3)) then
write(*, fmt="(A)", advance="no") " "
end if
write(*, fmt="(A)", advance="no") "("
do k=LBOUND (array, 2), UBOUND (array, 2), 1
if (k > LBOUND (array, 2)) then
write(*, fmt="(A)", advance="no") " "
end if
write(*, fmt="(A)", advance="no") "("
do l=LBOUND (array, 1), UBOUND (array, 1), 1
if (l > LBOUND (array, 1)) then
write(*, fmt="(A)", advance="no") ", "
end if
write(*, fmt="(I0)", advance="no") array (l, k, j, i)
end do
write(*, fmt="(A)", advance="no") ")"
end do
write(*, fmt="(A)", advance="no") ")"
end do
write(*, fmt="(A)", advance="no") ")"
end do
write(*, fmt="(A)", advance="yes") ")"
print *, "" ! Display Array Slice 4D
end subroutine show_4d
!
! Start of test program.
!
program test
interface
subroutine show_str (array)
character (len=*) :: array
end subroutine show_str
subroutine show_1d (array)
integer, dimension (:) :: array
end subroutine show_1d
subroutine show_2d (array)
integer, dimension(:,:) :: array
end subroutine show_2d
subroutine show_3d (array)
integer, dimension(:,:,:) :: array
end subroutine show_3d
subroutine show_4d (array)
integer, dimension(:,:,:,:) :: array
end subroutine show_4d
end interface
! Declare variables used in this test.
integer, dimension (-10:-1,-10:-2) :: neg_array
integer, dimension (1:10,1:10) :: array
integer, allocatable :: other (:, :)
character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz"
integer, dimension (-2:2,-2:2,-2:2) :: array3d
integer, dimension (-3:3,7:10,-3:3,-10:-7) :: array4d
integer, dimension (10:20) :: array1d
integer, dimension(:,:), pointer :: pointer2d => null()
integer, dimension(-1:9,-1:9), target :: tarray
! Allocate or associate any variables as needed.
allocate (other (-5:4, -2:7))
pointer2d => tarray
! Fill arrays with contents ready for testing.
call fill_array_1d (array1d)
call fill_array_2d (neg_array)
call fill_array_2d (array)
call fill_array_2d (other)
call fill_array_2d (tarray)
call fill_array_3d (array3d)
call fill_array_4d (array4d)
! The tests. Each call to a show_* function must have a unique set
! of arguments as GDB uses the arguments are part of the test name
! string, so duplicate arguments will result in duplicate test
! names.
!
! If a show_* line ends with VARS=... where '...' is a comma
! separated list of variable names, these variables are assumed to
! be part of the call line, and will be expanded by the test script,
! for example:
!
! do x=1,9,1
! do y=x,10,1
! call show_1d (some_array (x,y)) ! VARS=x,y
! end do
! end do
!
! In this example the test script will automatically expand 'x' and
! 'y' in order to better test different aspects of GDB. Do take
! care, the expansion is not very "smart", so try to avoid clashing
! with other text on the line, in the example above, avoid variables
! named 'some' or 'array', as these will likely clash with
! 'some_array'.
call show_str (str_1)
call show_str (str_1 (1:20))
call show_str (str_1 (10:20))
call show_elem (array1d (11))
call show_elem (pointer2d (2,3))
call show_1d (array1d)
call show_1d (array1d (13:17))
call show_1d (array1d (17:13:-1))
call show_1d (array (1:5,1))
call show_1d (array4d (1,7,3,:))
call show_1d (pointer2d (-1:3, 2))
call show_1d (pointer2d (-1, 2:4))
! Enclosing the array slice argument in (...) causess gfortran to
! repack the array.
call show_1d ((array (1:5,1)))
call show_2d (pointer2d)
call show_2d (array)
call show_2d (array (1:5,1:5))
do i=1,10,2
do j=1,10,3
call show_2d (array (1:10:i,1:10:j)) ! VARS=i,j
call show_2d (array (10:1:-i,1:10:j)) ! VARS=i,j
call show_2d (array (10:1:-i,10:1:-j)) ! VARS=i,j
call show_2d (array (1:10:i,10:1:-j)) ! VARS=i,j
end do
end do
call show_2d (array (6:2:-1,3:9))
call show_2d (array (1:10:2, 1:10:2))
call show_2d (other)
call show_2d (other (-5:0, -2:0))
call show_2d (other (-5:4:2, -2:7:3))
call show_2d (neg_array)
call show_2d (neg_array (-10:-3,-8:-4:2))
! Enclosing the array slice argument in (...) causess gfortran to
! repack the array.
call show_2d ((array (1:10:3, 1:10:2)))
call show_2d ((neg_array (-10:-3,-8:-4:2)))
call show_3d (array3d)
call show_3d (array3d(-1:1,-1:1,-1:1))
call show_3d (array3d(1:-1:-1,1:-1:-1,1:-1:-1))
! Enclosing the array slice argument in (...) causess gfortran to
! repack the array.
call show_3d ((array3d(1:-1:-1,1:-1:-1,1:-1:-1)))
call show_4d (array4d)
call show_4d (array4d (-3:0,10:7:-1,0:3,-7:-10:-1))
call show_4d (array4d (3:0:-1, 10:7:-1, :, -7:-10:-1))
! Enclosing the array slice argument in (...) causess gfortran to
! repack the array.
call show_4d ((array4d (3:-2:-2, 10:7:-2, :, -7:-10:-1)))
! All done. Deallocate.
deallocate (other)
! GDB catches this final breakpoint to indicate the end of the test.
print *, "" ! Final Breakpoint.
contains
! Fill a 1D array with a unique positive integer in each element.
subroutine fill_array_1d (array)
integer, dimension (:) :: array
integer :: counter
counter = 1
do j=LBOUND (array, 1), UBOUND (array, 1), 1
array (j) = counter
counter = counter + 1
end do
end subroutine fill_array_1d
! Fill a 2D array with a unique positive integer in each element.
subroutine fill_array_2d (array)
integer, dimension (:,:) :: array
integer :: counter
counter = 1
do i=LBOUND (array, 2), UBOUND (array, 2), 1
do j=LBOUND (array, 1), UBOUND (array, 1), 1
array (j,i) = counter
counter = counter + 1
end do
end do
end subroutine fill_array_2d
! Fill a 3D array with a unique positive integer in each element.
subroutine fill_array_3d (array)
integer, dimension (:,:,:) :: array
integer :: counter
counter = 1
do i=LBOUND (array, 3), UBOUND (array, 3), 1
do j=LBOUND (array, 2), UBOUND (array, 2), 1
do k=LBOUND (array, 1), UBOUND (array, 1), 1
array (k, j,i) = counter
counter = counter + 1
end do
end do
end do
end subroutine fill_array_3d
! Fill a 4D array with a unique positive integer in each element.
subroutine fill_array_4d (array)
integer, dimension (:,:,:,:) :: array
integer :: counter
counter = 1
do i=LBOUND (array, 4), UBOUND (array, 4), 1
do j=LBOUND (array, 3), UBOUND (array, 3), 1
do k=LBOUND (array, 2), UBOUND (array, 2), 1
do l=LBOUND (array, 1), UBOUND (array, 1), 1
array (l, k, j,i) = counter
counter = counter + 1
end do
end do
end do
end do
print *, ""
end subroutine fill_array_4d
end program test