libgfortran/generated/maxloc1_16_s4.c

   1 /* Implementation of the MAXLOC intrinsic
   2    Copyright (C) 2017-2023 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_16)
  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_16_s4 (gfc_array_i16 * 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_16_s4);
  49
  50 void
  51 maxloc1_16_s4 (gfc_array_i16 * 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_16 * 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_16));
 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_16 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_16)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_16_s4 (gfc_array_i16 * 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_16_s4);
 220
 221 void
 222 mmaxloc1_16_s4 (gfc_array_i16 * 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_16 * 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   if (mask == NULL)
 245     {
 246 #ifdef HAVE_BACK_ARG
 247       maxloc1_16_s4 (retarray, array, pdim, back, string_len);
 248 #else
 249       maxloc1_16_s4 (retarray, array, pdim, string_len);
 250 #endif
 251       return;
 252     }
 253
 254   dim = (*pdim) - 1;
 255   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 256
 257
 258   if (unlikely (dim < 0 || dim > rank))
 259     {
 260       runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 261                      "is %ld, should be between 1 and %ld",
 262                      (long int) dim + 1, (long int) rank + 1);
 263     }
 264
 265   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 266   if (len < 0)
 267     len = 0;
 268
 269   mbase = mask->base_addr;
 270
 271   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 272
 273   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 274 #ifdef HAVE_GFC_LOGICAL_16
 275       || mask_kind == 16
 276 #endif
 277       )
 278     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 279   else
 280     runtime_error ("Funny sized logical array");
 281
 282   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
 283   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 284
 285   for (n = 0; n < dim; n++)
 286     {
 287       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
 288       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 289       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 290
 291       if (extent[n] < 0)
 292         extent[n] = 0;
 293
 294     }
 295   for (n = dim; n < rank; n++)
 296     {
 297       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
 298       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 299       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 300
 301       if (extent[n] < 0)
 302         extent[n] = 0;
 303     }
 304
 305   if (retarray->base_addr == NULL)
 306     {
 307       size_t alloc_size, str;
 308
 309       for (n = 0; n < rank; n++)
 310         {
 311           if (n == 0)
 312             str = 1;
 313           else
 314             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 315
 316           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 317
 318         }
 319
 320       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 321
 322       retarray->offset = 0;
 323       retarray->dtype.rank = rank;
 324
 325       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
 326       if (alloc_size == 0)
 327         {
 328           /* Make sure we have a zero-sized array.  */
 329           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 330           return;
 331         }
 332     }
 333   else
 334     {
 335       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 336         runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
 337
 338       if (unlikely (compile_options.bounds_check))
 339         {
 340           bounds_ifunction_return ((array_t *) retarray, extent,
 341                                    "return value", "MAXLOC");
 342           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 343                                 "MASK argument", "MAXLOC");
 344         }
 345     }
 346
 347   for (n = 0; n < rank; n++)
 348     {
 349       count[n] = 0;
 350       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 351       if (extent[n] <= 0)
 352         return;
 353     }
 354
 355   dest = retarray->base_addr;
 356   base = array->base_addr;
 357
 358   while (base)
 359     {
 360       const GFC_UINTEGER_4 * restrict src;
 361       const GFC_LOGICAL_1 * restrict msrc;
 362       GFC_INTEGER_16 result;
 363       src = base;
 364       msrc = mbase;
 365       {
 366
 367         const GFC_UINTEGER_4 *maxval;
 368         maxval = base;
 369         result = 0;
 370         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 371           {
 372
 373                 if (*msrc)
 374                       {
 375                         maxval = src;
 376                         result = (GFC_INTEGER_16)n + 1;
 377                         break;
 378                       }
 379             }
 380             for (; n < len; n++, src += delta, msrc += mdelta)
 381               {
 382                 if (*msrc && (back ? compare_fcn (src, maxval, string_len) >= 0 :
 383                                      compare_fcn (src, maxval, string_len) > 0))
 384                   {
 385                     maxval = src;
 386                     result = (GFC_INTEGER_16)n + 1;
 387                   }
 388
 389           }
 390         *dest = result;
 391       }
 392       /* Advance to the next element.  */
 393       count[0]++;
 394       base += sstride[0];
 395       mbase += mstride[0];
 396       dest += dstride[0];
 397       n = 0;
 398       while (count[n] == extent[n])
 399         {
 400           /* When we get to the end of a dimension, reset it and increment
 401              the next dimension.  */
 402           count[n] = 0;
 403           /* We could precalculate these products, but this is a less
 404              frequently used path so probably not worth it.  */
 405           base -= sstride[n] * extent[n];
 406           mbase -= mstride[n] * extent[n];
 407           dest -= dstride[n] * extent[n];
 408           n++;
 409           if (n >= rank)
 410             {
 411               /* Break out of the loop.  */
 412               base = NULL;
 413               break;
 414             }
 415           else
 416             {
 417               count[n]++;
 418               base += sstride[n];
 419               mbase += mstride[n];
 420               dest += dstride[n];
 421             }
 422         }
 423     }
 424 }
 425
 426
 427 extern void smaxloc1_16_s4 (gfc_array_i16 * const restrict,
 428         gfc_array_s4 * const restrict, const index_type * const restrict,
 429         GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
 430 export_proto(smaxloc1_16_s4);
 431
 432 void
 433 smaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
 434         gfc_array_s4 * const restrict array,
 435         const index_type * const restrict pdim,
 436         GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
 437 {
 438   index_type count[GFC_MAX_DIMENSIONS];
 439   index_type extent[GFC_MAX_DIMENSIONS];
 440   index_type dstride[GFC_MAX_DIMENSIONS];
 441   GFC_INTEGER_16 * restrict dest;
 442   index_type rank;
 443   index_type n;
 444   index_type dim;
 445
 446
 447   if (mask == NULL || *mask)
 448     {
 449 #ifdef HAVE_BACK_ARG
 450       maxloc1_16_s4 (retarray, array, pdim, back, string_len);
 451 #else
 452       maxloc1_16_s4 (retarray, array, pdim, string_len);
 453 #endif
 454       return;
 455     }
 456   /* Make dim zero based to avoid confusion.  */
 457   dim = (*pdim) - 1;
 458   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 459
 460   if (unlikely (dim < 0 || dim > rank))
 461     {
 462       runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 463                      "is %ld, should be between 1 and %ld",
 464                      (long int) dim + 1, (long int) rank + 1);
 465     }
 466
 467   for (n = 0; n < dim; n++)
 468     {
 469       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
 470
 471       if (extent[n] <= 0)
 472         extent[n] = 0;
 473     }
 474
 475   for (n = dim; n < rank; n++)
 476     {
 477       extent[n] =
 478         GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
 479
 480       if (extent[n] <= 0)
 481         extent[n] = 0;
 482     }
 483
 484   if (retarray->base_addr == NULL)
 485     {
 486       size_t alloc_size, str;
 487
 488       for (n = 0; n < rank; n++)
 489         {
 490           if (n == 0)
 491             str = 1;
 492           else
 493             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 494
 495           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 496
 497         }
 498
 499       retarray->offset = 0;
 500       retarray->dtype.rank = rank;
 501
 502       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 503
 504       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
 505       if (alloc_size == 0)
 506         {
 507           /* Make sure we have a zero-sized array.  */
 508           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 509           return;
 510         }
 511     }
 512   else
 513     {
 514       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 515         runtime_error ("rank of return array incorrect in"
 516                        " MAXLOC intrinsic: is %ld, should be %ld",
 517                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 518                        (long int) rank);
 519
 520       if (unlikely (compile_options.bounds_check))
 521         {
 522           for (n=0; n < rank; n++)
 523             {
 524               index_type ret_extent;
 525
 526               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 527               if (extent[n] != ret_extent)
 528                 runtime_error ("Incorrect extent in return value of"
 529                                " MAXLOC intrinsic in dimension %ld:"
 530                                " is %ld, should be %ld", (long int) n + 1,
 531                                (long int) ret_extent, (long int) extent[n]);
 532             }
 533         }
 534     }
 535
 536   for (n = 0; n < rank; n++)
 537     {
 538       count[n] = 0;
 539       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 540     }
 541
 542   dest = retarray->base_addr;
 543
 544   while(1)
 545     {
 546       *dest = 0;
 547       count[0]++;
 548       dest += dstride[0];
 549       n = 0;
 550       while (count[n] == extent[n])
 551         {
 552           /* When we get to the end of a dimension, reset it and increment
 553              the next dimension.  */
 554           count[n] = 0;
 555           /* We could precalculate these products, but this is a less
 556              frequently used path so probably not worth it.  */
 557           dest -= dstride[n] * extent[n];
 558           n++;
 559           if (n >= rank)
 560             return;
 561           else
 562             {
 563               count[n]++;
 564               dest += dstride[n];
 565             }
 566         }
 567     }
 568 }
 569
 570 #endif