libgfortran/generated/minloc1_8_s4.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_4) && defined (HAVE_GFC_INTEGER_8)
  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 minloc1_8_s4 (gfc_array_i8 * const restrict,
  46         gfc_array_s4 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
  47         gfc_charlen_type);
  48 export_proto(minloc1_8_s4);
  49
  50 void
  51 minloc1_8_s4 (gfc_array_i8 * 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_8 * 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_8));
 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                        " MINLOC 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", "MINLOC");
 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_8 result;
 160       src = base;
 161       {
 162
 163         const GFC_UINTEGER_4 *minval;
 164         minval = 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 (minval == NULL || (back ? compare_fcn (src, minval, string_len) <= 0 :
 174                                               compare_fcn (src, minval, string_len) < 0))
 175                   {
 176                     minval = src;
 177                     result = (GFC_INTEGER_8)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 mminloc1_8_s4 (gfc_array_i8 * 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(mminloc1_8_s4);
 220
 221 void
 222 mminloc1_8_s4 (gfc_array_i8 * 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_8 * 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       minloc1_8_s4 (retarray, array, pdim, back, string_len);
 248 #else
 249       minloc1_8_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 MINLOC 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     return;
 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       if (alloc_size == 0)
 326         {
 327           /* Make sure we have a zero-sized array.  */
 328           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 329           return;
 330         }
 331       else
 332         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
 333
 334     }
 335   else
 336     {
 337       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 338         runtime_error ("rank of return array incorrect in MINLOC intrinsic");
 339
 340       if (unlikely (compile_options.bounds_check))
 341         {
 342           bounds_ifunction_return ((array_t *) retarray, extent,
 343                                    "return value", "MINLOC");
 344           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 345                                 "MASK argument", "MINLOC");
 346         }
 347     }
 348
 349   for (n = 0; n < rank; n++)
 350     {
 351       count[n] = 0;
 352       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 353       if (extent[n] <= 0)
 354         return;
 355     }
 356
 357   dest = retarray->base_addr;
 358   base = array->base_addr;
 359
 360   while (base)
 361     {
 362       const GFC_UINTEGER_4 * restrict src;
 363       const GFC_LOGICAL_1 * restrict msrc;
 364       GFC_INTEGER_8 result;
 365       src = base;
 366       msrc = mbase;
 367       {
 368
 369         const GFC_UINTEGER_4 *minval;
 370         minval = base;
 371         result = 0;
 372         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 373           {
 374
 375                 if (*msrc)
 376                       {
 377                         minval = src;
 378                         result = (GFC_INTEGER_8)n + 1;
 379                         break;
 380                       }
 381             }
 382             for (; n < len; n++, src += delta, msrc += mdelta)
 383               {
 384                 if (*msrc && (back ? compare_fcn (src, minval, string_len) <= 0 :
 385                                      compare_fcn (src, minval, string_len) < 0))
 386                   {
 387                     minval = src;
 388                     result = (GFC_INTEGER_8)n + 1;
 389                   }
 390
 391           }
 392         *dest = result;
 393       }
 394       /* Advance to the next element.  */
 395       count[0]++;
 396       base += sstride[0];
 397       mbase += mstride[0];
 398       dest += dstride[0];
 399       n = 0;
 400       while (count[n] == extent[n])
 401         {
 402           /* When we get to the end of a dimension, reset it and increment
 403              the next dimension.  */
 404           count[n] = 0;
 405           /* We could precalculate these products, but this is a less
 406              frequently used path so probably not worth it.  */
 407           base -= sstride[n] * extent[n];
 408           mbase -= mstride[n] * extent[n];
 409           dest -= dstride[n] * extent[n];
 410           n++;
 411           if (n >= rank)
 412             {
 413               /* Break out of the loop.  */
 414               base = NULL;
 415               break;
 416             }
 417           else
 418             {
 419               count[n]++;
 420               base += sstride[n];
 421               mbase += mstride[n];
 422               dest += dstride[n];
 423             }
 424         }
 425     }
 426 }
 427
 428
 429 extern void sminloc1_8_s4 (gfc_array_i8 * const restrict,
 430         gfc_array_s4 * const restrict, const index_type * const restrict,
 431         GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
 432 export_proto(sminloc1_8_s4);
 433
 434 void
 435 sminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
 436         gfc_array_s4 * const restrict array,
 437         const index_type * const restrict pdim,
 438         GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
 439 {
 440   index_type count[GFC_MAX_DIMENSIONS];
 441   index_type extent[GFC_MAX_DIMENSIONS];
 442   index_type dstride[GFC_MAX_DIMENSIONS];
 443   GFC_INTEGER_8 * restrict dest;
 444   index_type rank;
 445   index_type n;
 446   index_type dim;
 447
 448
 449   if (mask == NULL || *mask)
 450     {
 451 #ifdef HAVE_BACK_ARG
 452       minloc1_8_s4 (retarray, array, pdim, back, string_len);
 453 #else
 454       minloc1_8_s4 (retarray, array, pdim, string_len);
 455 #endif
 456       return;
 457     }
 458   /* Make dim zero based to avoid confusion.  */
 459   dim = (*pdim) - 1;
 460   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 461
 462   if (unlikely (dim < 0 || dim > rank))
 463     {
 464       runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
 465                      "is %ld, should be between 1 and %ld",
 466                      (long int) dim + 1, (long int) rank + 1);
 467     }
 468
 469   for (n = 0; n < dim; n++)
 470     {
 471       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
 472
 473       if (extent[n] <= 0)
 474         extent[n] = 0;
 475     }
 476
 477   for (n = dim; n < rank; n++)
 478     {
 479       extent[n] =
 480         GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
 481
 482       if (extent[n] <= 0)
 483         extent[n] = 0;
 484     }
 485
 486   if (retarray->base_addr == NULL)
 487     {
 488       size_t alloc_size, str;
 489
 490       for (n = 0; n < rank; n++)
 491         {
 492           if (n == 0)
 493             str = 1;
 494           else
 495             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 496
 497           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 498
 499         }
 500
 501       retarray->offset = 0;
 502       retarray->dtype.rank = rank;
 503
 504       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 505
 506       if (alloc_size == 0)
 507         {
 508           /* Make sure we have a zero-sized array.  */
 509           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 510           return;
 511         }
 512       else
 513         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
 514     }
 515   else
 516     {
 517       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 518         runtime_error ("rank of return array incorrect in"
 519                        " MINLOC intrinsic: is %ld, should be %ld",
 520                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 521                        (long int) rank);
 522
 523       if (unlikely (compile_options.bounds_check))
 524         {
 525           for (n=0; n < rank; n++)
 526             {
 527               index_type ret_extent;
 528
 529               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 530               if (extent[n] != ret_extent)
 531                 runtime_error ("Incorrect extent in return value of"
 532                                " MINLOC intrinsic in dimension %ld:"
 533                                " is %ld, should be %ld", (long int) n + 1,
 534                                (long int) ret_extent, (long int) extent[n]);
 535             }
 536         }
 537     }
 538
 539   for (n = 0; n < rank; n++)
 540     {
 541       count[n] = 0;
 542       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 543     }
 544
 545   dest = retarray->base_addr;
 546
 547   while(1)
 548     {
 549       *dest = 0;
 550       count[0]++;
 551       dest += dstride[0];
 552       n = 0;
 553       while (count[n] == extent[n])
 554         {
 555           /* When we get to the end of a dimension, reset it and increment
 556              the next dimension.  */
 557           count[n] = 0;
 558           /* We could precalculate these products, but this is a less
 559              frequently used path so probably not worth it.  */
 560           dest -= dstride[n] * extent[n];
 561           n++;
 562           if (n >= rank)
 563             return;
 564           else
 565             {
 566               count[n]++;
 567               dest += dstride[n];
 568             }
 569         }
 570     }
 571 }
 572
 573 #endif