libgfortran/intrinsics/spread_generic.c

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