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 152
Indexes created Sun Mar 01 05:31:48 UTC 2026