libgfortran/generated/findloc1_s1.c

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