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