libgfortran/generated/product_i4.c

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