gdb/testsuite/gdb.fortran/array-slices.f90

   1 ! Copyright 2019-2024 Free Software Foundation, Inc.
   2 !
   3 ! This program is free software; you can redistribute it and/or modify
   4 ! it under the terms of the GNU General Public License as published by
   5 ! the Free Software Foundation; either version 3 of the License, or
   6 ! (at your option) any later version.
   7 !
   8 ! This program is distributed in the hope that it will be useful,
   9 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ! GNU General Public License for more details.
  12 !
  13 ! You should have received a copy of the GNU General Public License
  14 ! along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 subroutine show_elem (array)
  17   integer :: array
  18
  19   print *, ""
  20   print *, "Expected GDB Output:"
  21   print *, ""
  22
  23   write(*, fmt="(A)", advance="no") "GDB = "
  24   write(*, fmt="(I0)", advance="no") array
  25   write(*, fmt="(A)", advance="yes") ""
  26
  27   print *, ""   ! Display Element
  28 end subroutine show_elem
  29
  30 subroutine show_str (array)
  31   character (len=*) :: array
  32
  33   print *, ""
  34   print *, "Expected GDB Output:"
  35   print *, ""
  36   write (*, fmt="(A)", advance="no") "GDB = '"
  37   write (*, fmt="(A)", advance="no") array
  38   write (*, fmt="(A)", advance="yes") "'"
  39
  40   print *, ""   ! Display String
  41 end subroutine show_str
  42
  43 subroutine show_1d (array)
  44   integer, dimension (:) :: array
  45
  46   print *, "Array Contents:"
  47   print *, ""
  48
  49   do i=LBOUND (array, 1), UBOUND (array, 1), 1
  50      write(*, fmt="(i4)", advance="no") array (i)
  51   end do
  52
  53   print *, ""
  54   print *, "Expected GDB Output:"
  55   print *, ""
  56
  57   write(*, fmt="(A)", advance="no") "GDB = ("
  58   do i=LBOUND (array, 1), UBOUND (array, 1), 1
  59      if (i > LBOUND (array, 1)) then
  60         write(*, fmt="(A)", advance="no") ", "
  61      end if
  62      write(*, fmt="(I0)", advance="no") array (i)
  63   end do
  64   write(*, fmt="(A)", advance="yes") ")"
  65
  66   print *, ""   ! Display Array Slice 1D
  67 end subroutine show_1d
  68
  69 subroutine show_2d (array)
  70   integer, dimension (:,:) :: array
  71
  72   print *, "Array Contents:"
  73   print *, ""
  74
  75   do i=LBOUND (array, 2), UBOUND (array, 2), 1
  76      do j=LBOUND (array, 1), UBOUND (array, 1), 1
  77         write(*, fmt="(i4)", advance="no") array (j, i)
  78      end do
  79      print *, ""
  80   end do
  81
  82   print *, ""
  83   print *, "Expected GDB Output:"
  84   print *, ""
  85
  86   write(*, fmt="(A)", advance="no") "GDB = ("
  87   do i=LBOUND (array, 2), UBOUND (array, 2), 1
  88      if (i > LBOUND (array, 2)) then
  89         write(*, fmt="(A)", advance="no") " "
  90      end if
  91      write(*, fmt="(A)", advance="no") "("
  92      do j=LBOUND (array, 1), UBOUND (array, 1), 1
  93         if (j > LBOUND (array, 1)) then
  94            write(*, fmt="(A)", advance="no") ", "
  95         end if
  96         write(*, fmt="(I0)", advance="no") array (j, i)
  97      end do
  98      write(*, fmt="(A)", advance="no") ")"
  99   end do
 100   write(*, fmt="(A)", advance="yes") ")"
 101
 102   print *, ""   ! Display Array Slice 2D
 103 end subroutine show_2d
 104
 105 subroutine show_3d (array)
 106   integer, dimension (:,:,:) :: array
 107
 108   print *, ""
 109   print *, "Expected GDB Output:"
 110   print *, ""
 111
 112   write(*, fmt="(A)", advance="no") "GDB = ("
 113   do i=LBOUND (array, 3), UBOUND (array, 3), 1
 114      if (i > LBOUND (array, 3)) then
 115         write(*, fmt="(A)", advance="no") " "
 116      end if
 117      write(*, fmt="(A)", advance="no") "("
 118      do j=LBOUND (array, 2), UBOUND (array, 2), 1
 119         if (j > LBOUND (array, 2)) then
 120            write(*, fmt="(A)", advance="no") " "
 121         end if
 122         write(*, fmt="(A)", advance="no") "("
 123         do k=LBOUND (array, 1), UBOUND (array, 1), 1
 124            if (k > LBOUND (array, 1)) then
 125               write(*, fmt="(A)", advance="no") ", "
 126            end if
 127            write(*, fmt="(I0)", advance="no") array (k, j, i)
 128         end do
 129         write(*, fmt="(A)", advance="no") ")"
 130      end do
 131      write(*, fmt="(A)", advance="no") ")"
 132   end do
 133   write(*, fmt="(A)", advance="yes") ")"
 134
 135   print *, ""   ! Display Array Slice 3D
 136 end subroutine show_3d
 137
 138 subroutine show_4d (array)
 139   integer, dimension (:,:,:,:) :: array
 140
 141   print *, ""
 142   print *, "Expected GDB Output:"
 143   print *, ""
 144
 145   write(*, fmt="(A)", advance="no") "GDB = ("
 146   do i=LBOUND (array, 4), UBOUND (array, 4), 1
 147      if (i > LBOUND (array, 4)) then
 148         write(*, fmt="(A)", advance="no") " "
 149      end if
 150      write(*, fmt="(A)", advance="no") "("
 151      do j=LBOUND (array, 3), UBOUND (array, 3), 1
 152         if (j > LBOUND (array, 3)) then
 153            write(*, fmt="(A)", advance="no") " "
 154         end if
 155         write(*, fmt="(A)", advance="no") "("
 156
 157         do k=LBOUND (array, 2), UBOUND (array, 2), 1
 158            if (k > LBOUND (array, 2)) then
 159               write(*, fmt="(A)", advance="no") " "
 160            end if
 161            write(*, fmt="(A)", advance="no") "("
 162            do l=LBOUND (array, 1), UBOUND (array, 1), 1
 163               if (l > LBOUND (array, 1)) then
 164                  write(*, fmt="(A)", advance="no") ", "
 165               end if
 166               write(*, fmt="(I0)", advance="no") array (l, k, j, i)
 167            end do
 168            write(*, fmt="(A)", advance="no") ")"
 169         end do
 170         write(*, fmt="(A)", advance="no") ")"
 171      end do
 172      write(*, fmt="(A)", advance="no") ")"
 173   end do
 174   write(*, fmt="(A)", advance="yes") ")"
 175
 176   print *, ""   ! Display Array Slice 4D
 177 end subroutine show_4d
 178
 179 !
 180 ! Start of test program.
 181 !
 182 program test
 183   interface
 184      subroutine show_str (array)
 185        character (len=*) :: array
 186      end subroutine show_str
 187
 188      subroutine show_1d (array)
 189        integer, dimension (:) :: array
 190      end subroutine show_1d
 191
 192      subroutine show_2d (array)
 193        integer, dimension(:,:) :: array
 194      end subroutine show_2d
 195
 196      subroutine show_3d (array)
 197        integer, dimension(:,:,:) :: array
 198      end subroutine show_3d
 199
 200      subroutine show_4d (array)
 201        integer, dimension(:,:,:,:) :: array
 202      end subroutine show_4d
 203   end interface
 204
 205   ! Declare variables used in this test.
 206   integer, dimension (-10:-1,-10:-2) :: neg_array
 207   integer, dimension (1:10,1:10) :: array
 208   integer, allocatable :: other (:, :)
 209   character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz"
 210   integer, dimension (-2:2,-2:2,-2:2) :: array3d
 211   integer, dimension (-3:3,7:10,-3:3,-10:-7) :: array4d
 212   integer, dimension (10:20) :: array1d
 213   integer, dimension(:,:), pointer :: pointer2d => null()
 214   integer, dimension(-1:9,-1:9), target :: tarray
 215
 216   ! Allocate or associate any variables as needed.
 217   allocate (other (-5:4, -2:7))
 218   pointer2d => tarray
 219
 220   ! Fill arrays with contents ready for testing.
 221   call fill_array_1d (array1d)
 222
 223   call fill_array_2d (neg_array)
 224   call fill_array_2d (array)
 225   call fill_array_2d (other)
 226   call fill_array_2d (tarray)
 227
 228   call fill_array_3d (array3d)
 229   call fill_array_4d (array4d)
 230
 231   ! The tests.  Each call to a show_* function must have a unique set
 232   ! of arguments as GDB uses the arguments are part of the test name
 233   ! string, so duplicate arguments will result in duplicate test
 234   ! names.
 235   !
 236   ! If a show_* line ends with VARS=... where '...' is a comma
 237   ! separated list of variable names, these variables are assumed to
 238   ! be part of the call line, and will be expanded by the test script,
 239   ! for example:
 240   !
 241   !     do x=1,9,1
 242   !       do y=x,10,1
 243   !         call show_1d (some_array (x,y))     ! VARS=x,y
 244   !       end do
 245   !     end do
 246   !
 247   ! In this example the test script will automatically expand 'x' and
 248   ! 'y' in order to better test different aspects of GDB.  Do take
 249   ! care, the expansion is not very "smart", so try to avoid clashing
 250   ! with other text on the line, in the example above, avoid variables
 251   ! named 'some' or 'array', as these will likely clash with
 252   ! 'some_array'.
 253   call show_str (str_1)
 254   call show_str (str_1 (1:20))
 255   call show_str (str_1 (10:20))
 256
 257   call show_elem (array1d (11))
 258   call show_elem (pointer2d (2,3))
 259
 260   call show_1d (array1d)
 261   call show_1d (array1d (13:17))
 262   call show_1d (array1d (17:13:-1))
 263   call show_1d (array (1:5,1))
 264   call show_1d (array4d (1,7,3,:))
 265   call show_1d (pointer2d (-1:3, 2))
 266   call show_1d (pointer2d (-1, 2:4))
 267
 268   ! Enclosing the array slice argument in (...) causess gfortran to
 269   ! repack the array.
 270   call show_1d ((array (1:5,1)))
 271
 272   call show_2d (pointer2d)
 273   call show_2d (array)
 274   call show_2d (array (1:5,1:5))
 275   do i=1,10,2
 276      do j=1,10,3
 277         call show_2d (array (1:10:i,1:10:j))    ! VARS=i,j
 278         call show_2d (array (10:1:-i,1:10:j))   ! VARS=i,j
 279         call show_2d (array (10:1:-i,10:1:-j))  ! VARS=i,j
 280         call show_2d (array (1:10:i,10:1:-j))   ! VARS=i,j
 281      end do
 282   end do
 283   call show_2d (array (6:2:-1,3:9))
 284   call show_2d (array (1:10:2, 1:10:2))
 285   call show_2d (other)
 286   call show_2d (other (-5:0, -2:0))
 287   call show_2d (other (-5:4:2, -2:7:3))
 288   call show_2d (neg_array)
 289   call show_2d (neg_array (-10:-3,-8:-4:2))
 290
 291   ! Enclosing the array slice argument in (...) causess gfortran to
 292   ! repack the array.
 293   call show_2d ((array (1:10:3, 1:10:2)))
 294   call show_2d ((neg_array (-10:-3,-8:-4:2)))
 295
 296   call show_3d (array3d)
 297   call show_3d (array3d(-1:1,-1:1,-1:1))
 298   call show_3d (array3d(1:-1:-1,1:-1:-1,1:-1:-1))
 299
 300   ! Enclosing the array slice argument in (...) causess gfortran to
 301   ! repack the array.
 302   call show_3d ((array3d(1:-1:-1,1:-1:-1,1:-1:-1)))
 303
 304   call show_4d (array4d)
 305   call show_4d (array4d (-3:0,10:7:-1,0:3,-7:-10:-1))
 306   call show_4d (array4d (3:0:-1, 10:7:-1, :, -7:-10:-1))
 307
 308   ! Enclosing the array slice argument in (...) causess gfortran to
 309   ! repack the array.
 310   call show_4d ((array4d (3:-2:-2, 10:7:-2, :, -7:-10:-1)))
 311
 312   ! All done.  Deallocate.
 313   deallocate (other)
 314
 315   ! GDB catches this final breakpoint to indicate the end of the test.
 316   print *, "" ! Final Breakpoint.
 317
 318 contains
 319
 320   ! Fill a 1D array with a unique positive integer in each element.
 321   subroutine fill_array_1d (array)
 322     integer, dimension (:) :: array
 323     integer :: counter
 324
 325     counter = 1
 326     do j=LBOUND (array, 1), UBOUND (array, 1), 1
 327        array (j) = counter
 328        counter = counter + 1
 329     end do
 330   end subroutine fill_array_1d
 331
 332   ! Fill a 2D array with a unique positive integer in each element.
 333   subroutine fill_array_2d (array)
 334     integer, dimension (:,:) :: array
 335     integer :: counter
 336
 337     counter = 1
 338     do i=LBOUND (array, 2), UBOUND (array, 2), 1
 339        do j=LBOUND (array, 1), UBOUND (array, 1), 1
 340           array (j,i) = counter
 341           counter = counter + 1
 342        end do
 343     end do
 344   end subroutine fill_array_2d
 345
 346   ! Fill a 3D array with a unique positive integer in each element.
 347   subroutine fill_array_3d (array)
 348     integer, dimension (:,:,:) :: array
 349     integer :: counter
 350
 351     counter = 1
 352     do i=LBOUND (array, 3), UBOUND (array, 3), 1
 353        do j=LBOUND (array, 2), UBOUND (array, 2), 1
 354           do k=LBOUND (array, 1), UBOUND (array, 1), 1
 355              array (k, j,i) = counter
 356              counter = counter + 1
 357           end do
 358        end do
 359     end do
 360   end subroutine fill_array_3d
 361
 362   ! Fill a 4D array with a unique positive integer in each element.
 363   subroutine fill_array_4d (array)
 364     integer, dimension (:,:,:,:) :: array
 365     integer :: counter
 366
 367     counter = 1
 368     do i=LBOUND (array, 4), UBOUND (array, 4), 1
 369        do j=LBOUND (array, 3), UBOUND (array, 3), 1
 370           do k=LBOUND (array, 2), UBOUND (array, 2), 1
 371              do l=LBOUND (array, 1), UBOUND (array, 1), 1
 372                 array (l, k, j,i) = counter
 373                 counter = counter + 1
 374              end do
 375           end do
 376        end do
 377     end do
 378     print *, ""
 379   end subroutine fill_array_4d
 380 end program test