libgfortran/generated/minloc1_4_s1.c

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