libgfortran/generated/product_i8.c

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