libgfortran/generated/findloc0_s1.c

   1
   2 /* Implementation of the FINDLOC intrinsic
   3    Copyright (C) 2018-2024 Free Software Foundation, Inc.
   4    Contributed by Thomas König <tk@tkoenig.net>
   5
   6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libgfortran.h"
  28 #include <assert.h>
  29
  30 #if defined (HAVE_GFC_UINTEGER_1)
  31 extern void findloc0_s1 (gfc_array_index_type * const restrict retarray,
  32                         gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
  33                          GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
  34
  35 export_proto(findloc0_s1);
  36
  37 void
  38 findloc0_s1 (gfc_array_index_type * const restrict retarray,
  39             gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
  40             GFC_LOGICAL_4 back, 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;
  46   const GFC_UINTEGER_1 *base;
  47   index_type * restrict dest;
  48   index_type rank;
  49   index_type n;
  50   index_type sz;
  51
  52   rank = GFC_DESCRIPTOR_RANK (array);
  53   if (rank <= 0)
  54     runtime_error ("Rank of array needs to be > 0");
  55
  56   if (retarray->base_addr == NULL)
  57     {
  58       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  59       retarray->dtype.rank = 1;
  60       retarray->offset = 0;
  61       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
  62     }
  63   else
  64     {
  65       if (unlikely (compile_options.bounds_check))
  66         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  67                                 "FINDLOC");
  68     }
  69
  70   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  71   dest = retarray->base_addr;
  72
  73   /* Set the return value.  */
  74   for (n = 0; n < rank; n++)
  75     dest[n * dstride] = 0;
  76
  77   sz = 1;
  78   for (n = 0; n < rank; n++)
  79     {
  80       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  81       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  82       sz *= extent[n];
  83       if (extent[n] <= 0)
  84         return;
  85     }
  86
  87     for (n = 0; n < rank; n++)
  88       count[n] = 0;
  89
  90   if (back)
  91     {
  92       base = array->base_addr + (sz - 1) * len_array;
  93
  94       while (1)
  95         {
  96           do
  97             {
  98               if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
  99                 {
 100                   for (n = 0; n < rank; n++)
 101                     dest[n * dstride] = extent[n] - count[n];
 102
 103                   return;
 104                 }
 105               base -= sstride[0] * len_array;
 106             } while(++count[0] != extent[0]);
 107
 108           n = 0;
 109           do
 110             {
 111               /* When we get to the end of a dimension, reset it and increment
 112                  the next dimension.  */
 113               count[n] = 0;
 114               /* We could precalculate these products, but this is a less
 115                  frequently used path so probably not worth it.  */
 116               base += sstride[n] * extent[n] * len_array;
 117               n++;
 118               if (n >= rank)
 119                 return;
 120               else
 121                 {
 122                   count[n]++;
 123                   base -= sstride[n] * len_array;
 124                 }
 125             } while (count[n] == extent[n]);
 126         }
 127     }
 128   else
 129     {
 130       base = array->base_addr;
 131       while (1)
 132         {
 133           do
 134             {
 135               if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
 136                 {
 137                   for (n = 0; n < rank; n++)
 138                     dest[n * dstride] = count[n] + 1;
 139
 140                   return;
 141                 }
 142               base += sstride[0] * len_array;
 143             } while(++count[0] != extent[0]);
 144
 145           n = 0;
 146           do
 147             {
 148               /* When we get to the end of a dimension, reset it and increment
 149                  the next dimension.  */
 150               count[n] = 0;
 151               /* We could precalculate these products, but this is a less
 152                  frequently used path so probably not worth it.  */
 153               base -= sstride[n] * extent[n] * len_array;
 154               n++;
 155               if (n >= rank)
 156                 return;
 157               else
 158                 {
 159                   count[n]++;
 160                   base += sstride[n] * len_array;
 161                 }
 162             } while (count[n] == extent[n]);
 163         }
 164     }
 165   return;
 166 }
 167
 168 extern void mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
 169                         gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
 170                          gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
 171                          gfc_charlen_type len_value);
 172 export_proto(mfindloc0_s1);
 173
 174 void
 175 mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
 176             gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
 177             gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
 178             gfc_charlen_type len_array, gfc_charlen_type len_value)
 179 {
 180   index_type count[GFC_MAX_DIMENSIONS];
 181   index_type extent[GFC_MAX_DIMENSIONS];
 182   index_type sstride[GFC_MAX_DIMENSIONS];
 183   index_type mstride[GFC_MAX_DIMENSIONS];
 184   index_type dstride;
 185   const GFC_UINTEGER_1 *base;
 186   index_type * restrict dest;
 187   GFC_LOGICAL_1 *mbase;
 188   index_type rank;
 189   index_type n;
 190   int mask_kind;
 191   index_type sz;
 192
 193   rank = GFC_DESCRIPTOR_RANK (array);
 194   if (rank <= 0)
 195     runtime_error ("Rank of array needs to be > 0");
 196
 197   if (retarray->base_addr == NULL)
 198     {
 199       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 200       retarray->dtype.rank = 1;
 201       retarray->offset = 0;
 202       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
 203     }
 204   else
 205     {
 206       if (unlikely (compile_options.bounds_check))
 207         {
 208           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 209                                   "FINDLOC");
 210           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 211                                 "MASK argument", "FINDLOC");
 212         }
 213     }
 214
 215   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 216
 217   mbase = mask->base_addr;
 218
 219   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 220 #ifdef HAVE_GFC_LOGICAL_16
 221       || mask_kind == 16
 222 #endif
 223       )
 224     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 225   else
 226     internal_error (NULL, "Funny sized logical array");
 227
 228   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 229   dest = retarray->base_addr;
 230
 231   /* Set the return value.  */
 232   for (n = 0; n < rank; n++)
 233     dest[n * dstride] = 0;
 234
 235   sz = 1;
 236   for (n = 0; n < rank; n++)
 237     {
 238       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 239       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 240       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 241       sz *= extent[n];
 242       if (extent[n] <= 0)
 243         return;
 244     }
 245
 246     for (n = 0; n < rank; n++)
 247       count[n] = 0;
 248
 249   if (back)
 250     {
 251       base = array->base_addr + (sz - 1) * len_array;
 252       mbase = mbase + (sz - 1) * mask_kind;
 253       while (1)
 254         {
 255           do
 256             {
 257               if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
 258                 {
 259                   for (n = 0; n < rank; n++)
 260                     dest[n * dstride] = extent[n] - count[n];
 261
 262                   return;
 263                 }
 264               base -= sstride[0] * len_array;
 265               mbase -= mstride[0];
 266             } while(++count[0] != extent[0]);
 267
 268           n = 0;
 269           do
 270             {
 271               /* When we get to the end of a dimension, reset it and increment
 272                  the next dimension.  */
 273               count[n] = 0;
 274               /* We could precalculate these products, but this is a less
 275                  frequently used path so probably not worth it.  */
 276               base += sstride[n] * extent[n] * len_array;
 277               mbase -= mstride[n] * extent[n];
 278               n++;
 279               if (n >= rank)
 280                 return;
 281               else
 282                 {
 283                   count[n]++;
 284                   base -= sstride[n] * len_array;
 285                   mbase += mstride[n];
 286                 }
 287             } while (count[n] == extent[n]);
 288         }
 289     }
 290   else
 291     {
 292       base = array->base_addr;
 293       while (1)
 294         {
 295           do
 296             {
 297               if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
 298                 {
 299                   for (n = 0; n < rank; n++)
 300                     dest[n * dstride] = count[n] + 1;
 301
 302                   return;
 303                 }
 304               base += sstride[0] * len_array;
 305               mbase += mstride[0];
 306             } while(++count[0] != extent[0]);
 307
 308           n = 0;
 309           do
 310             {
 311               /* When we get to the end of a dimension, reset it and increment
 312                  the next dimension.  */
 313               count[n] = 0;
 314               /* We could precalculate these products, but this is a less
 315                  frequently used path so probably not worth it.  */
 316               base -= sstride[n] * extent[n] * len_array;
 317               mbase -= mstride[n] * extent[n];
 318               n++;
 319               if (n >= rank)
 320                 return;
 321               else
 322                 {
 323                   count[n]++;
 324                   base += sstride[n]* len_array;
 325                   mbase += mstride[n];
 326                 }
 327             } while (count[n] == extent[n]);
 328         }
 329     }
 330   return;
 331 }
 332
 333 extern void sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
 334                         gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
 335                          GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
 336                          gfc_charlen_type len_value);
 337 export_proto(sfindloc0_s1);
 338
 339 void
 340 sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
 341             gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
 342             GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
 343             gfc_charlen_type len_value)
 344 {
 345   index_type rank;
 346   index_type dstride;
 347   index_type * restrict dest;
 348   index_type n;
 349
 350   if (mask == NULL || *mask)
 351     {
 352       findloc0_s1 (retarray, array, value, back, len_array, len_value);
 353       return;
 354     }
 355
 356   rank = GFC_DESCRIPTOR_RANK (array);
 357
 358   if (rank <= 0)
 359     internal_error (NULL, "Rank of array needs to be > 0");
 360
 361   if (retarray->base_addr == NULL)
 362     {
 363       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 364       retarray->dtype.rank = 1;
 365       retarray->offset = 0;
 366       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
 367     }
 368   else if (unlikely (compile_options.bounds_check))
 369     {
 370        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 371                                "FINDLOC");
 372     }
 373
 374   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 375   dest = retarray->base_addr;
 376   for (n = 0; n<rank; n++)
 377     dest[n * dstride] = 0 ;
 378 }
 379
 380 #endif
 381
 382
 383