1 2 /* Implementation of the FINDLOC intrinsic 3 Copyright (C) 2018-2022 Free Software Foundation, Inc. 4 Contributed by Thomas König <tk@tkoenig.net> 5 6 This file is part of the GNU Fortran 95 runtime library (libgfortran). 7 8 Libgfortran is free software; you can redistribute it and/or 9 modify it under the terms of the GNU General Public 10 License as published by the Free Software Foundation; either 11 version 3 of the License, or (at your option) any later version. 12 13 Libgfortran is distributed in the hope that it will be useful, 14 but WITHOUT ANY WARRANTY; without even the implied warranty of 15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 GNU General Public License for more details. 17 18 Under Section 7 of GPL version 3, you are granted additional 19 permissions described in the GCC Runtime Library Exception, version 20 3.1, as published by the Free Software Foundation. 21 22 You should have received a copy of the GNU General Public License and 23 a copy of the GCC Runtime Library Exception along with this program; 24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 25 <http://www.gnu.org/licenses/>. */ 26 27 #include "libgfortran.h" 28 #include <assert.h> 29 30 #if defined (HAVE_GFC_UINTEGER_1) 31 extern void findloc0_s1 (gfc_array_index_type * const restrict retarray, 32 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value, 33 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value); 34 35 export_proto(findloc0_s1); 36 37 void 38 findloc0_s1 (gfc_array_index_type * const restrict retarray, 39 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value, 40 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value) 41 { 42 index_type count[GFC_MAX_DIMENSIONS]; 43 index_type extent[GFC_MAX_DIMENSIONS]; 44 index_type sstride[GFC_MAX_DIMENSIONS]; 45 index_type dstride; 46 const GFC_UINTEGER_1 *base; 47 index_type * restrict dest; 48 index_type rank; 49 index_type n; 50 index_type sz; 51 52 rank = GFC_DESCRIPTOR_RANK (array); 53 if (rank <= 0) 54 runtime_error ("Rank of array needs to be > 0"); 55 56 if (retarray->base_addr == NULL) 57 { 58 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 59 retarray->dtype.rank = 1; 60 retarray->offset = 0; 61 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 62 } 63 else 64 { 65 if (unlikely (compile_options.bounds_check)) 66 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 67 "FINDLOC"); 68 } 69 70 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 71 dest = retarray->base_addr; 72 73 /* Set the return value. */ 74 for (n = 0; n < rank; n++) 75 dest[n * dstride] = 0; 76 77 sz = 1; 78 for (n = 0; n < rank; n++) 79 { 80 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 81 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 82 sz *= extent[n]; 83 if (extent[n] <= 0) 84 return; 85 } 86 87 for (n = 0; n < rank; n++) 88 count[n] = 0; 89 90 if (back) 91 { 92 base = array->base_addr + (sz - 1) * len_array; 93 94 while (1) 95 { 96 do 97 { 98 if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0)) 99 { 100 for (n = 0; n < rank; n++) 101 dest[n * dstride] = extent[n] - count[n]; 102 103 return; 104 } 105 base -= sstride[0] * len_array; 106 } while(++count[0] != extent[0]); 107 108 n = 0; 109 do 110 { 111 /* When we get to the end of a dimension, reset it and increment 112 the next dimension. */ 113 count[n] = 0; 114 /* We could precalculate these products, but this is a less 115 frequently used path so probably not worth it. */ 116 base += sstride[n] * extent[n] * len_array; 117 n++; 118 if (n >= rank) 119 return; 120 else 121 { 122 count[n]++; 123 base -= sstride[n] * len_array; 124 } 125 } while (count[n] == extent[n]); 126 } 127 } 128 else 129 { 130 base = array->base_addr; 131 while (1) 132 { 133 do 134 { 135 if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0)) 136 { 137 for (n = 0; n < rank; n++) 138 dest[n * dstride] = count[n] + 1; 139 140 return; 141 } 142 base += sstride[0] * len_array; 143 } while(++count[0] != extent[0]); 144 145 n = 0; 146 do 147 { 148 /* When we get to the end of a dimension, reset it and increment 149 the next dimension. */ 150 count[n] = 0; 151 /* We could precalculate these products, but this is a less 152 frequently used path so probably not worth it. */ 153 base -= sstride[n] * extent[n] * len_array; 154 n++; 155 if (n >= rank) 156 return; 157 else 158 { 159 count[n]++; 160 base += sstride[n] * len_array; 161 } 162 } while (count[n] == extent[n]); 163 } 164 } 165 return; 166 } 167 168 extern void mfindloc0_s1 (gfc_array_index_type * const restrict retarray, 169 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value, 170 gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array, 171 gfc_charlen_type len_value); 172 export_proto(mfindloc0_s1); 173 174 void 175 mfindloc0_s1 (gfc_array_index_type * const restrict retarray, 176 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value, 177 gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back, 178 gfc_charlen_type len_array, gfc_charlen_type len_value) 179 { 180 index_type count[GFC_MAX_DIMENSIONS]; 181 index_type extent[GFC_MAX_DIMENSIONS]; 182 index_type sstride[GFC_MAX_DIMENSIONS]; 183 index_type mstride[GFC_MAX_DIMENSIONS]; 184 index_type dstride; 185 const GFC_UINTEGER_1 *base; 186 index_type * restrict dest; 187 GFC_LOGICAL_1 *mbase; 188 index_type rank; 189 index_type n; 190 int mask_kind; 191 index_type sz; 192 193 rank = GFC_DESCRIPTOR_RANK (array); 194 if (rank <= 0) 195 runtime_error ("Rank of array needs to be > 0"); 196 197 if (retarray->base_addr == NULL) 198 { 199 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 200 retarray->dtype.rank = 1; 201 retarray->offset = 0; 202 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 203 } 204 else 205 { 206 if (unlikely (compile_options.bounds_check)) 207 { 208 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 209 "FINDLOC"); 210 bounds_equal_extents ((array_t *) mask, (array_t *) array, 211 "MASK argument", "FINDLOC"); 212 } 213 } 214 215 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 216 217 mbase = mask->base_addr; 218 219 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 220 #ifdef HAVE_GFC_LOGICAL_16 221 || mask_kind == 16 222 #endif 223 ) 224 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 225 else 226 internal_error (NULL, "Funny sized logical array"); 227 228 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 229 dest = retarray->base_addr; 230 231 /* Set the return value. */ 232 for (n = 0; n < rank; n++) 233 dest[n * dstride] = 0; 234 235 sz = 1; 236 for (n = 0; n < rank; n++) 237 { 238 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 239 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 240 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 241 sz *= extent[n]; 242 if (extent[n] <= 0) 243 return; 244 } 245 246 for (n = 0; n < rank; n++) 247 count[n] = 0; 248 249 if (back) 250 { 251 base = array->base_addr + (sz - 1) * len_array; 252 mbase = mbase + (sz - 1) * mask_kind; 253 while (1) 254 { 255 do 256 { 257 if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0)) 258 { 259 for (n = 0; n < rank; n++) 260 dest[n * dstride] = extent[n] - count[n]; 261 262 return; 263 } 264 base -= sstride[0] * len_array; 265 mbase -= mstride[0]; 266 } while(++count[0] != extent[0]); 267 268 n = 0; 269 do 270 { 271 /* When we get to the end of a dimension, reset it and increment 272 the next dimension. */ 273 count[n] = 0; 274 /* We could precalculate these products, but this is a less 275 frequently used path so probably not worth it. */ 276 base += sstride[n] * extent[n] * len_array; 277 mbase -= mstride[n] * extent[n]; 278 n++; 279 if (n >= rank) 280 return; 281 else 282 { 283 count[n]++; 284 base -= sstride[n] * len_array; 285 mbase += mstride[n]; 286 } 287 } while (count[n] == extent[n]); 288 } 289 } 290 else 291 { 292 base = array->base_addr; 293 while (1) 294 { 295 do 296 { 297 if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0)) 298 { 299 for (n = 0; n < rank; n++) 300 dest[n * dstride] = count[n] + 1; 301 302 return; 303 } 304 base += sstride[0] * len_array; 305 mbase += mstride[0]; 306 } while(++count[0] != extent[0]); 307 308 n = 0; 309 do 310 { 311 /* When we get to the end of a dimension, reset it and increment 312 the next dimension. */ 313 count[n] = 0; 314 /* We could precalculate these products, but this is a less 315 frequently used path so probably not worth it. */ 316 base -= sstride[n] * extent[n] * len_array; 317 mbase -= mstride[n] * extent[n]; 318 n++; 319 if (n >= rank) 320 return; 321 else 322 { 323 count[n]++; 324 base += sstride[n]* len_array; 325 mbase += mstride[n]; 326 } 327 } while (count[n] == extent[n]); 328 } 329 } 330 return; 331 } 332 333 extern void sfindloc0_s1 (gfc_array_index_type * const restrict retarray, 334 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value, 335 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array, 336 gfc_charlen_type len_value); 337 export_proto(sfindloc0_s1); 338 339 void 340 sfindloc0_s1 (gfc_array_index_type * const restrict retarray, 341 gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value, 342 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array, 343 gfc_charlen_type len_value) 344 { 345 index_type rank; 346 index_type dstride; 347 index_type * restrict dest; 348 index_type n; 349 350 if (mask == NULL || *mask) 351 { 352 findloc0_s1 (retarray, array, value, back, len_array, len_value); 353 return; 354 } 355 356 rank = GFC_DESCRIPTOR_RANK (array); 357 358 if (rank <= 0) 359 internal_error (NULL, "Rank of array needs to be > 0"); 360 361 if (retarray->base_addr == NULL) 362 { 363 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 364 retarray->dtype.rank = 1; 365 retarray->offset = 0; 366 retarray->base_addr = xmallocarray (rank, sizeof (index_type)); 367 } 368 else if (unlikely (compile_options.bounds_check)) 369 { 370 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 371 "FINDLOC"); 372 } 373 374 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 375 dest = retarray->base_addr; 376 for (n = 0; n<rank; n++) 377 dest[n * dstride] = 0 ; 378 } 379 380 #endif 381 382 383 384