libgfortran/generated/iall_i4.c

   1 /* Implementation of the IALL intrinsic
   2    Copyright (C) 2010-2023 Free Software Foundation, Inc.
   3    Contributed by Tobias Burnus <burnus@net-b.de>
   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_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
  30
  31
  32 extern void iall_i4 (gfc_array_i4 * const restrict,
  33         gfc_array_i4 * const restrict, const index_type * const restrict);
  34 export_proto(iall_i4);
  35
  36 void
  37 iall_i4 (gfc_array_i4 * const restrict retarray,
  38         gfc_array_i4 * 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_INTEGER_4 * restrict base;
  46   GFC_INTEGER_4 * 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 IALL 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_INTEGER_4));
 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                        " IALL 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", "IALL");
 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_INTEGER_4 * restrict src;
 144       GFC_INTEGER_4 result;
 145       src = base;
 146       {
 147
 148   result = (GFC_INTEGER_4) -1;
 149         if (len <= 0)
 150           *dest = 0;
 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 miall_i4 (gfc_array_i4 * const restrict,
 197         gfc_array_i4 * const restrict, const index_type * const restrict,
 198         gfc_array_l1 * const restrict);
 199 export_proto(miall_i4);
 200
 201 void
 202 miall_i4 (gfc_array_i4 * const restrict retarray,
 203         gfc_array_i4 * 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_INTEGER_4 * restrict dest;
 213   const GFC_INTEGER_4 * 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   if (mask == NULL)
 224     {
 225 #ifdef HAVE_BACK_ARG
 226       iall_i4 (retarray, array, pdim, back);
 227 #else
 228       iall_i4 (retarray, array, pdim);
 229 #endif
 230       return;
 231     }
 232
 233   dim = (*pdim) - 1;
 234   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 235
 236
 237   if (unlikely (dim < 0 || dim > rank))
 238     {
 239       runtime_error ("Dim argument incorrect in IALL intrinsic: "
 240                      "is %ld, should be between 1 and %ld",
 241                      (long int) dim + 1, (long int) rank + 1);
 242     }
 243
 244   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 245   if (len <= 0)
 246     return;
 247
 248   mbase = mask->base_addr;
 249
 250   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 251
 252   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 253 #ifdef HAVE_GFC_LOGICAL_16
 254       || mask_kind == 16
 255 #endif
 256       )
 257     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 258   else
 259     runtime_error ("Funny sized logical array");
 260
 261   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 262   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 263
 264   for (n = 0; n < dim; n++)
 265     {
 266       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 267       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 268       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 269
 270       if (extent[n] < 0)
 271         extent[n] = 0;
 272
 273     }
 274   for (n = dim; n < rank; n++)
 275     {
 276       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 277       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 278       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 279
 280       if (extent[n] < 0)
 281         extent[n] = 0;
 282     }
 283
 284   if (retarray->base_addr == NULL)
 285     {
 286       size_t alloc_size, str;
 287
 288       for (n = 0; n < rank; n++)
 289         {
 290           if (n == 0)
 291             str = 1;
 292           else
 293             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 294
 295           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 296
 297         }
 298
 299       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 300
 301       retarray->offset = 0;
 302       retarray->dtype.rank = rank;
 303
 304       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 305       if (alloc_size == 0)
 306         {
 307           /* Make sure we have a zero-sized array.  */
 308           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 309           return;
 310         }
 311     }
 312   else
 313     {
 314       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 315         runtime_error ("rank of return array incorrect in IALL intrinsic");
 316
 317       if (unlikely (compile_options.bounds_check))
 318         {
 319           bounds_ifunction_return ((array_t *) retarray, extent,
 320                                    "return value", "IALL");
 321           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 322                                 "MASK argument", "IALL");
 323         }
 324     }
 325
 326   for (n = 0; n < rank; n++)
 327     {
 328       count[n] = 0;
 329       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 330       if (extent[n] <= 0)
 331         return;
 332     }
 333
 334   dest = retarray->base_addr;
 335   base = array->base_addr;
 336
 337   while (base)
 338     {
 339       const GFC_INTEGER_4 * restrict src;
 340       const GFC_LOGICAL_1 * restrict msrc;
 341       GFC_INTEGER_4 result;
 342       src = base;
 343       msrc = mbase;
 344       {
 345
 346   result = (GFC_INTEGER_4) -1;
 347         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 348           {
 349
 350   if (*msrc)
 351     result &= *src;
 352           }
 353         *dest = result;
 354       }
 355       /* Advance to the next element.  */
 356       count[0]++;
 357       base += sstride[0];
 358       mbase += mstride[0];
 359       dest += dstride[0];
 360       n = 0;
 361       while (count[n] == extent[n])
 362         {
 363           /* When we get to the end of a dimension, reset it and increment
 364              the next dimension.  */
 365           count[n] = 0;
 366           /* We could precalculate these products, but this is a less
 367              frequently used path so probably not worth it.  */
 368           base -= sstride[n] * extent[n];
 369           mbase -= mstride[n] * extent[n];
 370           dest -= dstride[n] * extent[n];
 371           n++;
 372           if (n >= rank)
 373             {
 374               /* Break out of the loop.  */
 375               base = NULL;
 376               break;
 377             }
 378           else
 379             {
 380               count[n]++;
 381               base += sstride[n];
 382               mbase += mstride[n];
 383               dest += dstride[n];
 384             }
 385         }
 386     }
 387 }
 388
 389
 390 extern void siall_i4 (gfc_array_i4 * const restrict,
 391         gfc_array_i4 * const restrict, const index_type * const restrict,
 392         GFC_LOGICAL_4 *);
 393 export_proto(siall_i4);
 394
 395 void
 396 siall_i4 (gfc_array_i4 * const restrict retarray,
 397         gfc_array_i4 * const restrict array,
 398         const index_type * const restrict pdim,
 399         GFC_LOGICAL_4 * mask)
 400 {
 401   index_type count[GFC_MAX_DIMENSIONS];
 402   index_type extent[GFC_MAX_DIMENSIONS];
 403   index_type dstride[GFC_MAX_DIMENSIONS];
 404   GFC_INTEGER_4 * restrict dest;
 405   index_type rank;
 406   index_type n;
 407   index_type dim;
 408
 409
 410   if (mask == NULL || *mask)
 411     {
 412 #ifdef HAVE_BACK_ARG
 413       iall_i4 (retarray, array, pdim, back);
 414 #else
 415       iall_i4 (retarray, array, pdim);
 416 #endif
 417       return;
 418     }
 419   /* Make dim zero based to avoid confusion.  */
 420   dim = (*pdim) - 1;
 421   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 422
 423   if (unlikely (dim < 0 || dim > rank))
 424     {
 425       runtime_error ("Dim argument incorrect in IALL intrinsic: "
 426                      "is %ld, should be between 1 and %ld",
 427                      (long int) dim + 1, (long int) rank + 1);
 428     }
 429
 430   for (n = 0; n < dim; n++)
 431     {
 432       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 433
 434       if (extent[n] <= 0)
 435         extent[n] = 0;
 436     }
 437
 438   for (n = dim; n < rank; n++)
 439     {
 440       extent[n] =
 441         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 442
 443       if (extent[n] <= 0)
 444         extent[n] = 0;
 445     }
 446
 447   if (retarray->base_addr == NULL)
 448     {
 449       size_t alloc_size, str;
 450
 451       for (n = 0; n < rank; n++)
 452         {
 453           if (n == 0)
 454             str = 1;
 455           else
 456             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 457
 458           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 459
 460         }
 461
 462       retarray->offset = 0;
 463       retarray->dtype.rank = rank;
 464
 465       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 466
 467       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 468       if (alloc_size == 0)
 469         {
 470           /* Make sure we have a zero-sized array.  */
 471           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 472           return;
 473         }
 474     }
 475   else
 476     {
 477       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 478         runtime_error ("rank of return array incorrect in"
 479                        " IALL intrinsic: is %ld, should be %ld",
 480                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 481                        (long int) rank);
 482
 483       if (unlikely (compile_options.bounds_check))
 484         {
 485           for (n=0; n < rank; n++)
 486             {
 487               index_type ret_extent;
 488
 489               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 490               if (extent[n] != ret_extent)
 491                 runtime_error ("Incorrect extent in return value of"
 492                                " IALL intrinsic in dimension %ld:"
 493                                " is %ld, should be %ld", (long int) n + 1,
 494                                (long int) ret_extent, (long int) extent[n]);
 495             }
 496         }
 497     }
 498
 499   for (n = 0; n < rank; n++)
 500     {
 501       count[n] = 0;
 502       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 503     }
 504
 505   dest = retarray->base_addr;
 506
 507   while(1)
 508     {
 509       *dest = 0;
 510       count[0]++;
 511       dest += dstride[0];
 512       n = 0;
 513       while (count[n] == extent[n])
 514         {
 515           /* When we get to the end of a dimension, reset it and increment
 516              the next dimension.  */
 517           count[n] = 0;
 518           /* We could precalculate these products, but this is a less
 519              frequently used path so probably not worth it.  */
 520           dest -= dstride[n] * extent[n];
 521           n++;
 522           if (n >= rank)
 523             return;
 524           else
 525             {
 526               count[n]++;
 527               dest += dstride[n];
 528             }
 529         }
 530     }
 531 }
 532
 533 #endif