libgfortran/generated/product_i4.c

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