1/* Implementation of the FINDLOC intrinsic 2 Copyright (C) 2018-2022 Free Software Foundation, Inc. 3 Contributed by Thomas K��nig <tk@tkoenig.net> 4 5This file is part of the GNU Fortran 95 runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24<http://www.gnu.org/licenses/>. */ 25 26#include "libgfortran.h" 27#include <assert.h> 28 29#if defined (HAVE_GFC_UINTEGER_4) 30extern void findloc1_s4 (gfc_array_index_type * const restrict retarray, 31 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value, 32 const index_type * restrict pdim, GFC_LOGICAL_4 back, 33 gfc_charlen_type len_array, gfc_charlen_type len_value); 34export_proto(findloc1_s4); 35 36extern void 37findloc1_s4 (gfc_array_index_type * const restrict retarray, 38 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value, 39 const index_type * restrict pdim, GFC_LOGICAL_4 back, 40 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[GFC_MAX_DIMENSIONS]; 46 const GFC_UINTEGER_4 * restrict base; 47 index_type * restrict dest; 48 index_type rank; 49 index_type n; 50 index_type len; 51 index_type delta; 52 index_type dim; 53 int continue_loop; 54 55 /* Make dim zero based to avoid confusion. */ 56 rank = GFC_DESCRIPTOR_RANK (array) - 1; 57 dim = (*pdim) - 1; 58 59 if (unlikely (dim < 0 || dim > rank)) 60 { 61 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 62 "is %ld, should be between 1 and %ld", 63 (long int) dim + 1, (long int) rank + 1); 64 } 65 66 len = GFC_DESCRIPTOR_EXTENT(array,dim); 67 if (len < 0) 68 len = 0; 69 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 70 71 for (n = 0; n < dim; n++) 72 { 73 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 74 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 75 76 if (extent[n] < 0) 77 extent[n] = 0; 78 } 79 for (n = dim; n < rank; n++) 80 { 81 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 82 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 83 84 if (extent[n] < 0) 85 extent[n] = 0; 86 } 87 88 if (retarray->base_addr == NULL) 89 { 90 size_t alloc_size, str; 91 92 for (n = 0; n < rank; n++) 93 { 94 if (n == 0) 95 str = 1; 96 else 97 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 98 99 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 100 101 } 102 103 retarray->offset = 0; 104 retarray->dtype.rank = rank; 105 106 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 107 108 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 109 if (alloc_size == 0) 110 { 111 /* Make sure we have a zero-sized array. */ 112 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 113 return; 114 } 115 } 116 else 117 { 118 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 119 runtime_error ("rank of return array incorrect in" 120 " FINDLOC intrinsic: is %ld, should be %ld", 121 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 122 (long int) rank); 123 124 if (unlikely (compile_options.bounds_check)) 125 bounds_ifunction_return ((array_t *) retarray, extent, 126 "return value", "FINDLOC"); 127 } 128 129 for (n = 0; n < rank; n++) 130 { 131 count[n] = 0; 132 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 133 if (extent[n] <= 0) 134 return; 135 } 136 137 dest = retarray->base_addr; 138 continue_loop = 1; 139 140 base = array->base_addr; 141 while (continue_loop) 142 { 143 const GFC_UINTEGER_4 * restrict src; 144 index_type result; 145 146 result = 0; 147 if (back) 148 { 149 src = base + (len - 1) * delta * len_array; 150 for (n = len; n > 0; n--, src -= delta * len_array) 151 { 152 if (compare_string_char4 (len_array, src, len_value, value) == 0) 153 { 154 result = n; 155 break; 156 } 157 } 158 } 159 else 160 { 161 src = base; 162 for (n = 1; n <= len; n++, src += delta * len_array) 163 { 164 if (compare_string_char4 (len_array, src, len_value, value) == 0) 165 { 166 result = n; 167 break; 168 } 169 } 170 } 171 *dest = result; 172 173 count[0]++; 174 base += sstride[0] * len_array; 175 dest += dstride[0]; 176 n = 0; 177 while (count[n] == extent[n]) 178 { 179 count[n] = 0; 180 base -= sstride[n] * extent[n] * len_array; 181 dest -= dstride[n] * extent[n]; 182 n++; 183 if (n >= rank) 184 { 185 continue_loop = 0; 186 break; 187 } 188 else 189 { 190 count[n]++; 191 base += sstride[n] * len_array; 192 dest += dstride[n]; 193 } 194 } 195 } 196} 197extern void mfindloc1_s4 (gfc_array_index_type * const restrict retarray, 198 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value, 199 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 200 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value); 201export_proto(mfindloc1_s4); 202 203extern void 204mfindloc1_s4 (gfc_array_index_type * const restrict retarray, 205 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value, 206 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 207 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value) 208{ 209 index_type count[GFC_MAX_DIMENSIONS]; 210 index_type extent[GFC_MAX_DIMENSIONS]; 211 index_type sstride[GFC_MAX_DIMENSIONS]; 212 index_type mstride[GFC_MAX_DIMENSIONS]; 213 index_type dstride[GFC_MAX_DIMENSIONS]; 214 const GFC_UINTEGER_4 * restrict base; 215 const GFC_LOGICAL_1 * restrict mbase; 216 index_type * restrict dest; 217 index_type rank; 218 index_type n; 219 index_type len; 220 index_type delta; 221 index_type mdelta; 222 index_type dim; 223 int mask_kind; 224 int continue_loop; 225 226 /* Make dim zero based to avoid confusion. */ 227 rank = GFC_DESCRIPTOR_RANK (array) - 1; 228 dim = (*pdim) - 1; 229 230 if (unlikely (dim < 0 || dim > rank)) 231 { 232 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 233 "is %ld, should be between 1 and %ld", 234 (long int) dim + 1, (long int) rank + 1); 235 } 236 237 len = GFC_DESCRIPTOR_EXTENT(array,dim); 238 if (len < 0) 239 len = 0; 240 241 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 242 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); 243 244 mbase = mask->base_addr; 245 246 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 247 248 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 249#ifdef HAVE_GFC_LOGICAL_16 250 || mask_kind == 16 251#endif 252 ) 253 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 254 else 255 internal_error (NULL, "Funny sized logical array"); 256 257 for (n = 0; n < dim; n++) 258 { 259 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 260 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 261 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 262 263 if (extent[n] < 0) 264 extent[n] = 0; 265 } 266 for (n = dim; n < rank; n++) 267 { 268 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 269 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); 270 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 271 272 if (extent[n] < 0) 273 extent[n] = 0; 274 } 275 276 if (retarray->base_addr == NULL) 277 { 278 size_t alloc_size, str; 279 280 for (n = 0; n < rank; n++) 281 { 282 if (n == 0) 283 str = 1; 284 else 285 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 286 287 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 288 289 } 290 291 retarray->offset = 0; 292 retarray->dtype.rank = rank; 293 294 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 295 296 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 297 if (alloc_size == 0) 298 { 299 /* Make sure we have a zero-sized array. */ 300 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 301 return; 302 } 303 } 304 else 305 { 306 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 307 runtime_error ("rank of return array incorrect in" 308 " FINDLOC intrinsic: is %ld, should be %ld", 309 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 310 (long int) rank); 311 312 if (unlikely (compile_options.bounds_check)) 313 bounds_ifunction_return ((array_t *) retarray, extent, 314 "return value", "FINDLOC"); 315 } 316 317 for (n = 0; n < rank; n++) 318 { 319 count[n] = 0; 320 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 321 if (extent[n] <= 0) 322 return; 323 } 324 325 dest = retarray->base_addr; 326 continue_loop = 1; 327 328 base = array->base_addr; 329 while (continue_loop) 330 { 331 const GFC_UINTEGER_4 * restrict src; 332 const GFC_LOGICAL_1 * restrict msrc; 333 index_type result; 334 335 result = 0; 336 if (back) 337 { 338 src = base + (len - 1) * delta * len_array; 339 msrc = mbase + (len - 1) * mdelta; 340 for (n = len; n > 0; n--, src -= delta * len_array, msrc -= mdelta) 341 { 342 if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0) 343 { 344 result = n; 345 break; 346 } 347 } 348 } 349 else 350 { 351 src = base; 352 msrc = mbase; 353 for (n = 1; n <= len; n++, src += delta * len_array, msrc += mdelta) 354 { 355 if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0) 356 { 357 result = n; 358 break; 359 } 360 } 361 } 362 *dest = result; 363 364 count[0]++; 365 base += sstride[0] * len_array; 366 mbase += mstride[0]; 367 dest += dstride[0]; 368 n = 0; 369 while (count[n] == extent[n]) 370 { 371 count[n] = 0; 372 base -= sstride[n] * extent[n] * len_array; 373 mbase -= mstride[n] * extent[n]; 374 dest -= dstride[n] * extent[n]; 375 n++; 376 if (n >= rank) 377 { 378 continue_loop = 0; 379 break; 380 } 381 else 382 { 383 count[n]++; 384 base += sstride[n] * len_array; 385 dest += dstride[n]; 386 } 387 } 388 } 389} 390extern void sfindloc1_s4 (gfc_array_index_type * const restrict retarray, 391 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value, 392 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 393 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value); 394export_proto(sfindloc1_s4); 395 396extern void 397sfindloc1_s4 (gfc_array_index_type * const restrict retarray, 398 gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value, 399 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 400 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value) 401{ 402 index_type count[GFC_MAX_DIMENSIONS]; 403 index_type extent[GFC_MAX_DIMENSIONS]; 404 index_type dstride[GFC_MAX_DIMENSIONS]; 405 index_type * restrict dest; 406 index_type rank; 407 index_type n; 408 index_type len; 409 index_type dim; 410 bool continue_loop; 411 412 if (mask == NULL || *mask) 413 { 414 findloc1_s4 (retarray, array, value, pdim, back, len_array, len_value); 415 return; 416 } 417 /* Make dim zero based to avoid confusion. */ 418 rank = GFC_DESCRIPTOR_RANK (array) - 1; 419 dim = (*pdim) - 1; 420 421 if (unlikely (dim < 0 || dim > rank)) 422 { 423 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 424 "is %ld, should be between 1 and %ld", 425 (long int) dim + 1, (long int) rank + 1); 426 } 427 428 len = GFC_DESCRIPTOR_EXTENT(array,dim); 429 if (len < 0) 430 len = 0; 431 432 for (n = 0; n < dim; n++) 433 { 434 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 435 436 if (extent[n] <= 0) 437 extent[n] = 0; 438 } 439 440 for (n = dim; n < rank; n++) 441 { 442 extent[n] = 443 GFC_DESCRIPTOR_EXTENT(array,n + 1); 444 445 if (extent[n] <= 0) 446 extent[n] = 0; 447 } 448 449 450 if (retarray->base_addr == NULL) 451 { 452 size_t alloc_size, str; 453 454 for (n = 0; n < rank; n++) 455 { 456 if (n == 0) 457 str = 1; 458 else 459 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 460 461 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 462 } 463 464 retarray->offset = 0; 465 retarray->dtype.rank = rank; 466 467 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 468 469 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 470 if (alloc_size == 0) 471 { 472 /* Make sure we have a zero-sized array. */ 473 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 474 return; 475 } 476 } 477 else 478 { 479 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 480 runtime_error ("rank of return array incorrect in" 481 " FINDLOC intrinsic: is %ld, should be %ld", 482 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 483 (long int) rank); 484 485 if (unlikely (compile_options.bounds_check)) 486 bounds_ifunction_return ((array_t *) retarray, extent, 487 "return value", "FINDLOC"); 488 } 489 490 for (n = 0; n < rank; n++) 491 { 492 count[n] = 0; 493 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 494 if (extent[n] <= 0) 495 return; 496 } 497 dest = retarray->base_addr; 498 continue_loop = 1; 499 500 while (continue_loop) 501 { 502 *dest = 0; 503 504 count[0]++; 505 dest += dstride[0]; 506 n = 0; 507 while (count[n] == extent[n]) 508 { 509 count[n] = 0; 510 dest -= dstride[n] * extent[n]; 511 n++; 512 if (n >= rank) 513 { 514 continue_loop = 0; 515 break; 516 } 517 else 518 { 519 count[n]++; 520 dest += dstride[n]; 521 } 522 } 523 } 524} 525#endif 526