libgfortran/generated/findloc1_s1.c

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