libgfortran/m4/ifindloc0.m4

   1 `/* Implementation of the FINDLOC intrinsic
   2    Copyright (C) 2018-2023 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_'atype_name`)
  30 'header1`
  31 {
  32   index_type count[GFC_MAX_DIMENSIONS];
  33   index_type extent[GFC_MAX_DIMENSIONS];
  34   index_type sstride[GFC_MAX_DIMENSIONS];
  35   index_type dstride;
  36   const 'atype_name` *base;
  37   index_type * restrict dest;
  38   index_type rank;
  39   index_type n;
  40   index_type sz;
  41
  42   rank = GFC_DESCRIPTOR_RANK (array);
  43   if (rank <= 0)
  44     runtime_error ("Rank of array needs to be > 0");
  45
  46   if (retarray->base_addr == NULL)
  47     {
  48       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  49       retarray->dtype.rank = 1;
  50       retarray->offset = 0;
  51       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
  52     }
  53   else
  54     {
  55       if (unlikely (compile_options.bounds_check))
  56         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  57                                 "FINDLOC");
  58     }
  59
  60   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  61   dest = retarray->base_addr;
  62
  63   /* Set the return value.  */
  64   for (n = 0; n < rank; n++)
  65     dest[n * dstride] = 0;
  66
  67   sz = 1;
  68   for (n = 0; n < rank; n++)
  69     {
  70       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  71       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  72       sz *= extent[n];
  73       if (extent[n] <= 0)
  74         return;
  75     }
  76
  77     for (n = 0; n < rank; n++)
  78       count[n] = 0;
  79
  80   if (back)
  81     {
  82       base = array->base_addr + (sz - 1) * 'base_mult`'`;
  83
  84       while (1)
  85         {
  86           do
  87             {
  88               if (unlikely('comparison`))
  89                 {
  90                   for (n = 0; n < rank; n++)
  91                     dest[n * dstride] = extent[n] - count[n];
  92
  93                   return;
  94                 }
  95               base -= sstride[0] * 'base_mult`'`;
  96             } while(++count[0] != extent[0]);
  97
  98           n = 0;
  99           do
 100             {
 101               /* When we get to the end of a dimension, reset it and increment
 102                  the next dimension.  */
 103               count[n] = 0;
 104               /* We could precalculate these products, but this is a less
 105                  frequently used path so probably not worth it.  */
 106               base += sstride[n] * extent[n] * 'base_mult`'`;
 107               n++;
 108               if (n >= rank)
 109                 return;
 110               else
 111                 {
 112                   count[n]++;
 113                   base -= sstride[n] * 'base_mult`'`;
 114                 }
 115             } while (count[n] == extent[n]);
 116         }
 117     }
 118   else
 119     {
 120       base = array->base_addr;
 121       while (1)
 122         {
 123           do
 124             {
 125               if (unlikely('comparison`))
 126                 {
 127                   for (n = 0; n < rank; n++)
 128                     dest[n * dstride] = count[n] + 1;
 129
 130                   return;
 131                 }
 132               base += sstride[0] * 'base_mult`'`;
 133             } while(++count[0] != extent[0]);
 134
 135           n = 0;
 136           do
 137             {
 138               /* When we get to the end of a dimension, reset it and increment
 139                  the next dimension.  */
 140               count[n] = 0;
 141               /* We could precalculate these products, but this is a less
 142                  frequently used path so probably not worth it.  */
 143               base -= sstride[n] * extent[n] * 'base_mult`'`;
 144               n++;
 145               if (n >= rank)
 146                 return;
 147               else
 148                 {
 149                   count[n]++;
 150                   base += sstride[n] * 'base_mult`'`;
 151                 }
 152             } while (count[n] == extent[n]);
 153         }
 154     }
 155   return;
 156 }
 157
 158 'header2`
 159 {
 160   index_type count[GFC_MAX_DIMENSIONS];
 161   index_type extent[GFC_MAX_DIMENSIONS];
 162   index_type sstride[GFC_MAX_DIMENSIONS];
 163   index_type mstride[GFC_MAX_DIMENSIONS];
 164   index_type dstride;
 165   const 'atype_name` *base;
 166   index_type * restrict dest;
 167   GFC_LOGICAL_1 *mbase;
 168   index_type rank;
 169   index_type n;
 170   int mask_kind;
 171   index_type sz;
 172
 173   rank = GFC_DESCRIPTOR_RANK (array);
 174   if (rank <= 0)
 175     runtime_error ("Rank of array needs to be > 0");
 176
 177   if (retarray->base_addr == NULL)
 178     {
 179       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 180       retarray->dtype.rank = 1;
 181       retarray->offset = 0;
 182       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
 183     }
 184   else
 185     {
 186       if (unlikely (compile_options.bounds_check))
 187         {
 188           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 189                                   "FINDLOC");
 190           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 191                                 "MASK argument", "FINDLOC");
 192         }
 193     }
 194
 195   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 196
 197   mbase = mask->base_addr;
 198
 199   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 200 #ifdef HAVE_GFC_LOGICAL_16
 201       || mask_kind == 16
 202 #endif
 203       )
 204     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 205   else
 206     internal_error (NULL, "Funny sized logical array");
 207
 208   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 209   dest = retarray->base_addr;
 210
 211   /* Set the return value.  */
 212   for (n = 0; n < rank; n++)
 213     dest[n * dstride] = 0;
 214
 215   sz = 1;
 216   for (n = 0; n < rank; n++)
 217     {
 218       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 219       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 220       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 221       sz *= extent[n];
 222       if (extent[n] <= 0)
 223         return;
 224     }
 225
 226     for (n = 0; n < rank; n++)
 227       count[n] = 0;
 228
 229   if (back)
 230     {
 231       base = array->base_addr + (sz - 1) * 'base_mult`'`;
 232       mbase = mbase + (sz - 1) * mask_kind;
 233       while (1)
 234         {
 235           do
 236             {
 237               if (unlikely(*mbase && 'comparison`))
 238                 {
 239                   for (n = 0; n < rank; n++)
 240                     dest[n * dstride] = extent[n] - count[n];
 241
 242                   return;
 243                 }
 244               base -= sstride[0] * 'base_mult`'`;
 245               mbase -= mstride[0];
 246             } while(++count[0] != extent[0]);
 247
 248           n = 0;
 249           do
 250             {
 251               /* When we get to the end of a dimension, reset it and increment
 252                  the next dimension.  */
 253               count[n] = 0;
 254               /* We could precalculate these products, but this is a less
 255                  frequently used path so probably not worth it.  */
 256               base += sstride[n] * extent[n] * 'base_mult`'`;
 257               mbase -= mstride[n] * extent[n];
 258               n++;
 259               if (n >= rank)
 260                 return;
 261               else
 262                 {
 263                   count[n]++;
 264                   base -= sstride[n] * 'base_mult`'`;
 265                   mbase += mstride[n];
 266                 }
 267             } while (count[n] == extent[n]);
 268         }
 269     }
 270   else
 271     {
 272       base = array->base_addr;
 273       while (1)
 274         {
 275           do
 276             {
 277               if (unlikely(*mbase && 'comparison`))
 278                 {
 279                   for (n = 0; n < rank; n++)
 280                     dest[n * dstride] = count[n] + 1;
 281
 282                   return;
 283                 }
 284               base += sstride[0] * 'base_mult`'`;
 285               mbase += mstride[0];
 286             } while(++count[0] != extent[0]);
 287
 288           n = 0;
 289           do
 290             {
 291               /* When we get to the end of a dimension, reset it and increment
 292                  the next dimension.  */
 293               count[n] = 0;
 294               /* We could precalculate these products, but this is a less
 295                  frequently used path so probably not worth it.  */
 296               base -= sstride[n] * extent[n] * 'base_mult`'`;
 297               mbase -= mstride[n] * extent[n];
 298               n++;
 299               if (n >= rank)
 300                 return;
 301               else
 302                 {
 303                   count[n]++;
 304                   base += sstride[n]* 'base_mult`'`;
 305                   mbase += mstride[n];
 306                 }
 307             } while (count[n] == extent[n]);
 308         }
 309     }
 310   return;
 311 }
 312
 313 'header3`
 314 {
 315   index_type rank;
 316   index_type dstride;
 317   index_type * restrict dest;
 318   index_type n;
 319
 320   if (mask == NULL || *mask)
 321     {
 322       findloc0_'atype_code` (retarray, array, value, back'len_arg`);
 323       return;
 324     }
 325
 326   rank = GFC_DESCRIPTOR_RANK (array);
 327
 328   if (rank <= 0)
 329     internal_error (NULL, "Rank of array needs to be > 0");
 330
 331   if (retarray->base_addr == NULL)
 332     {
 333       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 334       retarray->dtype.rank = 1;
 335       retarray->offset = 0;
 336       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
 337     }
 338   else if (unlikely (compile_options.bounds_check))
 339     {
 340        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 341                                "FINDLOC");
 342     }
 343
 344   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 345   dest = retarray->base_addr;
 346   for (n = 0; n<rank; n++)
 347     dest[n * dstride] = 0 ;
 348 }
 349
 350 #endif'