gdb/testsuite/gdb.fortran/size.f90

   1 ! Copyright 2021-2023 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 !
  17 ! Start of test program.
  18 !
  19 program test
  20   use ISO_C_BINDING, only: C_NULL_PTR, C_SIZEOF
  21
  22   ! Things to perform tests on.
  23   integer, target :: array_1d (1:10) = 0
  24   integer, target :: array_2d (1:4, 1:3) = 0
  25   integer :: an_integer = 0
  26   real :: a_real = 0.0
  27   integer, pointer :: array_1d_p (:) => null ()
  28   integer, pointer :: array_2d_p (:,:) => null ()
  29   integer, allocatable :: allocatable_array_1d (:)
  30   integer, allocatable :: allocatable_array_2d (:,:)
  31
  32   integer, parameter :: b1_o = 127 + 1
  33   integer, parameter :: b2_o = 32767 + 3
  34
  35   ! This test tests the GDB overflow behavior when using a KIND parameter
  36   ! too small to hold the actual output argument.  This is done for 1, 2, and
  37   ! 4 byte overflow.  On 32-bit machines most compilers will complain when
  38   ! trying to allocate an array with ranges outside the 4 byte integer range.
  39   ! We take the byte size of a C pointer as indication as to whether or not we
  40   ! are on a 32 bit machine an skip the 4 byte overflow tests in that case.
  41   integer, parameter :: bytes_c_ptr = C_SIZEOF(C_NULL_PTR)
  42   integer*8, parameter :: max_signed_4byte_int = 2147483647
  43   integer*8 :: b4_o
  44   logical :: is_64_bit
  45
  46   integer, allocatable :: array_1d_1byte_overflow (:)
  47   integer, allocatable :: array_1d_2bytes_overflow (:)
  48   integer, allocatable :: array_1d_4bytes_overflow (:)
  49   integer, allocatable :: array_2d_1byte_overflow (:,:)
  50   integer, allocatable :: array_2d_2bytes_overflow (:,:)
  51   integer, allocatable :: array_3d_1byte_overflow (:,:,:)
  52
  53   ! Loop counters.
  54   integer :: s1, s2
  55
  56   ! Set the 4 byte overflow only on 64 bit machines.
  57   if (bytes_c_ptr < 8) then
  58     b4_o = 0
  59     is_64_bit = .FALSE.
  60   else
  61     b4_o = max_signed_4byte_int + 5
  62     is_64_bit = .TRUE.
  63   end if
  64
  65   allocate (array_1d_1byte_overflow (1:b1_o))
  66   allocate (array_1d_2bytes_overflow (1:b2_o))
  67   if (is_64_bit) then
  68     allocate (array_1d_4bytes_overflow (b4_o-b2_o:b4_o))
  69   end if
  70   allocate (array_2d_1byte_overflow (1:b1_o, 1:b1_o))
  71   allocate (array_2d_2bytes_overflow (b2_o-b1_o:b2_o, b2_o-b1_o:b2_o))
  72
  73   allocate (array_3d_1byte_overflow (1:b1_o, 1:b1_o, 1:b1_o))
  74
  75
  76   ! The start of the tests.
  77   call test_size_4 (size (array_1d))
  78   call test_size_4 (size (array_1d, 1))
  79   do s1=1, SIZE (array_1d, 1), 1
  80      call test_size_4 (size (array_1d (1:10:s1)))
  81      call test_size_4 (size (array_1d (1:10:s1), 1))
  82      call test_size_4 (size (array_1d (10:1:-s1)))
  83      call test_size_4 (size (array_1d (10:1:-s1), 1))
  84   end do
  85
  86   do s2=1, SIZE (array_2d, 2), 1
  87      do s1=1, SIZE (array_2d, 1), 1
  88         call test_size_4 (size (array_2d (1:4:s1, 1:3:s2)))
  89         call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2)))
  90         call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2)))
  91         call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2)))
  92
  93         call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 1))
  94         call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 1))
  95         call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 1))
  96         call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 1))
  97
  98         call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 2))
  99         call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 2))
 100         call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 2))
 101         call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 2))
 102      end do
 103   end do
 104
 105   allocate (allocatable_array_1d (-10:-5))
 106   call test_size_4 (size (allocatable_array_1d))
 107   do s1=1, SIZE (allocatable_array_1d, 1), 1
 108      call test_size_4 (size (allocatable_array_1d (-10:-5:s1)))
 109      call test_size_4 (size (allocatable_array_1d (-5:-10:-s1)))
 110
 111      call test_size_4 (size (allocatable_array_1d (-10:-5:s1), 1))
 112      call test_size_4 (size (allocatable_array_1d (-5:-10:-s1), 1))
 113   end do
 114
 115   allocate (allocatable_array_2d (-3:3, 8:12))
 116   do s2=1, SIZE (allocatable_array_2d, 2), 1
 117      do s1=1, SIZE (allocatable_array_2d, 1), 1
 118         call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
 119         call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
 120         call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
 121         call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
 122
 123         call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
 124         call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
 125         call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
 126         call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
 127      end do
 128   end do
 129
 130   array_1d_p => array_1d
 131   call test_size_4 (size (array_1d_p))
 132   call test_size_4 (size (array_1d_p, 1))
 133
 134   array_2d_p => array_2d
 135   call test_size_4 (size (array_2d_p))
 136   call test_size_4 (size (array_2d_p, 1))
 137   call test_size_4 (size (array_2d_p, 2))
 138
 139   ! Test kind parameters - compiler requires these to be compile time constant
 140   ! so sadly there cannot be a loop over the kinds 1, 2, 4, 8.
 141   call test_size_4 (size (array_1d_1byte_overflow))
 142   call test_size_4 (size (array_1d_2bytes_overflow))
 143
 144   call test_size_4 (size (array_1d_1byte_overflow, 1))
 145   call test_size_4 (size (array_1d_2bytes_overflow, 1))
 146
 147   if (is_64_bit) then
 148     call test_size_4 (size (array_1d_4bytes_overflow))
 149     call test_size_4 (size (array_1d_4bytes_overflow, 1))
 150   end if
 151
 152   call test_size_4 (size (array_2d_1byte_overflow, 1))
 153   call test_size_4 (size (array_2d_1byte_overflow, 2))
 154   call test_size_4 (size (array_2d_2bytes_overflow, 1))
 155   call test_size_4 (size (array_2d_2bytes_overflow, 2))
 156
 157   call test_size_4 (size (array_3d_1byte_overflow, 1))
 158   call test_size_4 (size (array_3d_1byte_overflow, 2))
 159   call test_size_4 (size (array_3d_1byte_overflow, 3))
 160
 161   ! Kind 1.
 162
 163   call test_size_1 (size (array_1d_1byte_overflow, 1, 1))
 164   call test_size_1 (size (array_1d_2bytes_overflow, 1, 1))
 165   if (is_64_bit) then
 166     call test_size_1 (size (array_1d_4bytes_overflow, 1, 1))
 167   end if
 168
 169   call test_size_1 (size (array_2d_1byte_overflow, 1, 1))
 170   call test_size_1 (size (array_2d_1byte_overflow, 2, 1))
 171   call test_size_1 (size (array_2d_2bytes_overflow, 1, 1))
 172   call test_size_1 (size (array_2d_2bytes_overflow, 2, 1))
 173
 174   call test_size_1 (size (array_3d_1byte_overflow, 1, 1))
 175   call test_size_1 (size (array_3d_1byte_overflow, 2, 1))
 176   call test_size_1 (size (array_3d_1byte_overflow, 3, 1))
 177
 178   ! Kind 2.
 179   call test_size_2 (size (array_1d_1byte_overflow, 1, 2))
 180   call test_size_2 (size (array_1d_2bytes_overflow, 1, 2))
 181   if (is_64_bit) then
 182     call test_size_2 (size (array_1d_4bytes_overflow, 1, 2))
 183   end if
 184
 185   call test_size_2 (size (array_2d_1byte_overflow, 1, 2))
 186   call test_size_2 (size (array_2d_1byte_overflow, 2, 2))
 187   call test_size_2 (size (array_2d_2bytes_overflow, 1, 2))
 188   call test_size_2 (size (array_2d_2bytes_overflow, 2, 2))
 189
 190   call test_size_2 (size (array_3d_1byte_overflow, 1, 2))
 191   call test_size_2 (size (array_3d_1byte_overflow, 2, 2))
 192   call test_size_2 (size (array_3d_1byte_overflow, 3, 2))
 193
 194   ! Kind 4.
 195   call test_size_4 (size (array_1d_1byte_overflow, 1, 4))
 196   call test_size_4 (size (array_1d_2bytes_overflow, 1, 4))
 197   if (is_64_bit) then
 198     call test_size_4 (size (array_1d_4bytes_overflow, 1, 4))
 199   end if
 200
 201   call test_size_4 (size (array_2d_1byte_overflow, 1, 4))
 202   call test_size_4 (size (array_2d_1byte_overflow, 2, 4))
 203   call test_size_4 (size (array_2d_2bytes_overflow, 1, 4))
 204   call test_size_4 (size (array_2d_2bytes_overflow, 2, 4))
 205
 206   call test_size_4 (size (array_3d_1byte_overflow, 1, 4))
 207   call test_size_4 (size (array_3d_1byte_overflow, 2, 4))
 208   call test_size_4 (size (array_3d_1byte_overflow, 3, 4))
 209
 210   ! Kind 8.
 211   call test_size_8 (size (array_1d_1byte_overflow, 1, 8))
 212   call test_size_8 (size (array_1d_2bytes_overflow, 1, 8))
 213   if (is_64_bit) then
 214     call test_size_8 (size (array_1d_4bytes_overflow, 1, 8))
 215   end if
 216
 217   call test_size_8 (size (array_2d_1byte_overflow, 1, 8))
 218   call test_size_8 (size (array_2d_1byte_overflow, 2, 8))
 219   call test_size_8 (size (array_2d_2bytes_overflow, 1, 8))
 220   call test_size_8 (size (array_2d_2bytes_overflow, 2, 8))
 221
 222   call test_size_8 (size (array_3d_1byte_overflow, 1, 8))
 223   call test_size_8 (size (array_3d_1byte_overflow, 2, 8))
 224   call test_size_8 (size (array_3d_1byte_overflow, 3, 8))
 225
 226   print *, "" ! Breakpoint before deallocate.
 227
 228   deallocate (allocatable_array_1d)
 229   deallocate (allocatable_array_2d)
 230
 231   deallocate (array_3d_1byte_overflow)
 232
 233   deallocate (array_2d_2bytes_overflow)
 234   deallocate (array_2d_1byte_overflow)
 235
 236   if (is_64_bit) then
 237     deallocate (array_1d_4bytes_overflow)
 238   end if
 239   deallocate (array_1d_2bytes_overflow)
 240   deallocate (array_1d_1byte_overflow)
 241
 242   array_1d_p => null ()
 243   array_2d_p => null ()
 244
 245   print *, "" ! Final Breakpoint
 246   print *, an_integer
 247   print *, a_real
 248   print *, associated (array_1d_p)
 249   print *, associated (array_2d_p)
 250   print *, allocated (allocatable_array_1d)
 251   print *, allocated (allocatable_array_2d)
 252
 253 contains
 254   subroutine test_size_1 (answer)
 255     integer*1 :: answer
 256
 257     print *, answer     ! Test Breakpoint 1
 258   end subroutine test_size_1
 259
 260   subroutine test_size_2 (answer)
 261     integer*2 :: answer
 262
 263     print *, answer     ! Test Breakpoint 2
 264   end subroutine test_size_2
 265
 266   subroutine test_size_4 (answer)
 267     integer*4 :: answer
 268
 269     print *, answer     ! Test Breakpoint 3
 270   end subroutine test_size_4
 271
 272   subroutine test_size_8 (answer)
 273     integer*8 :: answer
 274
 275     print *, answer     ! Test Breakpoint 4
 276   end subroutine test_size_8
 277
 278 end program test