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

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