libgfortran/generated/product_r10.c

   1 /* Implementation of the PRODUCT intrinsic
   2    Copyright (C) 2002-2018 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 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_REAL_10) && defined (HAVE_GFC_REAL_10)
  30
  31
  32 extern void product_r10 (gfc_array_r10 * const restrict,
  33         gfc_array_r10 * const restrict, const index_type * const restrict);
  34 export_proto(product_r10);
  35
  36 void
  37 product_r10 (gfc_array_r10 * const restrict retarray,
  38         gfc_array_r10 * const restrict array,
  39         const index_type * const restrict pdim)
  40 {
  41   index_type count[GFC_MAX_DIMENSIONS];
  42   index_type extent[GFC_MAX_DIMENSIONS];
  43   index_type sstride[GFC_MAX_DIMENSIONS];
  44   index_type dstride[GFC_MAX_DIMENSIONS];
  45   const GFC_REAL_10 * restrict base;
  46   GFC_REAL_10 * restrict dest;
  47   index_type rank;
  48   index_type n;
  49   index_type len;
  50   index_type delta;
  51   index_type dim;
  52   int continue_loop;
  53
  54   /* Make dim zero based to avoid confusion.  */
  55   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  56   dim = (*pdim) - 1;
  57
  58   if (unlikely (dim < 0 || dim > rank))
  59     {
  60       runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
  61                      "is %ld, should be between 1 and %ld",
  62                      (long int) dim + 1, (long int) rank + 1);
  63     }
  64
  65   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  66   if (len < 0)
  67     len = 0;
  68   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  69
  70   for (n = 0; n < dim; n++)
  71     {
  72       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  73       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  74
  75       if (extent[n] < 0)
  76         extent[n] = 0;
  77     }
  78   for (n = dim; n < rank; n++)
  79     {
  80       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
  81       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  82
  83       if (extent[n] < 0)
  84         extent[n] = 0;
  85     }
  86
  87   if (retarray->base_addr == NULL)
  88     {
  89       size_t alloc_size, str;
  90
  91       for (n = 0; n < rank; n++)
  92         {
  93           if (n == 0)
  94             str = 1;
  95           else
  96             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
  97
  98           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
  99
 100         }
 101
 102       retarray->offset = 0;
 103       retarray->dtype.rank = rank;
 104
 105       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 106
 107       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 108       if (alloc_size == 0)
 109         {
 110           /* Make sure we have a zero-sized array.  */
 111           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 112           return;
 113
 114         }
 115     }
 116   else
 117     {
 118       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 119         runtime_error ("rank of return array incorrect in"
 120                        " PRODUCT intrinsic: is %ld, should be %ld",
 121                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 122                        (long int) rank);
 123
 124       if (unlikely (compile_options.bounds_check))
 125         bounds_ifunction_return ((array_t *) retarray, extent,
 126                                  "return value", "PRODUCT");
 127     }
 128
 129   for (n = 0; n < rank; n++)
 130     {
 131       count[n] = 0;
 132       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 133       if (extent[n] <= 0)
 134         return;
 135     }
 136
 137   base = array->base_addr;
 138   dest = retarray->base_addr;
 139
 140   continue_loop = 1;
 141   while (continue_loop)
 142     {
 143       const GFC_REAL_10 * restrict src;
 144       GFC_REAL_10 result;
 145       src = base;
 146       {
 147
 148   result = 1;
 149         if (len <= 0)
 150           *dest = 1;
 151         else
 152           {
 153 #if ! defined HAVE_BACK_ARG
 154             for (n = 0; n < len; n++, src += delta)
 155               {
 156 #endif
 157
 158   result *= *src;
 159               }
 160
 161             *dest = result;
 162           }
 163       }
 164       /* Advance to the next element.  */
 165       count[0]++;
 166       base += sstride[0];
 167       dest += dstride[0];
 168       n = 0;
 169       while (count[n] == extent[n])
 170         {
 171           /* When we get to the end of a dimension, reset it and increment
 172              the next dimension.  */
 173           count[n] = 0;
 174           /* We could precalculate these products, but this is a less
 175              frequently used path so probably not worth it.  */
 176           base -= sstride[n] * extent[n];
 177           dest -= dstride[n] * extent[n];
 178           n++;
 179           if (n >= rank)
 180             {
 181               /* Break out of the loop.  */
 182               continue_loop = 0;
 183               break;
 184             }
 185           else
 186             {
 187               count[n]++;
 188               base += sstride[n];
 189               dest += dstride[n];
 190             }
 191         }
 192     }
 193 }
 194
 195
 196 extern void mproduct_r10 (gfc_array_r10 * const restrict,
 197         gfc_array_r10 * const restrict, const index_type * const restrict,
 198         gfc_array_l1 * const restrict);
 199 export_proto(mproduct_r10);
 200
 201 void
 202 mproduct_r10 (gfc_array_r10 * const restrict retarray,
 203         gfc_array_r10 * const restrict array,
 204         const index_type * const restrict pdim,
 205         gfc_array_l1 * const restrict mask)
 206 {
 207   index_type count[GFC_MAX_DIMENSIONS];
 208   index_type extent[GFC_MAX_DIMENSIONS];
 209   index_type sstride[GFC_MAX_DIMENSIONS];
 210   index_type dstride[GFC_MAX_DIMENSIONS];
 211   index_type mstride[GFC_MAX_DIMENSIONS];
 212   GFC_REAL_10 * restrict dest;
 213   const GFC_REAL_10 * restrict base;
 214   const GFC_LOGICAL_1 * restrict mbase;
 215   index_type rank;
 216   index_type dim;
 217   index_type n;
 218   index_type len;
 219   index_type delta;
 220   index_type mdelta;
 221   int mask_kind;
 222
 223   dim = (*pdim) - 1;
 224   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 225
 226
 227   if (unlikely (dim < 0 || dim > rank))
 228     {
 229       runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
 230                      "is %ld, should be between 1 and %ld",
 231                      (long int) dim + 1, (long int) rank + 1);
 232     }
 233
 234   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 235   if (len <= 0)
 236     return;
 237
 238   mbase = mask->base_addr;
 239
 240   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 241
 242   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 243 #ifdef HAVE_GFC_LOGICAL_16
 244       || mask_kind == 16
 245 #endif
 246       )
 247     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 248   else
 249     runtime_error ("Funny sized logical array");
 250
 251   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 252   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 253
 254   for (n = 0; n < dim; n++)
 255     {
 256       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 257       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 258       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 259
 260       if (extent[n] < 0)
 261         extent[n] = 0;
 262
 263     }
 264   for (n = dim; n < rank; n++)
 265     {
 266       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 267       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 268       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 269
 270       if (extent[n] < 0)
 271         extent[n] = 0;
 272     }
 273
 274   if (retarray->base_addr == NULL)
 275     {
 276       size_t alloc_size, str;
 277
 278       for (n = 0; n < rank; n++)
 279         {
 280           if (n == 0)
 281             str = 1;
 282           else
 283             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 284
 285           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 286
 287         }
 288
 289       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 290
 291       retarray->offset = 0;
 292       retarray->dtype.rank = rank;
 293
 294       if (alloc_size == 0)
 295         {
 296           /* Make sure we have a zero-sized array.  */
 297           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 298           return;
 299         }
 300       else
 301         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 302
 303     }
 304   else
 305     {
 306       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 307         runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
 308
 309       if (unlikely (compile_options.bounds_check))
 310         {
 311           bounds_ifunction_return ((array_t *) retarray, extent,
 312                                    "return value", "PRODUCT");
 313           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 314                                 "MASK argument", "PRODUCT");
 315         }
 316     }
 317
 318   for (n = 0; n < rank; n++)
 319     {
 320       count[n] = 0;
 321       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 322       if (extent[n] <= 0)
 323         return;
 324     }
 325
 326   dest = retarray->base_addr;
 327   base = array->base_addr;
 328
 329   while (base)
 330     {
 331       const GFC_REAL_10 * restrict src;
 332       const GFC_LOGICAL_1 * restrict msrc;
 333       GFC_REAL_10 result;
 334       src = base;
 335       msrc = mbase;
 336       {
 337
 338   result = 1;
 339         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 340           {
 341
 342   if (*msrc)
 343     result *= *src;
 344           }
 345         *dest = result;
 346       }
 347       /* Advance to the next element.  */
 348       count[0]++;
 349       base += sstride[0];
 350       mbase += mstride[0];
 351       dest += dstride[0];
 352       n = 0;
 353       while (count[n] == extent[n])
 354         {
 355           /* When we get to the end of a dimension, reset it and increment
 356              the next dimension.  */
 357           count[n] = 0;
 358           /* We could precalculate these products, but this is a less
 359              frequently used path so probably not worth it.  */
 360           base -= sstride[n] * extent[n];
 361           mbase -= mstride[n] * extent[n];
 362           dest -= dstride[n] * extent[n];
 363           n++;
 364           if (n >= rank)
 365             {
 366               /* Break out of the loop.  */
 367               base = NULL;
 368               break;
 369             }
 370           else
 371             {
 372               count[n]++;
 373               base += sstride[n];
 374               mbase += mstride[n];
 375               dest += dstride[n];
 376             }
 377         }
 378     }
 379 }
 380
 381
 382 extern void sproduct_r10 (gfc_array_r10 * const restrict,
 383         gfc_array_r10 * const restrict, const index_type * const restrict,
 384         GFC_LOGICAL_4 *);
 385 export_proto(sproduct_r10);
 386
 387 void
 388 sproduct_r10 (gfc_array_r10 * const restrict retarray,
 389         gfc_array_r10 * const restrict array,
 390         const index_type * const restrict pdim,
 391         GFC_LOGICAL_4 * mask)
 392 {
 393   index_type count[GFC_MAX_DIMENSIONS];
 394   index_type extent[GFC_MAX_DIMENSIONS];
 395   index_type dstride[GFC_MAX_DIMENSIONS];
 396   GFC_REAL_10 * restrict dest;
 397   index_type rank;
 398   index_type n;
 399   index_type dim;
 400
 401
 402   if (*mask)
 403     {
 404 #ifdef HAVE_BACK_ARG
 405       product_r10 (retarray, array, pdim, back);
 406 #else
 407       product_r10 (retarray, array, pdim);
 408 #endif
 409       return;
 410     }
 411   /* Make dim zero based to avoid confusion.  */
 412   dim = (*pdim) - 1;
 413   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 414
 415   if (unlikely (dim < 0 || dim > rank))
 416     {
 417       runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
 418                      "is %ld, should be between 1 and %ld",
 419                      (long int) dim + 1, (long int) rank + 1);
 420     }
 421
 422   for (n = 0; n < dim; n++)
 423     {
 424       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 425
 426       if (extent[n] <= 0)
 427         extent[n] = 0;
 428     }
 429
 430   for (n = dim; n < rank; n++)
 431     {
 432       extent[n] =
 433         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 434
 435       if (extent[n] <= 0)
 436         extent[n] = 0;
 437     }
 438
 439   if (retarray->base_addr == NULL)
 440     {
 441       size_t alloc_size, str;
 442
 443       for (n = 0; n < rank; n++)
 444         {
 445           if (n == 0)
 446             str = 1;
 447           else
 448             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 449
 450           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 451
 452         }
 453
 454       retarray->offset = 0;
 455       retarray->dtype.rank = rank;
 456
 457       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 458
 459       if (alloc_size == 0)
 460         {
 461           /* Make sure we have a zero-sized array.  */
 462           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 463           return;
 464         }
 465       else
 466         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 467     }
 468   else
 469     {
 470       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 471         runtime_error ("rank of return array incorrect in"
 472                        " PRODUCT intrinsic: is %ld, should be %ld",
 473                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 474                        (long int) rank);
 475
 476       if (unlikely (compile_options.bounds_check))
 477         {
 478           for (n=0; n < rank; n++)
 479             {
 480               index_type ret_extent;
 481
 482               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 483               if (extent[n] != ret_extent)
 484                 runtime_error ("Incorrect extent in return value of"
 485                                " PRODUCT intrinsic in dimension %ld:"
 486                                " is %ld, should be %ld", (long int) n + 1,
 487                                (long int) ret_extent, (long int) extent[n]);
 488             }
 489         }
 490     }
 491
 492   for (n = 0; n < rank; n++)
 493     {
 494       count[n] = 0;
 495       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 496     }
 497
 498   dest = retarray->base_addr;
 499
 500   while(1)
 501     {
 502       *dest = 1;
 503       count[0]++;
 504       dest += dstride[0];
 505       n = 0;
 506       while (count[n] == extent[n])
 507         {
 508           /* When we get to the end of a dimension, reset it and increment
 509              the next dimension.  */
 510           count[n] = 0;
 511           /* We could precalculate these products, but this is a less
 512              frequently used path so probably not worth it.  */
 513           dest -= dstride[n] * extent[n];
 514           n++;
 515           if (n >= rank)
 516             return;
 517           else
 518             {
 519               count[n]++;
 520               dest += dstride[n];
 521             }
 522         }
 523     }
 524 }
 525
 526 #endif