1/* Implementation of the MAXLOC intrinsic 2 Copyright (C) 2017-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig 4 5This file is part of the GNU Fortran 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 28 29#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16) 30 31#define HAVE_BACK_ARG 1 32 33#include <string.h> 34#include <assert.h> 35 36static inline int 37compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n) 38{ 39 if (sizeof (GFC_UINTEGER_4) == 1) 40 return memcmp (a, b, n); 41 else 42 return memcmp_char4 (a, b, n); 43} 44 45extern void maxloc1_16_s4 (gfc_array_i16 * const restrict, 46 gfc_array_s4 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back, 47 gfc_charlen_type); 48export_proto(maxloc1_16_s4); 49 50void 51maxloc1_16_s4 (gfc_array_i16 * const restrict retarray, 52 gfc_array_s4 * const restrict array, 53 const index_type * const restrict pdim, GFC_LOGICAL_4 back, 54 gfc_charlen_type string_len) 55{ 56 index_type count[GFC_MAX_DIMENSIONS]; 57 index_type extent[GFC_MAX_DIMENSIONS]; 58 index_type sstride[GFC_MAX_DIMENSIONS]; 59 index_type dstride[GFC_MAX_DIMENSIONS]; 60 const GFC_UINTEGER_4 * restrict base; 61 GFC_INTEGER_16 * restrict dest; 62 index_type rank; 63 index_type n; 64 index_type len; 65 index_type delta; 66 index_type dim; 67 int continue_loop; 68 69 /* Make dim zero based to avoid confusion. */ 70 rank = GFC_DESCRIPTOR_RANK (array) - 1; 71 dim = (*pdim) - 1; 72 73 if (unlikely (dim < 0 || dim > rank)) 74 { 75 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " 76 "is %ld, should be between 1 and %ld", 77 (long int) dim + 1, (long int) rank + 1); 78 } 79 80 len = GFC_DESCRIPTOR_EXTENT(array,dim); 81 if (len < 0) 82 len = 0; 83 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; 84 85 for (n = 0; n < dim; n++) 86 { 87 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; 88 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 89 90 if (extent[n] < 0) 91 extent[n] = 0; 92 } 93 for (n = dim; n < rank; n++) 94 { 95 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; 96 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 97 98 if (extent[n] < 0) 99 extent[n] = 0; 100 } 101 102 if (retarray->base_addr == NULL) 103 { 104 size_t alloc_size, str; 105 106 for (n = 0; n < rank; n++) 107 { 108 if (n == 0) 109 str = 1; 110 else 111 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 112 113 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 114 115 } 116 117 retarray->offset = 0; 118 retarray->dtype.rank = rank; 119 120 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 121 122 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); 123 if (alloc_size == 0) 124 { 125 /* Make sure we have a zero-sized array. */ 126 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 127 return; 128 129 } 130 } 131 else 132 { 133 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 134 runtime_error ("rank of return array incorrect in" 135 " MAXLOC intrinsic: is %ld, should be %ld", 136 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 137 (long int) rank); 138 139 if (unlikely (compile_options.bounds_check)) 140 bounds_ifunction_return ((array_t *) retarray, extent, 141 "return value", "MAXLOC"); 142 } 143 144 for (n = 0; n < rank; n++) 145 { 146 count[n] = 0; 147 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 148 if (extent[n] <= 0) 149 return; 150 } 151 152 base = array->base_addr; 153 dest = retarray->base_addr; 154 155 continue_loop = 1; 156 while (continue_loop) 157 { 158 const GFC_UINTEGER_4 * restrict src; 159 GFC_INTEGER_16 result; 160 src = base; 161 { 162 163 const GFC_UINTEGER_4 *maxval; 164 maxval = NULL; 165 result = 0; 166 if (len <= 0) 167 *dest = 0; 168 else 169 { 170 for (n = 0; n < len; n++, src += delta) 171 { 172 173 if (maxval == NULL || (back ? compare_fcn (src, maxval, string_len) >= 0 : 174 compare_fcn (src, maxval, string_len) > 0)) 175 { 176 maxval = src; 177 result = (GFC_INTEGER_16)n + 1; 178 } 179 } 180 181 *dest = result; 182 } 183 } 184 /* Advance to the next element. */ 185 count[0]++; 186 base += sstride[0]; 187 dest += dstride[0]; 188 n = 0; 189 while (count[n] == extent[n]) 190 { 191 /* When we get to the end of a dimension, reset it and increment 192 the next dimension. */ 193 count[n] = 0; 194 /* We could precalculate these products, but this is a less 195 frequently used path so probably not worth it. */ 196 base -= sstride[n] * extent[n]; 197 dest -= dstride[n] * extent[n]; 198 n++; 199 if (n >= rank) 200 { 201 /* Break out of the loop. */ 202 continue_loop = 0; 203 break; 204 } 205 else 206 { 207 count[n]++; 208 base += sstride[n]; 209 dest += dstride[n]; 210 } 211 } 212 } 213} 214 215 216extern void mmaxloc1_16_s4 (gfc_array_i16 * const restrict, 217 gfc_array_s4 * const restrict, const index_type * const restrict, 218 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type); 219export_proto(mmaxloc1_16_s4); 220 221void 222mmaxloc1_16_s4 (gfc_array_i16 * const restrict retarray, 223 gfc_array_s4 * const restrict array, 224 const index_type * const restrict pdim, 225 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back, 226 gfc_charlen_type string_len) 227{ 228 index_type count[GFC_MAX_DIMENSIONS]; 229 index_type extent[GFC_MAX_DIMENSIONS]; 230 index_type sstride[GFC_MAX_DIMENSIONS]; 231 index_type dstride[GFC_MAX_DIMENSIONS]; 232 index_type mstride[GFC_MAX_DIMENSIONS]; 233 GFC_INTEGER_16 * restrict dest; 234 const GFC_UINTEGER_4 * restrict base; 235 const GFC_LOGICAL_1 * restrict mbase; 236 index_type rank; 237 index_type dim; 238 index_type n; 239 index_type len; 240 index_type delta; 241 index_type mdelta; 242 int mask_kind; 243 244 if (mask == NULL) 245 { 246#ifdef HAVE_BACK_ARG 247 maxloc1_16_s4 (retarray, array, pdim, back, string_len); 248#else 249 maxloc1_16_s4 (retarray, array, pdim, string_len); 250#endif 251 return; 252 } 253 254 dim = (*pdim) - 1; 255 rank = GFC_DESCRIPTOR_RANK (array) - 1; 256 257 258 if (unlikely (dim < 0 || dim > rank)) 259 { 260 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " 261 "is %ld, should be between 1 and %ld", 262 (long int) dim + 1, (long int) rank + 1); 263 } 264 265 len = GFC_DESCRIPTOR_EXTENT(array,dim); 266 if (len <= 0) 267 return; 268 269 mbase = mask->base_addr; 270 271 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 272 273 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 274#ifdef HAVE_GFC_LOGICAL_16 275 || mask_kind == 16 276#endif 277 ) 278 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 279 else 280 runtime_error ("Funny sized logical array"); 281 282 delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; 283 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); 284 285 for (n = 0; n < dim; n++) 286 { 287 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; 288 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 289 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 290 291 if (extent[n] < 0) 292 extent[n] = 0; 293 294 } 295 for (n = dim; n < rank; n++) 296 { 297 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; 298 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); 299 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 300 301 if (extent[n] < 0) 302 extent[n] = 0; 303 } 304 305 if (retarray->base_addr == NULL) 306 { 307 size_t alloc_size, str; 308 309 for (n = 0; n < rank; n++) 310 { 311 if (n == 0) 312 str = 1; 313 else 314 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 315 316 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 317 318 } 319 320 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 321 322 retarray->offset = 0; 323 retarray->dtype.rank = rank; 324 325 if (alloc_size == 0) 326 { 327 /* Make sure we have a zero-sized array. */ 328 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 329 return; 330 } 331 else 332 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); 333 334 } 335 else 336 { 337 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 338 runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); 339 340 if (unlikely (compile_options.bounds_check)) 341 { 342 bounds_ifunction_return ((array_t *) retarray, extent, 343 "return value", "MAXLOC"); 344 bounds_equal_extents ((array_t *) mask, (array_t *) array, 345 "MASK argument", "MAXLOC"); 346 } 347 } 348 349 for (n = 0; n < rank; n++) 350 { 351 count[n] = 0; 352 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 353 if (extent[n] <= 0) 354 return; 355 } 356 357 dest = retarray->base_addr; 358 base = array->base_addr; 359 360 while (base) 361 { 362 const GFC_UINTEGER_4 * restrict src; 363 const GFC_LOGICAL_1 * restrict msrc; 364 GFC_INTEGER_16 result; 365 src = base; 366 msrc = mbase; 367 { 368 369 const GFC_UINTEGER_4 *maxval; 370 maxval = base; 371 result = 0; 372 for (n = 0; n < len; n++, src += delta, msrc += mdelta) 373 { 374 375 if (*msrc) 376 { 377 maxval = src; 378 result = (GFC_INTEGER_16)n + 1; 379 break; 380 } 381 } 382 for (; n < len; n++, src += delta, msrc += mdelta) 383 { 384 if (*msrc && (back ? compare_fcn (src, maxval, string_len) >= 0 : 385 compare_fcn (src, maxval, string_len) > 0)) 386 { 387 maxval = src; 388 result = (GFC_INTEGER_16)n + 1; 389 } 390 391 } 392 *dest = result; 393 } 394 /* Advance to the next element. */ 395 count[0]++; 396 base += sstride[0]; 397 mbase += mstride[0]; 398 dest += dstride[0]; 399 n = 0; 400 while (count[n] == extent[n]) 401 { 402 /* When we get to the end of a dimension, reset it and increment 403 the next dimension. */ 404 count[n] = 0; 405 /* We could precalculate these products, but this is a less 406 frequently used path so probably not worth it. */ 407 base -= sstride[n] * extent[n]; 408 mbase -= mstride[n] * extent[n]; 409 dest -= dstride[n] * extent[n]; 410 n++; 411 if (n >= rank) 412 { 413 /* Break out of the loop. */ 414 base = NULL; 415 break; 416 } 417 else 418 { 419 count[n]++; 420 base += sstride[n]; 421 mbase += mstride[n]; 422 dest += dstride[n]; 423 } 424 } 425 } 426} 427 428 429extern void smaxloc1_16_s4 (gfc_array_i16 * const restrict, 430 gfc_array_s4 * const restrict, const index_type * const restrict, 431 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type); 432export_proto(smaxloc1_16_s4); 433 434void 435smaxloc1_16_s4 (gfc_array_i16 * const restrict retarray, 436 gfc_array_s4 * const restrict array, 437 const index_type * const restrict pdim, 438 GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len) 439{ 440 index_type count[GFC_MAX_DIMENSIONS]; 441 index_type extent[GFC_MAX_DIMENSIONS]; 442 index_type dstride[GFC_MAX_DIMENSIONS]; 443 GFC_INTEGER_16 * restrict dest; 444 index_type rank; 445 index_type n; 446 index_type dim; 447 448 449 if (mask == NULL || *mask) 450 { 451#ifdef HAVE_BACK_ARG 452 maxloc1_16_s4 (retarray, array, pdim, back, string_len); 453#else 454 maxloc1_16_s4 (retarray, array, pdim, string_len); 455#endif 456 return; 457 } 458 /* Make dim zero based to avoid confusion. */ 459 dim = (*pdim) - 1; 460 rank = GFC_DESCRIPTOR_RANK (array) - 1; 461 462 if (unlikely (dim < 0 || dim > rank)) 463 { 464 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " 465 "is %ld, should be between 1 and %ld", 466 (long int) dim + 1, (long int) rank + 1); 467 } 468 469 for (n = 0; n < dim; n++) 470 { 471 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len; 472 473 if (extent[n] <= 0) 474 extent[n] = 0; 475 } 476 477 for (n = dim; n < rank; n++) 478 { 479 extent[n] = 480 GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len; 481 482 if (extent[n] <= 0) 483 extent[n] = 0; 484 } 485 486 if (retarray->base_addr == NULL) 487 { 488 size_t alloc_size, str; 489 490 for (n = 0; n < rank; n++) 491 { 492 if (n == 0) 493 str = 1; 494 else 495 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 496 497 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 498 499 } 500 501 retarray->offset = 0; 502 retarray->dtype.rank = rank; 503 504 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 505 506 if (alloc_size == 0) 507 { 508 /* Make sure we have a zero-sized array. */ 509 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 510 return; 511 } 512 else 513 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); 514 } 515 else 516 { 517 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 518 runtime_error ("rank of return array incorrect in" 519 " MAXLOC intrinsic: is %ld, should be %ld", 520 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 521 (long int) rank); 522 523 if (unlikely (compile_options.bounds_check)) 524 { 525 for (n=0; n < rank; n++) 526 { 527 index_type ret_extent; 528 529 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 530 if (extent[n] != ret_extent) 531 runtime_error ("Incorrect extent in return value of" 532 " MAXLOC intrinsic in dimension %ld:" 533 " is %ld, should be %ld", (long int) n + 1, 534 (long int) ret_extent, (long int) extent[n]); 535 } 536 } 537 } 538 539 for (n = 0; n < rank; n++) 540 { 541 count[n] = 0; 542 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 543 } 544 545 dest = retarray->base_addr; 546 547 while(1) 548 { 549 *dest = 0; 550 count[0]++; 551 dest += dstride[0]; 552 n = 0; 553 while (count[n] == extent[n]) 554 { 555 /* When we get to the end of a dimension, reset it and increment 556 the next dimension. */ 557 count[n] = 0; 558 /* We could precalculate these products, but this is a less 559 frequently used path so probably not worth it. */ 560 dest -= dstride[n] * extent[n]; 561 n++; 562 if (n >= rank) 563 return; 564 else 565 { 566 count[n]++; 567 dest += dstride[n]; 568 } 569 } 570 } 571} 572 573#endif 574