1 /* Copyright (C) 2009-2019 Free Software Foundation, Inc. 2 Contributed by Thomas Koenig 3 4 This file is part of the GNU Fortran runtime library (libgfortran). 5 6 Libgfortran is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 3, or (at your option) 9 any later version. 10 11 Libgfortran is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 Under Section 7 of GPL version 3, you are granted additional 17 permissions described in the GCC Runtime Library Exception, version 18 3.1, as published by the Free Software Foundation. 19 20 You should have received a copy of the GNU General Public License and 21 a copy of the GCC Runtime Library Exception along with this program; 22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 23 <http://www.gnu.org/licenses/>. */ 24 25 #include "libgfortran.h" 26 #include <assert.h> 27 28 /* Auxiliary functions for bounds checking, mostly to reduce library size. */ 29 30 /* Bounds checking for the return values of the iforeach functions (such 31 as maxloc and minloc). The extent of ret_array must 32 must match the rank of array. */ 33 34 void 35 bounds_iforeach_return (array_t *retarray, array_t *array, const char *name) 36 { 37 index_type rank; 38 index_type ret_rank; 39 index_type ret_extent; 40 41 ret_rank = GFC_DESCRIPTOR_RANK (retarray); 42 43 /* ret_rank should always be 1, otherwise there is an internal error */ 44 GFC_ASSERT(ret_rank == 1); 45 46 rank = GFC_DESCRIPTOR_RANK (array); 47 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); 48 if (ret_extent != rank) 49 runtime_error ("Incorrect extent in return value of" 50 " %s intrinsic: is %ld, should be %ld", 51 name, (long int) ret_extent, (long int) rank); 52 53 } 54 55 /* Check the return of functions generated from ifunction.m4. 56 We check the array descriptor "a" against the extents precomputed 57 from ifunction.m4, and complain about the argument a_name in the 58 intrinsic function. */ 59 60 void 61 bounds_ifunction_return (array_t * a, const index_type * extent, 62 const char * a_name, const char * intrinsic) 63 { 64 int empty; 65 int rank; 66 index_type a_size; 67 68 rank = GFC_DESCRIPTOR_RANK (a); 69 a_size = size0 (a); 70 71 empty = 0; 72 for (index_type n = 0; n < rank; n++) 73 { 74 if (extent[n] == 0) 75 empty = 1; 76 } 77 if (empty) 78 { 79 if (a_size != 0) 80 runtime_error ("Incorrect size in %s of %s" 81 " intrinsic: should be zero-sized", 82 a_name, intrinsic); 83 } 84 else 85 { 86 if (a_size == 0) 87 runtime_error ("Incorrect size of %s in %s" 88 " intrinsic: should not be zero-sized", 89 a_name, intrinsic); 90 91 for (index_type n = 0; n < rank; n++) 92 { 93 index_type a_extent; 94 a_extent = GFC_DESCRIPTOR_EXTENT(a, n); 95 if (a_extent != extent[n]) 96 runtime_error("Incorrect extent in %s of %s" 97 " intrinsic in dimension %ld: is %ld," 98 " should be %ld", a_name, intrinsic, (long int) n + 1, 99 (long int) a_extent, (long int) extent[n]); 100 101 } 102 } 103 } 104 105 /* Check that two arrays have equal extents, or are both zero-sized. Abort 106 with a runtime error if this is not the case. Complain that a has the 107 wrong size. */ 108 109 void 110 bounds_equal_extents (array_t *a, array_t *b, const char *a_name, 111 const char *intrinsic) 112 { 113 index_type a_size, b_size, n; 114 115 assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b)); 116 117 a_size = size0 (a); 118 b_size = size0 (b); 119 120 if (b_size == 0) 121 { 122 if (a_size != 0) 123 runtime_error ("Incorrect size of %s in %s" 124 " intrinsic: should be zero-sized", 125 a_name, intrinsic); 126 } 127 else 128 { 129 if (a_size == 0) 130 runtime_error ("Incorrect size of %s of %s" 131 " intrinsic: Should not be zero-sized", 132 a_name, intrinsic); 133 134 for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++) 135 { 136 index_type a_extent, b_extent; 137 138 a_extent = GFC_DESCRIPTOR_EXTENT(a, n); 139 b_extent = GFC_DESCRIPTOR_EXTENT(b, n); 140 if (a_extent != b_extent) 141 runtime_error("Incorrect extent in %s of %s" 142 " intrinsic in dimension %ld: is %ld," 143 " should be %ld", a_name, intrinsic, (long int) n + 1, 144 (long int) a_extent, (long int) b_extent); 145 } 146 } 147 } 148 149 /* Check that the extents of a and b agree, except that a has a missing 150 dimension in argument which. Complain about a if anything is wrong. */ 151 152 void 153 bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name, 154 const char *intrinsic) 155 { 156 157 index_type i, n, a_size, b_size; 158 159 assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1); 160 161 a_size = size0 (a); 162 b_size = size0 (b); 163 164 if (b_size == 0) 165 { 166 if (a_size != 0) 167 runtime_error ("Incorrect size in %s of %s" 168 " intrinsic: should not be zero-sized", 169 a_name, intrinsic); 170 } 171 else 172 { 173 if (a_size == 0) 174 runtime_error ("Incorrect size of %s of %s" 175 " intrinsic: should be zero-sized", 176 a_name, intrinsic); 177 178 i = 0; 179 for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++) 180 { 181 index_type a_extent, b_extent; 182 183 if (n != which) 184 { 185 a_extent = GFC_DESCRIPTOR_EXTENT(a, i); 186 b_extent = GFC_DESCRIPTOR_EXTENT(b, n); 187 if (a_extent != b_extent) 188 runtime_error("Incorrect extent in %s of %s" 189 " intrinsic in dimension %ld: is %ld," 190 " should be %ld", a_name, intrinsic, (long int) i + 1, 191 (long int) a_extent, (long int) b_extent); 192 i++; 193 } 194 } 195 } 196 } 197 198 /* count_0 - count all the true elements in an array. The front 199 end usually inlines this, we need this for bounds checking 200 for unpack. */ 201 202 index_type count_0 (const gfc_array_l1 * array) 203 { 204 const GFC_LOGICAL_1 * restrict base; 205 index_type rank; 206 int kind; 207 int continue_loop; 208 index_type count[GFC_MAX_DIMENSIONS]; 209 index_type extent[GFC_MAX_DIMENSIONS]; 210 index_type sstride[GFC_MAX_DIMENSIONS]; 211 index_type result; 212 index_type n; 213 214 rank = GFC_DESCRIPTOR_RANK (array); 215 kind = GFC_DESCRIPTOR_SIZE (array); 216 217 base = array->base_addr; 218 219 if (kind == 1 || kind == 2 || kind == 4 || kind == 8 220 #ifdef HAVE_GFC_LOGICAL_16 221 || kind == 16 222 #endif 223 ) 224 { 225 if (base) 226 base = GFOR_POINTER_TO_L1 (base, kind); 227 } 228 else 229 internal_error (NULL, "Funny sized logical array in count_0"); 230 231 for (n = 0; n < rank; n++) 232 { 233 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); 234 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 235 count[n] = 0; 236 237 if (extent[n] <= 0) 238 return 0; 239 } 240 241 result = 0; 242 continue_loop = 1; 243 while (continue_loop) 244 { 245 if (*base) 246 result ++; 247 248 count[0]++; 249 base += sstride[0]; 250 n = 0; 251 while (count[n] == extent[n]) 252 { 253 count[n] = 0; 254 base -= sstride[n] * extent[n]; 255 n++; 256 if (n == rank) 257 { 258 continue_loop = 0; 259 break; 260 } 261 else 262 { 263 count[n]++; 264 base += sstride[n]; 265 } 266 } 267 } 268 return result; 269 } 270