1 /* Implementation of the MAXVAL intrinsic 2 Copyright (C) 2017-2019 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_1) && defined (HAVE_GFC_UINTEGER_1) 30 31 #include <string.h> 32 #include <assert.h> 33 34 static inline int 35 compare_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 43 extern 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); 46 export_proto(maxval1_s1); 47 48 void 49 maxval1_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 212 extern 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); 216 export_proto(mmaxval1_s1); 217 218 void 219 mmaxval1_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 422 void 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 427 export_proto(smaxval1_s1); 428 429 void 430 smaxval1_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