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