libgfortran/m4/ifindloc1.m4

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