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