1 /* Implementation of the MAXLOC intrinsic 2 Copyright (C) 2017-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig 4 5 This file is part of the GNU Fortran runtime library (libgfortran). 6 7 Libgfortran is free software; you can redistribute it and/or 8 modify it under the terms of the GNU General Public 9 License as published by the Free Software Foundation; either 10 version 3 of the License, or (at your option) any later version. 11 12 Libgfortran is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 Under Section 7 of GPL version 3, you are granted additional 18 permissions described in the GCC Runtime Library Exception, version 19 3.1, as published by the Free Software Foundation. 20 21 You should have received a copy of the GNU General Public License and 22 a copy of the GCC Runtime Library Exception along with this program; 23 see 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 36 static inline int 37 compare_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 45 extern 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); 48 export_proto(maxloc1_16_s4); 49 50 void 51 maxloc1_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 216 extern 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); 219 export_proto(mmaxloc1_16_s4); 220 221 void 222 mmaxloc1_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 429 extern 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); 432 export_proto(smaxloc1_16_s4); 433 434 void 435 smaxloc1_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); 472 473 if (extent[n] <= 0) 474 extent[n] = 0; 475 } 476 477 for (n = dim; n < rank; n++) 478 { 479 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); 480 481 if (extent[n] <= 0) 482 extent[n] = 0; 483 } 484 485 if (retarray->base_addr == NULL) 486 { 487 size_t alloc_size, str; 488 489 for (n = 0; n < rank; n++) 490 { 491 if (n == 0) 492 str = 1; 493 else 494 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 495 496 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 497 498 } 499 500 retarray->offset = 0; 501 retarray->dtype.rank = rank; 502 503 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 504 505 if (alloc_size == 0) 506 { 507 /* Make sure we have a zero-sized array. */ 508 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 509 return; 510 } 511 else 512 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); 513 } 514 else 515 { 516 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 517 runtime_error ("rank of return array incorrect in" 518 " MAXLOC intrinsic: is %ld, should be %ld", 519 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 520 (long int) rank); 521 522 if (unlikely (compile_options.bounds_check)) 523 { 524 for (n=0; n < rank; n++) 525 { 526 index_type ret_extent; 527 528 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 529 if (extent[n] != ret_extent) 530 runtime_error ("Incorrect extent in return value of" 531 " MAXLOC intrinsic in dimension %ld:" 532 " is %ld, should be %ld", (long int) n + 1, 533 (long int) ret_extent, (long int) extent[n]); 534 } 535 } 536 } 537 538 for (n = 0; n < rank; n++) 539 { 540 count[n] = 0; 541 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 542 } 543 544 dest = retarray->base_addr; 545 546 while(1) 547 { 548 *dest = 0; 549 count[0]++; 550 dest += dstride[0]; 551 n = 0; 552 while (count[n] == extent[n]) 553 { 554 /* When we get to the end of a dimension, reset it and increment 555 the next dimension. */ 556 count[n] = 0; 557 /* We could precalculate these products, but this is a less 558 frequently used path so probably not worth it. */ 559 dest -= dstride[n] * extent[n]; 560 n++; 561 if (n >= rank) 562 return; 563 else 564 { 565 count[n]++; 566 dest += dstride[n]; 567 } 568 } 569 } 570 } 571 572 #endif 573
Indexes created Mon Mar 02 05:31:46 UTC 2026