gdb/testsuite/gdb.fortran/lbound-ubound.F90

   1 ! Copyright 2021-2022 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 #define DO_TEST(ARRAY)  \
  17   call do_test (lbound (ARRAY), ubound (ARRAY))
  18
  19 subroutine do_test (lb, ub)
  20   integer*4, dimension (:) :: lb
  21   integer*4, dimension (:) :: ub
  22
  23   print *, ""
  24   print *, "Expected GDB Output:"
  25   print *, ""
  26
  27   write(*, fmt="(A)", advance="no") "LBOUND = ("
  28   do i=LBOUND (lb, 1), UBOUND (lb, 1), 1
  29      if (i > LBOUND (lb, 1)) then
  30         write(*, fmt="(A)", advance="no") ", "
  31      end if
  32      write(*, fmt="(I0)", advance="no") lb (i)
  33   end do
  34   write(*, fmt="(A)", advance="yes") ")"
  35
  36   write(*, fmt="(A)", advance="no") "UBOUND = ("
  37   do i=LBOUND (ub, 1), UBOUND (ub, 1), 1
  38      if (i > LBOUND (ub, 1)) then
  39         write(*, fmt="(A)", advance="no") ", "
  40      end if
  41      write(*, fmt="(I0)", advance="no") ub (i)
  42   end do
  43   write(*, fmt="(A)", advance="yes") ")"
  44
  45   print *, ""   ! Test Breakpoint
  46 end subroutine do_test
  47
  48 !
  49 ! Start of test program.
  50 !
  51 program test
  52   use ISO_C_BINDING, only: C_NULL_PTR, C_SIZEOF
  53
  54   interface
  55      subroutine do_test (lb, ub)
  56        integer*4, dimension (:) :: lb
  57        integer*4, dimension (:) :: ub
  58      end subroutine do_test
  59   end interface
  60
  61   ! Declare variables used in this test.
  62   integer, dimension (-8:-1,-10:-2) :: neg_array
  63   integer, dimension (2:10,1:9), target :: array
  64   integer, allocatable :: other (:, :)
  65   character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz"
  66   integer, dimension (-2:2,-3:3,-1:5) :: array3d
  67   integer, dimension (-3:3,7:10,-4:2,-10:-7) :: array4d
  68   integer, dimension (10:20) :: array1d
  69   integer, dimension(:,:), pointer :: pointer2d => null()
  70   integer, dimension(-2:6,-1:9), target :: tarray
  71   integer :: an_int
  72
  73   integer, dimension (:), pointer :: pointer1d => null()
  74
  75   integer, parameter :: b1 = 127 - 10
  76   integer, parameter :: b1_o = 127 + 2
  77   integer, parameter :: b2 = 32767 - 10
  78   integer, parameter :: b2_o = 32767 + 3
  79
  80   ! This tests the GDB overflow behavior when using a KIND parameter too small
  81   ! to hold the actual output argument.  This is done for 1, 2, and 4 byte
  82   ! overflow.  On 32-bit machines most compilers will complain when trying to
  83   ! allocate an array with ranges outside the 4 byte integer range.
  84   ! We take the byte size of a C pointer as indication as to whether or not we
  85   ! are on a 32 bit machine an skip the 4 byte overflow tests in that case.
  86   integer, parameter :: bytes_c_ptr = C_SIZEOF(C_NULL_PTR)
  87
  88   integer*8, parameter :: max_signed_4byte_int = 2147483647
  89   integer*8, parameter :: b4 = max_signed_4byte_int - 10
  90   integer*8 :: b4_o
  91   logical :: is_64_bit
  92
  93   integer, allocatable :: array_1d_1bytes_overflow (:)
  94   integer, allocatable :: array_1d_2bytes_overflow (:)
  95   integer, allocatable :: array_1d_4bytes_overflow (:)
  96   integer, allocatable :: array_2d_1byte_overflow (:,:)
  97   integer, allocatable :: array_2d_2bytes_overflow (:,:)
  98   integer, allocatable :: array_3d_1byte_overflow (:,:,:)
  99
 100   ! Set the 4 byte overflow only on 64 bit machines.
 101   if (bytes_c_ptr < 8) then
 102     b4_o = 0
 103     is_64_bit = .FALSE.
 104   else
 105     b4_o = max_signed_4byte_int + 5
 106     is_64_bit = .TRUE.
 107   end if
 108
 109   ! Allocate or associate any variables as needed.
 110   allocate (other (-5:4, -2:7))
 111   pointer2d => tarray
 112   pointer1d => array (3, 2:5)
 113
 114   allocate (array_1d_1bytes_overflow (-b1_o:-b1))
 115   allocate (array_1d_2bytes_overflow (b2:b2_o))
 116   if (is_64_bit) then
 117     allocate (array_1d_4bytes_overflow (-b4_o:-b4))
 118   end if
 119   allocate (array_2d_1byte_overflow (-b1_o:-b1,b1:b1_o))
 120   allocate (array_2d_2bytes_overflow (b2:b2_o,-b2_o:b2))
 121
 122   allocate (array_3d_1byte_overflow (-b1_o:-b1,b1:b1_o,-b1_o:-b1))
 123
 124   DO_TEST (neg_array)
 125   DO_TEST (neg_array (-7:-3,-5:-4))
 126   DO_TEST (array)
 127   ! The following is disabled due to a bug in gfortran:
 128   !   https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99027
 129   ! gfortran generates the incorrect expected results.
 130   ! DO_TEST (array (3, 2:5))
 131   DO_TEST (pointer1d)
 132   DO_TEST (other)
 133   DO_TEST (array3d)
 134   DO_TEST (array4d)
 135   DO_TEST (array1d)
 136   DO_TEST (pointer2d)
 137   DO_TEST (tarray)
 138
 139   DO_TEST (array_1d_1bytes_overflow)
 140   DO_TEST (array_1d_2bytes_overflow)
 141
 142   if (is_64_bit) then
 143     DO_TEST (array_1d_4bytes_overflow)
 144   end if
 145   DO_TEST (array_2d_1byte_overflow)
 146   DO_TEST (array_2d_2bytes_overflow)
 147   DO_TEST (array_3d_1byte_overflow)
 148
 149   ! All done.  Deallocate.
 150   print *, "" ! Breakpoint before deallocate.
 151   deallocate (other)
 152
 153   deallocate (array_3d_1byte_overflow)
 154
 155   deallocate (array_2d_2bytes_overflow)
 156   deallocate (array_2d_1byte_overflow)
 157
 158   if (is_64_bit) then
 159     deallocate (array_1d_4bytes_overflow)
 160   end if
 161   deallocate (array_1d_2bytes_overflow)
 162   deallocate (array_1d_1bytes_overflow)
 163
 164   ! GDB catches this final breakpoint to indicate the end of the test.
 165   print *, "" ! Final Breakpoint.
 166
 167   ! Reference otherwise unused locals in order to keep them around.
 168   ! GDB will make use of these for some tests.
 169   print *, str_1
 170   an_int = 1
 171   print *, an_int
 172
 173 end program test