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