libgfortran/generated/maxloc1_4_s4.c

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