1 /* Generic implementation of the PACK intrinsic 2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 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 Ligbfortran 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 #include <string.h> 28 29 /* PACK is specified as follows: 30 31 13.14.80 PACK (ARRAY, MASK, [VECTOR]) 32 33 Description: Pack an array into an array of rank one under the 34 control of a mask. 35 36 Class: Transformational function. 37 38 Arguments: 39 ARRAY may be of any type. It shall not be scalar. 40 MASK shall be of type LOGICAL. It shall be conformable with ARRAY. 41 VECTOR (optional) shall be of the same type and type parameters 42 as ARRAY. VECTOR shall have at least as many elements as 43 there are true elements in MASK. If MASK is a scalar 44 with the value true, VECTOR shall have at least as many 45 elements as there are in ARRAY. 46 47 Result Characteristics: The result is an array of rank one with the 48 same type and type parameters as ARRAY. If VECTOR is present, the 49 result size is that of VECTOR; otherwise, the result size is the 50 number /t/ of true elements in MASK unless MASK is scalar with the 51 value true, in which case the result size is the size of ARRAY. 52 53 Result Value: Element /i/ of the result is the element of ARRAY 54 that corresponds to the /i/th true element of MASK, taking elements 55 in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is 56 present and has size /n/ > /t/, element /i/ of the result has the 57 value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. 58 59 Examples: The nonzero elements of an array M with the value 60 | 0 0 0 | 61 | 9 0 0 | may be "gathered" by the function PACK. The result of 62 | 0 0 7 | 63 PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, 64 VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. 65 66 There are two variants of the PACK intrinsic: one, where MASK is 67 array valued, and the other one where MASK is scalar. */ 68 69 static void 70 pack_internal (gfc_array_char *ret, const gfc_array_char *array, 71 const gfc_array_l1 *mask, const gfc_array_char *vector, 72 index_type size) 73 { 74 /* r.* indicates the return array. */ 75 index_type rstride0; 76 char * restrict rptr; 77 /* s.* indicates the source array. */ 78 index_type sstride[GFC_MAX_DIMENSIONS]; 79 index_type sstride0; 80 const char *sptr; 81 /* m.* indicates the mask array. */ 82 index_type mstride[GFC_MAX_DIMENSIONS]; 83 index_type mstride0; 84 const GFC_LOGICAL_1 *mptr; 85 86 index_type count[GFC_MAX_DIMENSIONS]; 87 index_type extent[GFC_MAX_DIMENSIONS]; 88 bool zero_sized; 89 index_type n; 90 index_type dim; 91 index_type nelem; 92 index_type total; 93 int mask_kind; 94 95 dim = GFC_DESCRIPTOR_RANK (array); 96 97 sptr = array->base_addr; 98 mptr = mask->base_addr; 99 100 /* Use the same loop for all logical types, by using GFC_LOGICAL_1 101 and using shifting to address size and endian issues. */ 102 103 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 104 105 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 106 #ifdef HAVE_GFC_LOGICAL_16 107 || mask_kind == 16 108 #endif 109 ) 110 { 111 /* Don't convert a NULL pointer as we use test for NULL below. */ 112 if (mptr) 113 mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); 114 } 115 else 116 runtime_error ("Funny sized logical array"); 117 118 zero_sized = false; 119 for (n = 0; n < dim; n++) 120 { 121 count[n] = 0; 122 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 123 if (extent[n] <= 0) 124 zero_sized = true; 125 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); 126 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 127 } 128 if (sstride[0] == 0) 129 sstride[0] = size; 130 if (mstride[0] == 0) 131 mstride[0] = mask_kind; 132 133 if (zero_sized) 134 sptr = NULL; 135 else 136 sptr = array->base_addr; 137 138 if (ret->base_addr == NULL || unlikely (compile_options.bounds_check)) 139 { 140 /* Count the elements, either for allocating memory or 141 for bounds checking. */ 142 143 if (vector != NULL) 144 { 145 /* The return array will have as many 146 elements as there are in VECTOR. */ 147 total = GFC_DESCRIPTOR_EXTENT(vector,0); 148 } 149 else 150 { 151 /* We have to count the true elements in MASK. */ 152 153 total = count_0 (mask); 154 } 155 156 if (ret->base_addr == NULL) 157 { 158 /* Setup the array descriptor. */ 159 GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); 160 161 ret->offset = 0; 162 /* xmallocarray allocates a single byte for zero size. */ 163 ret->base_addr = xmallocarray (total, size); 164 165 if (total == 0) 166 return; /* In this case, nothing remains to be done. */ 167 } 168 else 169 { 170 /* We come here because of range checking. */ 171 index_type ret_extent; 172 173 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); 174 if (total != ret_extent) 175 runtime_error ("Incorrect extent in return value of PACK intrinsic;" 176 " is %ld, should be %ld", (long int) total, 177 (long int) ret_extent); 178 } 179 } 180 181 rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0); 182 if (rstride0 == 0) 183 rstride0 = size; 184 sstride0 = sstride[0]; 185 mstride0 = mstride[0]; 186 rptr = ret->base_addr; 187 188 while (sptr && mptr) 189 { 190 /* Test this element. */ 191 if (*mptr) 192 { 193 /* Add it. */ 194 memcpy (rptr, sptr, size); 195 rptr += rstride0; 196 } 197 /* Advance to the next element. */ 198 sptr += sstride0; 199 mptr += mstride0; 200 count[0]++; 201 n = 0; 202 while (count[n] == extent[n]) 203 { 204 /* When we get to the end of a dimension, reset it and increment 205 the next dimension. */ 206 count[n] = 0; 207 /* We could precalculate these products, but this is a less 208 frequently used path so probably not worth it. */ 209 sptr -= sstride[n] * extent[n]; 210 mptr -= mstride[n] * extent[n]; 211 n++; 212 if (n >= dim) 213 { 214 /* Break out of the loop. */ 215 sptr = NULL; 216 break; 217 } 218 else 219 { 220 count[n]++; 221 sptr += sstride[n]; 222 mptr += mstride[n]; 223 } 224 } 225 } 226 227 /* Add any remaining elements from VECTOR. */ 228 if (vector) 229 { 230 n = GFC_DESCRIPTOR_EXTENT(vector,0); 231 nelem = ((rptr - ret->base_addr) / rstride0); 232 if (n > nelem) 233 { 234 sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0); 235 if (sstride0 == 0) 236 sstride0 = size; 237 238 sptr = vector->base_addr + sstride0 * nelem; 239 n -= nelem; 240 while (n--) 241 { 242 memcpy (rptr, sptr, size); 243 rptr += rstride0; 244 sptr += sstride0; 245 } 246 } 247 } 248 } 249 250 extern void pack (gfc_array_char *, const gfc_array_char *, 251 const gfc_array_l1 *, const gfc_array_char *); 252 export_proto(pack); 253 254 void 255 pack (gfc_array_char *ret, const gfc_array_char *array, 256 const gfc_array_l1 *mask, const gfc_array_char *vector) 257 { 258 index_type type_size; 259 index_type size; 260 261 type_size = GFC_DTYPE_TYPE_SIZE(array); 262 263 switch(type_size) 264 { 265 case GFC_DTYPE_LOGICAL_1: 266 case GFC_DTYPE_INTEGER_1: 267 pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, 268 (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); 269 return; 270 271 case GFC_DTYPE_LOGICAL_2: 272 case GFC_DTYPE_INTEGER_2: 273 pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, 274 (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); 275 return; 276 277 case GFC_DTYPE_LOGICAL_4: 278 case GFC_DTYPE_INTEGER_4: 279 pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, 280 (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); 281 return; 282 283 case GFC_DTYPE_LOGICAL_8: 284 case GFC_DTYPE_INTEGER_8: 285 pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, 286 (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); 287 return; 288 289 #ifdef HAVE_GFC_INTEGER_16 290 case GFC_DTYPE_LOGICAL_16: 291 case GFC_DTYPE_INTEGER_16: 292 pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, 293 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); 294 return; 295 #endif 296 297 case GFC_DTYPE_REAL_4: 298 pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, 299 (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); 300 return; 301 302 case GFC_DTYPE_REAL_8: 303 pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, 304 (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); 305 return; 306 307 /* FIXME: This here is a hack, which will have to be removed when 308 the array descriptor is reworked. Currently, we don't store the 309 kind value for the type, but only the size. Because on targets with 310 __float128, we have sizeof(logn double) == sizeof(__float128), 311 we cannot discriminate here and have to fall back to the generic 312 handling (which is suboptimal). */ 313 #if !defined(GFC_REAL_16_IS_FLOAT128) 314 # ifdef HAVE_GFC_REAL_10 315 case GFC_DTYPE_REAL_10: 316 pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, 317 (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); 318 return; 319 # endif 320 321 # ifdef HAVE_GFC_REAL_16 322 case GFC_DTYPE_REAL_16: 323 pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, 324 (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); 325 return; 326 # endif 327 #endif 328 329 case GFC_DTYPE_COMPLEX_4: 330 pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, 331 (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); 332 return; 333 334 case GFC_DTYPE_COMPLEX_8: 335 pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, 336 (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); 337 return; 338 339 /* FIXME: This here is a hack, which will have to be removed when 340 the array descriptor is reworked. Currently, we don't store the 341 kind value for the type, but only the size. Because on targets with 342 __float128, we have sizeof(logn double) == sizeof(__float128), 343 we cannot discriminate here and have to fall back to the generic 344 handling (which is suboptimal). */ 345 #if !defined(GFC_REAL_16_IS_FLOAT128) 346 # ifdef HAVE_GFC_COMPLEX_10 347 case GFC_DTYPE_COMPLEX_10: 348 pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, 349 (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); 350 return; 351 # endif 352 353 # ifdef HAVE_GFC_COMPLEX_16 354 case GFC_DTYPE_COMPLEX_16: 355 pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, 356 (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); 357 return; 358 # endif 359 #endif 360 } 361 362 /* For other types, let's check the actual alignment of the data pointers. 363 If they are aligned, we can safely call the unpack functions. */ 364 365 switch (GFC_DESCRIPTOR_SIZE (array)) 366 { 367 case 1: 368 pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, 369 (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); 370 return; 371 372 case 2: 373 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr) 374 || (vector && GFC_UNALIGNED_2(vector->base_addr))) 375 break; 376 else 377 { 378 pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, 379 (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); 380 return; 381 } 382 383 case 4: 384 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr) 385 || (vector && GFC_UNALIGNED_4(vector->base_addr))) 386 break; 387 else 388 { 389 pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, 390 (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); 391 return; 392 } 393 394 case 8: 395 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr) 396 || (vector && GFC_UNALIGNED_8(vector->base_addr))) 397 break; 398 else 399 { 400 pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, 401 (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); 402 return; 403 } 404 405 #ifdef HAVE_GFC_INTEGER_16 406 case 16: 407 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr) 408 || (vector && GFC_UNALIGNED_16(vector->base_addr))) 409 break; 410 else 411 { 412 pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, 413 (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); 414 return; 415 } 416 #endif 417 default: 418 break; 419 } 420 421 size = GFC_DESCRIPTOR_SIZE (array); 422 pack_internal (ret, array, mask, vector, size); 423 } 424 425 426 extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, 427 const gfc_array_l1 *, const gfc_array_char *, 428 GFC_INTEGER_4, GFC_INTEGER_4); 429 export_proto(pack_char); 430 431 void 432 pack_char (gfc_array_char *ret, 433 GFC_INTEGER_4 ret_length __attribute__((unused)), 434 const gfc_array_char *array, const gfc_array_l1 *mask, 435 const gfc_array_char *vector, GFC_INTEGER_4 array_length, 436 GFC_INTEGER_4 vector_length __attribute__((unused))) 437 { 438 pack_internal (ret, array, mask, vector, array_length); 439 } 440 441 442 extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, 443 const gfc_array_l1 *, const gfc_array_char *, 444 GFC_INTEGER_4, GFC_INTEGER_4); 445 export_proto(pack_char4); 446 447 void 448 pack_char4 (gfc_array_char *ret, 449 GFC_INTEGER_4 ret_length __attribute__((unused)), 450 const gfc_array_char *array, const gfc_array_l1 *mask, 451 const gfc_array_char *vector, GFC_INTEGER_4 array_length, 452 GFC_INTEGER_4 vector_length __attribute__((unused))) 453 { 454 pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t)); 455 } 456 457 458 static void 459 pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, 460 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector, 461 index_type size) 462 { 463 /* r.* indicates the return array. */ 464 index_type rstride0; 465 char *rptr; 466 /* s.* indicates the source array. */ 467 index_type sstride[GFC_MAX_DIMENSIONS]; 468 index_type sstride0; 469 const char *sptr; 470 471 index_type count[GFC_MAX_DIMENSIONS]; 472 index_type extent[GFC_MAX_DIMENSIONS]; 473 index_type n; 474 index_type dim; 475 index_type ssize; 476 index_type nelem; 477 index_type total; 478 479 dim = GFC_DESCRIPTOR_RANK (array); 480 /* Initialize sstride[0] to avoid -Wmaybe-uninitialized 481 complaints. */ 482 sstride[0] = size; 483 ssize = 1; 484 for (n = 0; n < dim; n++) 485 { 486 count[n] = 0; 487 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 488 if (extent[n] < 0) 489 extent[n] = 0; 490 491 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); 492 ssize *= extent[n]; 493 } 494 if (sstride[0] == 0) 495 sstride[0] = size; 496 497 sstride0 = sstride[0]; 498 499 if (ssize != 0) 500 sptr = array->base_addr; 501 else 502 sptr = NULL; 503 504 if (ret->base_addr == NULL) 505 { 506 /* Allocate the memory for the result. */ 507 508 if (vector != NULL) 509 { 510 /* The return array will have as many elements as there are 511 in vector. */ 512 total = GFC_DESCRIPTOR_EXTENT(vector,0); 513 if (total <= 0) 514 { 515 total = 0; 516 vector = NULL; 517 } 518 } 519 else 520 { 521 if (*mask) 522 { 523 /* The result array will have as many elements as the input 524 array. */ 525 total = extent[0]; 526 for (n = 1; n < dim; n++) 527 total *= extent[n]; 528 } 529 else 530 /* The result array will be empty. */ 531 total = 0; 532 } 533 534 /* Setup the array descriptor. */ 535 GFC_DIMENSION_SET(ret->dim[0],0,total-1,1); 536 537 ret->offset = 0; 538 539 ret->base_addr = xmallocarray (total, size); 540 541 if (total == 0) 542 return; 543 } 544 545 rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0); 546 if (rstride0 == 0) 547 rstride0 = size; 548 rptr = ret->base_addr; 549 550 /* The remaining possibilities are now: 551 If MASK is .TRUE., we have to copy the source array into the 552 result array. We then have to fill it up with elements from VECTOR. 553 If MASK is .FALSE., we have to copy VECTOR into the result 554 array. If VECTOR were not present we would have already returned. */ 555 556 if (*mask && ssize != 0) 557 { 558 while (sptr) 559 { 560 /* Add this element. */ 561 memcpy (rptr, sptr, size); 562 rptr += rstride0; 563 564 /* Advance to the next element. */ 565 sptr += sstride0; 566 count[0]++; 567 n = 0; 568 while (count[n] == extent[n]) 569 { 570 /* When we get to the end of a dimension, reset it and 571 increment the next dimension. */ 572 count[n] = 0; 573 /* We could precalculate these products, but this is a 574 less frequently used path so probably not worth it. */ 575 sptr -= sstride[n] * extent[n]; 576 n++; 577 if (n >= dim) 578 { 579 /* Break out of the loop. */ 580 sptr = NULL; 581 break; 582 } 583 else 584 { 585 count[n]++; 586 sptr += sstride[n]; 587 } 588 } 589 } 590 } 591 592 /* Add any remaining elements from VECTOR. */ 593 if (vector) 594 { 595 n = GFC_DESCRIPTOR_EXTENT(vector,0); 596 nelem = ((rptr - ret->base_addr) / rstride0); 597 if (n > nelem) 598 { 599 sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0); 600 if (sstride0 == 0) 601 sstride0 = size; 602 603 sptr = vector->base_addr + sstride0 * nelem; 604 n -= nelem; 605 while (n--) 606 { 607 memcpy (rptr, sptr, size); 608 rptr += rstride0; 609 sptr += sstride0; 610 } 611 } 612 } 613 } 614 615 extern void pack_s (gfc_array_char *ret, const gfc_array_char *array, 616 const GFC_LOGICAL_4 *, const gfc_array_char *); 617 export_proto(pack_s); 618 619 void 620 pack_s (gfc_array_char *ret, const gfc_array_char *array, 621 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector) 622 { 623 pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); 624 } 625 626 627 extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4, 628 const gfc_array_char *array, const GFC_LOGICAL_4 *, 629 const gfc_array_char *, GFC_INTEGER_4, 630 GFC_INTEGER_4); 631 export_proto(pack_s_char); 632 633 void 634 pack_s_char (gfc_array_char *ret, 635 GFC_INTEGER_4 ret_length __attribute__((unused)), 636 const gfc_array_char *array, const GFC_LOGICAL_4 *mask, 637 const gfc_array_char *vector, GFC_INTEGER_4 array_length, 638 GFC_INTEGER_4 vector_length __attribute__((unused))) 639 { 640 pack_s_internal (ret, array, mask, vector, array_length); 641 } 642 643 644 extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4, 645 const gfc_array_char *array, const GFC_LOGICAL_4 *, 646 const gfc_array_char *, GFC_INTEGER_4, 647 GFC_INTEGER_4); 648 export_proto(pack_s_char4); 649 650 void 651 pack_s_char4 (gfc_array_char *ret, 652 GFC_INTEGER_4 ret_length __attribute__((unused)), 653 const gfc_array_char *array, const GFC_LOGICAL_4 *mask, 654 const gfc_array_char *vector, GFC_INTEGER_4 array_length, 655 GFC_INTEGER_4 vector_length __attribute__((unused))) 656 { 657 pack_s_internal (ret, array, mask, vector, 658 array_length * sizeof (gfc_char4_t)); 659 } 660