1/* Copyright (C) 2009-2020 Free Software Foundation, Inc. 2 Contributed by Thomas Koenig 3 4This file is part of the GNU Fortran runtime library (libgfortran). 5 6Libgfortran is free software; you can redistribute it and/or modify 7it under the terms of the GNU General Public License as published by 8the Free Software Foundation; either version 3, or (at your option) 9any later version. 10 11Libgfortran is distributed in the hope that it will be useful, 12but WITHOUT ANY WARRANTY; without even the implied warranty of 13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14GNU General Public License for more details. 15 16Under Section 7 of GPL version 3, you are granted additional 17permissions described in the GCC Runtime Library Exception, version 183.1, as published by the Free Software Foundation. 19 20You should have received a copy of the GNU General Public License and 21a copy of the GCC Runtime Library Exception along with this program; 22see 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 34void 35bounds_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 60void 61bounds_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 109void 110bounds_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 152void 153bounds_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 202index_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