1/* Generic implementation of the SPREAD intrinsic 2 Copyright (C) 2002-2020 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 12Ligbfortran 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#include <string.h> 28 29static void 30spread_internal (gfc_array_char *ret, const gfc_array_char *source, 31 const index_type *along, const index_type *pncopies) 32{ 33 /* r.* indicates the return array. */ 34 index_type rstride[GFC_MAX_DIMENSIONS]; 35 index_type rstride0; 36 index_type rdelta = 0; 37 index_type rrank; 38 index_type rs; 39 char *rptr; 40 char *dest; 41 /* s.* indicates the source array. */ 42 index_type sstride[GFC_MAX_DIMENSIONS]; 43 index_type sstride0; 44 index_type srank; 45 const char *sptr; 46 47 index_type count[GFC_MAX_DIMENSIONS]; 48 index_type extent[GFC_MAX_DIMENSIONS]; 49 index_type n; 50 index_type dim; 51 index_type ncopies; 52 index_type size; 53 54 size = GFC_DESCRIPTOR_SIZE(source); 55 56 srank = GFC_DESCRIPTOR_RANK(source); 57 58 rrank = srank + 1; 59 if (rrank > GFC_MAX_DIMENSIONS) 60 runtime_error ("return rank too large in spread()"); 61 62 if (*along > rrank) 63 runtime_error ("dim outside of rank in spread()"); 64 65 ncopies = *pncopies; 66 67 if (ret->base_addr == NULL) 68 { 69 /* The front end has signalled that we need to populate the 70 return array descriptor. */ 71 72 size_t ub, stride; 73 74 ret->dtype.rank = rrank; 75 76 dim = 0; 77 rs = 1; 78 for (n = 0; n < rrank; n++) 79 { 80 stride = rs; 81 if (n == *along - 1) 82 { 83 ub = ncopies - 1; 84 rdelta = rs * size; 85 rs *= ncopies; 86 } 87 else 88 { 89 count[dim] = 0; 90 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); 91 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim); 92 rstride[dim] = rs * size; 93 94 ub = extent[dim]-1; 95 rs *= extent[dim]; 96 dim++; 97 } 98 99 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); 100 } 101 ret->offset = 0; 102 ret->base_addr = xmallocarray (rs, size); 103 104 if (rs <= 0) 105 return; 106 } 107 else 108 { 109 int zero_sized; 110 111 zero_sized = 0; 112 113 dim = 0; 114 if (GFC_DESCRIPTOR_RANK(ret) != rrank) 115 runtime_error ("rank mismatch in spread()"); 116 117 if (compile_options.bounds_check) 118 { 119 for (n = 0; n < rrank; n++) 120 { 121 index_type ret_extent; 122 123 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); 124 if (n == *along - 1) 125 { 126 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n); 127 128 if (ret_extent != ncopies) 129 runtime_error("Incorrect extent in return value of SPREAD" 130 " intrinsic in dimension %ld: is %ld," 131 " should be %ld", (long int) n+1, 132 (long int) ret_extent, (long int) ncopies); 133 } 134 else 135 { 136 count[dim] = 0; 137 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); 138 if (ret_extent != extent[dim]) 139 runtime_error("Incorrect extent in return value of SPREAD" 140 " intrinsic in dimension %ld: is %ld," 141 " should be %ld", (long int) n+1, 142 (long int) ret_extent, 143 (long int) extent[dim]); 144 145 if (extent[dim] <= 0) 146 zero_sized = 1; 147 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim); 148 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n); 149 dim++; 150 } 151 } 152 } 153 else 154 { 155 for (n = 0; n < rrank; n++) 156 { 157 if (n == *along - 1) 158 { 159 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n); 160 } 161 else 162 { 163 count[dim] = 0; 164 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); 165 if (extent[dim] <= 0) 166 zero_sized = 1; 167 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim); 168 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n); 169 dim++; 170 } 171 } 172 } 173 174 if (zero_sized) 175 return; 176 177 if (sstride[0] == 0) 178 sstride[0] = size; 179 } 180 sstride0 = sstride[0]; 181 rstride0 = rstride[0]; 182 rptr = ret->base_addr; 183 sptr = source->base_addr; 184 185 while (sptr) 186 { 187 /* Spread this element. */ 188 dest = rptr; 189 for (n = 0; n < ncopies; n++) 190 { 191 memcpy (dest, sptr, size); 192 dest += rdelta; 193 } 194 /* Advance to the next element. */ 195 sptr += sstride0; 196 rptr += rstride0; 197 count[0]++; 198 n = 0; 199 while (count[n] == extent[n]) 200 { 201 /* When we get to the end of a dimension, reset it and increment 202 the next dimension. */ 203 count[n] = 0; 204 /* We could precalculate these products, but this is a less 205 frequently used path so probably not worth it. */ 206 sptr -= sstride[n] * extent[n]; 207 rptr -= rstride[n] * extent[n]; 208 n++; 209 if (n >= srank) 210 { 211 /* Break out of the loop. */ 212 sptr = NULL; 213 break; 214 } 215 else 216 { 217 count[n]++; 218 sptr += sstride[n]; 219 rptr += rstride[n]; 220 } 221 } 222 } 223} 224 225/* This version of spread_internal treats the special case of a scalar 226 source. This is much simpler than the more general case above. */ 227 228static void 229spread_internal_scalar (gfc_array_char *ret, const char *source, 230 const index_type *along, const index_type *pncopies) 231{ 232 int n; 233 int ncopies = *pncopies; 234 char * dest; 235 size_t size; 236 237 size = GFC_DESCRIPTOR_SIZE(ret); 238 239 if (GFC_DESCRIPTOR_RANK (ret) != 1) 240 runtime_error ("incorrect destination rank in spread()"); 241 242 if (*along > 1) 243 runtime_error ("dim outside of rank in spread()"); 244 245 if (ret->base_addr == NULL) 246 { 247 ret->base_addr = xmallocarray (ncopies, size); 248 ret->offset = 0; 249 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); 250 } 251 else 252 { 253 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) 254 / GFC_DESCRIPTOR_STRIDE(ret,0)) 255 runtime_error ("dim too large in spread()"); 256 } 257 258 for (n = 0; n < ncopies; n++) 259 { 260 dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0)); 261 memcpy (dest , source, size); 262 } 263} 264 265extern void spread (gfc_array_char *, const gfc_array_char *, 266 const index_type *, const index_type *); 267export_proto(spread); 268 269void 270spread (gfc_array_char *ret, const gfc_array_char *source, 271 const index_type *along, const index_type *pncopies) 272{ 273 index_type type_size; 274 275 type_size = GFC_DTYPE_TYPE_SIZE(ret); 276 switch(type_size) 277 { 278 case GFC_DTYPE_LOGICAL_1: 279 case GFC_DTYPE_INTEGER_1: 280 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source, 281 *along, *pncopies); 282 return; 283 284 case GFC_DTYPE_LOGICAL_2: 285 case GFC_DTYPE_INTEGER_2: 286 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, 287 *along, *pncopies); 288 return; 289 290 case GFC_DTYPE_LOGICAL_4: 291 case GFC_DTYPE_INTEGER_4: 292 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, 293 *along, *pncopies); 294 return; 295 296 case GFC_DTYPE_LOGICAL_8: 297 case GFC_DTYPE_INTEGER_8: 298 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, 299 *along, *pncopies); 300 return; 301 302#ifdef HAVE_GFC_INTEGER_16 303 case GFC_DTYPE_LOGICAL_16: 304 case GFC_DTYPE_INTEGER_16: 305 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, 306 *along, *pncopies); 307 return; 308#endif 309 310 case GFC_DTYPE_REAL_4: 311 spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source, 312 *along, *pncopies); 313 return; 314 315 case GFC_DTYPE_REAL_8: 316 spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source, 317 *along, *pncopies); 318 return; 319 320/* FIXME: This here is a hack, which will have to be removed when 321 the array descriptor is reworked. Currently, we don't store the 322 kind value for the type, but only the size. Because on targets with 323 __float128, we have sizeof(logn double) == sizeof(__float128), 324 we cannot discriminate here and have to fall back to the generic 325 handling (which is suboptimal). */ 326#if !defined(GFC_REAL_16_IS_FLOAT128) 327# ifdef GFC_HAVE_REAL_10 328 case GFC_DTYPE_REAL_10: 329 spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source, 330 *along, *pncopies); 331 return; 332# endif 333 334# ifdef GFC_HAVE_REAL_16 335 case GFC_DTYPE_REAL_16: 336 spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source, 337 *along, *pncopies); 338 return; 339# endif 340#endif 341 342 case GFC_DTYPE_COMPLEX_4: 343 spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source, 344 *along, *pncopies); 345 return; 346 347 case GFC_DTYPE_COMPLEX_8: 348 spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source, 349 *along, *pncopies); 350 return; 351 352/* FIXME: This here is a hack, which will have to be removed when 353 the array descriptor is reworked. Currently, we don't store the 354 kind value for the type, but only the size. Because on targets with 355 __float128, we have sizeof(logn double) == sizeof(__float128), 356 we cannot discriminate here and have to fall back to the generic 357 handling (which is suboptimal). */ 358#if !defined(GFC_REAL_16_IS_FLOAT128) 359# ifdef GFC_HAVE_COMPLEX_10 360 case GFC_DTYPE_COMPLEX_10: 361 spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source, 362 *along, *pncopies); 363 return; 364# endif 365 366# ifdef GFC_HAVE_COMPLEX_16 367 case GFC_DTYPE_COMPLEX_16: 368 spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source, 369 *along, *pncopies); 370 return; 371# endif 372#endif 373 374 } 375 376 switch (GFC_DESCRIPTOR_SIZE (ret)) 377 { 378 case 1: 379 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source, 380 *along, *pncopies); 381 return; 382 383 case 2: 384 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr)) 385 break; 386 else 387 { 388 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, 389 *along, *pncopies); 390 return; 391 } 392 393 case 4: 394 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr)) 395 break; 396 else 397 { 398 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, 399 *along, *pncopies); 400 return; 401 } 402 403 case 8: 404 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr)) 405 break; 406 else 407 { 408 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, 409 *along, *pncopies); 410 return; 411 } 412#ifdef HAVE_GFC_INTEGER_16 413 case 16: 414 if (GFC_UNALIGNED_16(ret->base_addr) 415 || GFC_UNALIGNED_16(source->base_addr)) 416 break; 417 else 418 { 419 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, 420 *along, *pncopies); 421 return; 422 } 423#endif 424 425 } 426 427 spread_internal (ret, source, along, pncopies); 428} 429 430 431extern void spread_char (gfc_array_char *, GFC_INTEGER_4, 432 const gfc_array_char *, const index_type *, 433 const index_type *, GFC_INTEGER_4); 434export_proto(spread_char); 435 436void 437spread_char (gfc_array_char *ret, 438 GFC_INTEGER_4 ret_length __attribute__((unused)), 439 const gfc_array_char *source, const index_type *along, 440 const index_type *pncopies, 441 GFC_INTEGER_4 source_length __attribute__((unused))) 442{ 443 spread_internal (ret, source, along, pncopies); 444} 445 446 447extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4, 448 const gfc_array_char *, const index_type *, 449 const index_type *, GFC_INTEGER_4); 450export_proto(spread_char4); 451 452void 453spread_char4 (gfc_array_char *ret, 454 GFC_INTEGER_4 ret_length __attribute__((unused)), 455 const gfc_array_char *source, const index_type *along, 456 const index_type *pncopies, 457 GFC_INTEGER_4 source_length __attribute__((unused))) 458{ 459 spread_internal (ret, source, along, pncopies); 460} 461 462 463/* The following are the prototypes for the versions of spread with a 464 scalar source. */ 465 466extern void spread_scalar (gfc_array_char *, const char *, 467 const index_type *, const index_type *); 468export_proto(spread_scalar); 469 470void 471spread_scalar (gfc_array_char *ret, const char *source, 472 const index_type *along, const index_type *pncopies) 473{ 474 index_type type_size; 475 476 if (GFC_DTYPE_IS_UNSET(ret)) 477 runtime_error ("return array missing descriptor in spread()"); 478 479 type_size = GFC_DTYPE_TYPE_SIZE(ret); 480 switch(type_size) 481 { 482 case GFC_DTYPE_LOGICAL_1: 483 case GFC_DTYPE_INTEGER_1: 484 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source, 485 *along, *pncopies); 486 return; 487 488 case GFC_DTYPE_LOGICAL_2: 489 case GFC_DTYPE_INTEGER_2: 490 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, 491 *along, *pncopies); 492 return; 493 494 case GFC_DTYPE_LOGICAL_4: 495 case GFC_DTYPE_INTEGER_4: 496 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, 497 *along, *pncopies); 498 return; 499 500 case GFC_DTYPE_LOGICAL_8: 501 case GFC_DTYPE_INTEGER_8: 502 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, 503 *along, *pncopies); 504 return; 505 506#ifdef HAVE_GFC_INTEGER_16 507 case GFC_DTYPE_LOGICAL_16: 508 case GFC_DTYPE_INTEGER_16: 509 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, 510 *along, *pncopies); 511 return; 512#endif 513 514 case GFC_DTYPE_REAL_4: 515 spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source, 516 *along, *pncopies); 517 return; 518 519 case GFC_DTYPE_REAL_8: 520 spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source, 521 *along, *pncopies); 522 return; 523 524/* FIXME: This here is a hack, which will have to be removed when 525 the array descriptor is reworked. Currently, we don't store the 526 kind value for the type, but only the size. Because on targets with 527 __float128, we have sizeof(logn double) == sizeof(__float128), 528 we cannot discriminate here and have to fall back to the generic 529 handling (which is suboptimal). */ 530#if !defined(GFC_REAL_16_IS_FLOAT128) 531# ifdef HAVE_GFC_REAL_10 532 case GFC_DTYPE_REAL_10: 533 spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source, 534 *along, *pncopies); 535 return; 536# endif 537 538# ifdef HAVE_GFC_REAL_16 539 case GFC_DTYPE_REAL_16: 540 spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source, 541 *along, *pncopies); 542 return; 543# endif 544#endif 545 546 case GFC_DTYPE_COMPLEX_4: 547 spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source, 548 *along, *pncopies); 549 return; 550 551 case GFC_DTYPE_COMPLEX_8: 552 spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source, 553 *along, *pncopies); 554 return; 555 556/* FIXME: This here is a hack, which will have to be removed when 557 the array descriptor is reworked. Currently, we don't store the 558 kind value for the type, but only the size. Because on targets with 559 __float128, we have sizeof(logn double) == sizeof(__float128), 560 we cannot discriminate here and have to fall back to the generic 561 handling (which is suboptimal). */ 562#if !defined(GFC_REAL_16_IS_FLOAT128) 563# ifdef HAVE_GFC_COMPLEX_10 564 case GFC_DTYPE_COMPLEX_10: 565 spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source, 566 *along, *pncopies); 567 return; 568# endif 569 570# ifdef HAVE_GFC_COMPLEX_16 571 case GFC_DTYPE_COMPLEX_16: 572 spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source, 573 *along, *pncopies); 574 return; 575# endif 576#endif 577 578 } 579 580 switch (GFC_DESCRIPTOR_SIZE(ret)) 581 { 582 case 1: 583 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source, 584 *along, *pncopies); 585 return; 586 587 case 2: 588 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source)) 589 break; 590 else 591 { 592 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, 593 *along, *pncopies); 594 return; 595 } 596 597 case 4: 598 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source)) 599 break; 600 else 601 { 602 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, 603 *along, *pncopies); 604 return; 605 } 606 607 case 8: 608 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source)) 609 break; 610 else 611 { 612 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, 613 *along, *pncopies); 614 return; 615 } 616#ifdef HAVE_GFC_INTEGER_16 617 case 16: 618 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source)) 619 break; 620 else 621 { 622 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, 623 *along, *pncopies); 624 return; 625 } 626#endif 627 default: 628 break; 629 } 630 631 spread_internal_scalar (ret, source, along, pncopies); 632} 633 634 635extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4, 636 const char *, const index_type *, 637 const index_type *, GFC_INTEGER_4); 638export_proto(spread_char_scalar); 639 640void 641spread_char_scalar (gfc_array_char *ret, 642 GFC_INTEGER_4 ret_length __attribute__((unused)), 643 const char *source, const index_type *along, 644 const index_type *pncopies, 645 GFC_INTEGER_4 source_length __attribute__((unused))) 646{ 647 if (GFC_DTYPE_IS_UNSET(ret)) 648 runtime_error ("return array missing descriptor in spread()"); 649 spread_internal_scalar (ret, source, along, pncopies); 650} 651 652 653extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4, 654 const char *, const index_type *, 655 const index_type *, GFC_INTEGER_4); 656export_proto(spread_char4_scalar); 657 658void 659spread_char4_scalar (gfc_array_char *ret, 660 GFC_INTEGER_4 ret_length __attribute__((unused)), 661 const char *source, const index_type *along, 662 const index_type *pncopies, 663 GFC_INTEGER_4 source_length __attribute__((unused))) 664{ 665 if (GFC_DTYPE_IS_UNSET(ret)) 666 runtime_error ("return array missing descriptor in spread()"); 667 spread_internal_scalar (ret, source, along, pncopies); 668 669} 670 671