libgfortran/generated/maxval1_s1.c

   1 /* Implementation of the MAXVAL intrinsic
   2    Copyright (C) 2017-2024 Free Software Foundation, Inc.
   3    Contributed by Thomas Koenig
   4
   5 This file is part of the GNU Fortran 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
  28
  29 #if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1)
  30
  31 #include <string.h>
  32 #include <assert.h>
  33
  34 static inline int
  35 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
  36 {
  37   if (sizeof (GFC_UINTEGER_1) == 1)
  38     return memcmp (a, b, n);
  39   else
  40     return memcmp_char4 (a, b, n);
  41 }
  42
  43 extern void maxval1_s1 (gfc_array_s1 * const restrict,
  44         gfc_charlen_type, gfc_array_s1 * const restrict,
  45         const index_type * const restrict, gfc_charlen_type);
  46 export_proto(maxval1_s1);
  47
  48 void
  49 maxval1_s1 (gfc_array_s1 * const restrict retarray,
  50         gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
  51         const index_type * const restrict pdim, gfc_charlen_type string_len)
  52 {
  53   index_type count[GFC_MAX_DIMENSIONS];
  54   index_type extent[GFC_MAX_DIMENSIONS];
  55   index_type sstride[GFC_MAX_DIMENSIONS];
  56   index_type dstride[GFC_MAX_DIMENSIONS];
  57   const GFC_UINTEGER_1 * restrict base;
  58   GFC_UINTEGER_1 * restrict dest;
  59   index_type rank;
  60   index_type n;
  61   index_type len;
  62   index_type delta;
  63   index_type dim;
  64   int continue_loop;
  65
  66   assert (xlen == string_len);
  67   /* Make dim zero based to avoid confusion.  */
  68   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  69   dim = (*pdim) - 1;
  70
  71   if (unlikely (dim < 0 || dim > rank))
  72     {
  73       runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
  74                      "is %ld, should be between 1 and %ld",
  75                      (long int) dim + 1, (long int) rank + 1);
  76     }
  77
  78   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  79   if (len < 0)
  80     len = 0;
  81
  82   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
  83
  84   for (n = 0; n < dim; n++)
  85     {
  86       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
  87       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  88
  89       if (extent[n] < 0)
  90         extent[n] = 0;
  91     }
  92   for (n = dim; n < rank; n++)
  93     {
  94       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
  95       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  96
  97       if (extent[n] < 0)
  98         extent[n] = 0;
  99     }
 100
 101   if (retarray->base_addr == NULL)
 102     {
 103       size_t alloc_size, str;
 104
 105       for (n = 0; n < rank; n++)
 106         {
 107           if (n == 0)
 108             str = 1;
 109           else
 110             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 111
 112           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 113
 114         }
 115
 116       retarray->offset = 0;
 117       retarray->dtype.rank = rank;
 118
 119       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
 120                  * string_len;
 121
 122       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
 123       if (alloc_size == 0)
 124         return;
 125     }
 126   else
 127     {
 128       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 129         runtime_error ("rank of return array incorrect in"
 130                        " MAXVAL intrinsic: is %ld, should be %ld",
 131                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 132                        (long int) rank);
 133
 134       if (unlikely (compile_options.bounds_check))
 135         bounds_ifunction_return ((array_t *) retarray, extent,
 136                                  "return value", "MAXVAL");
 137     }
 138
 139   for (n = 0; n < rank; n++)
 140     {
 141       count[n] = 0;
 142       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
 143       if (extent[n] <= 0)
 144         return;
 145     }
 146
 147   base = array->base_addr;
 148   dest = retarray->base_addr;
 149
 150   continue_loop = 1;
 151   while (continue_loop)
 152     {
 153       const GFC_UINTEGER_1 * restrict src;
 154       src = base;
 155       {
 156
 157         const GFC_UINTEGER_1 *retval;
 158         retval = base;
 159         if (len <= 0)
 160           memset (dest, 0, sizeof (*dest) * string_len);
 161         else
 162           {
 163             for (n = 0; n < len; n++, src += delta)
 164               {
 165
 166                 if (compare_fcn (src, retval, string_len) > 0)
 167                   {
 168                     retval = src;
 169                   }
 170               }
 171
 172             memcpy (dest, retval, sizeof (*dest) * string_len);
 173           }
 174       }
 175       /* Advance to the next element.  */
 176       count[0]++;
 177       base += sstride[0];
 178       dest += dstride[0];
 179       n = 0;
 180       while (count[n] == extent[n])
 181         {
 182           /* When we get to the end of a dimension, reset it and increment
 183              the next dimension.  */
 184           count[n] = 0;
 185           /* We could precalculate these products, but this is a less
 186              frequently used path so probably not worth it.  */
 187           base -= sstride[n] * extent[n];
 188           dest -= dstride[n] * extent[n];
 189           n++;
 190           if (n >= rank)
 191             {
 192               /* Break out of the loop.  */
 193               continue_loop = 0;
 194               break;
 195             }
 196           else
 197             {
 198               count[n]++;
 199               base += sstride[n];
 200               dest += dstride[n];
 201             }
 202         }
 203     }
 204 }
 205
 206
 207 extern void mmaxval1_s1 (gfc_array_s1 * const restrict,
 208         gfc_charlen_type, gfc_array_s1 * const restrict,
 209         const index_type * const restrict,
 210         gfc_array_l1 * const restrict, gfc_charlen_type);
 211 export_proto(mmaxval1_s1);
 212
 213 void
 214 mmaxval1_s1 (gfc_array_s1 * const restrict retarray,
 215         gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
 216         const index_type * const restrict pdim,
 217         gfc_array_l1 * const restrict mask,
 218         gfc_charlen_type string_len)
 219
 220 {
 221   index_type count[GFC_MAX_DIMENSIONS];
 222   index_type extent[GFC_MAX_DIMENSIONS];
 223   index_type sstride[GFC_MAX_DIMENSIONS];
 224   index_type dstride[GFC_MAX_DIMENSIONS];
 225   index_type mstride[GFC_MAX_DIMENSIONS];
 226   GFC_UINTEGER_1 * restrict dest;
 227   const GFC_UINTEGER_1 * restrict base;
 228   const GFC_LOGICAL_1 * restrict mbase;
 229   index_type rank;
 230   index_type dim;
 231   index_type n;
 232   index_type len;
 233   index_type delta;
 234   index_type mdelta;
 235   int mask_kind;
 236
 237   if (mask == NULL)
 238     {
 239       maxval1_s1 (retarray, xlen, array, pdim, string_len);
 240       return;
 241     }
 242
 243   assert (xlen == string_len);
 244
 245   dim = (*pdim) - 1;
 246   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 247
 248   if (unlikely (dim < 0 || dim > rank))
 249     {
 250       runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
 251                      "is %ld, should be between 1 and %ld",
 252                      (long int) dim + 1, (long int) rank + 1);
 253     }
 254
 255   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 256   if (len < 0)
 257     len = 0;
 258
 259   mbase = mask->base_addr;
 260
 261   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 262
 263   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 264 #ifdef HAVE_GFC_LOGICAL_16
 265       || mask_kind == 16
 266 #endif
 267       )
 268     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 269   else
 270     runtime_error ("Funny sized logical array");
 271
 272   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
 273   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 274
 275   for (n = 0; n < dim; n++)
 276     {
 277       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
 278       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 279       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 280
 281       if (extent[n] < 0)
 282         extent[n] = 0;
 283
 284     }
 285   for (n = dim; n < rank; n++)
 286     {
 287       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
 288       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 289       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 290
 291       if (extent[n] < 0)
 292         extent[n] = 0;
 293     }
 294
 295   if (retarray->base_addr == NULL)
 296     {
 297       size_t alloc_size, str;
 298
 299       for (n = 0; n < rank; n++)
 300         {
 301           if (n == 0)
 302             str = 1;
 303           else
 304             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 305
 306           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 307
 308         }
 309
 310       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
 311                  * string_len;
 312
 313       retarray->offset = 0;
 314       retarray->dtype.rank = rank;
 315
 316       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
 317       if (alloc_size == 0)
 318         return;
 319     }
 320   else
 321     {
 322       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 323         runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
 324
 325       if (unlikely (compile_options.bounds_check))
 326         {
 327           bounds_ifunction_return ((array_t *) retarray, extent,
 328                                    "return value", "MAXVAL");
 329           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 330                                 "MASK argument", "MAXVAL");
 331         }
 332     }
 333
 334   for (n = 0; n < rank; n++)
 335     {
 336       count[n] = 0;
 337       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
 338       if (extent[n] <= 0)
 339         return;
 340     }
 341
 342   dest = retarray->base_addr;
 343   base = array->base_addr;
 344
 345   while (base)
 346     {
 347       const GFC_UINTEGER_1 * restrict src;
 348       const GFC_LOGICAL_1 * restrict msrc;
 349
 350       src = base;
 351       msrc = mbase;
 352       {
 353
 354         const GFC_UINTEGER_1 *retval;
 355         memset (dest, 0, sizeof (*dest) * string_len);
 356         retval = dest;
 357         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 358           {
 359
 360                 if (*msrc)
 361                       {
 362                         retval = src;
 363                         break;
 364                       }
 365             }
 366             for (; n < len; n++, src += delta, msrc += mdelta)
 367               {
 368                 if (*msrc && compare_fcn (src, retval, string_len) > 0)
 369                   {
 370                     retval = src;
 371                   }
 372
 373           }
 374         memcpy (dest, retval, sizeof (*dest) * string_len);
 375       }
 376       /* Advance to the next element.  */
 377       count[0]++;
 378       base += sstride[0];
 379       mbase += mstride[0];
 380       dest += dstride[0];
 381       n = 0;
 382       while (count[n] == extent[n])
 383         {
 384           /* When we get to the end of a dimension, reset it and increment
 385              the next dimension.  */
 386           count[n] = 0;
 387           /* We could precalculate these products, but this is a less
 388              frequently used path so probably not worth it.  */
 389           base -= sstride[n] * extent[n];
 390           mbase -= mstride[n] * extent[n];
 391           dest -= dstride[n] * extent[n];
 392           n++;
 393           if (n >= rank)
 394             {
 395               /* Break out of the loop.  */
 396               base = NULL;
 397               break;
 398             }
 399           else
 400             {
 401               count[n]++;
 402               base += sstride[n];
 403               mbase += mstride[n];
 404               dest += dstride[n];
 405             }
 406         }
 407     }
 408 }
 409
 410
 411 void smaxval1_s1 (gfc_array_s1 * const restrict,
 412         gfc_charlen_type, gfc_array_s1 * const restrict,
 413         const index_type * const restrict,
 414         GFC_LOGICAL_4 *, gfc_charlen_type);
 415
 416 export_proto(smaxval1_s1);
 417
 418 void
 419 smaxval1_s1 (gfc_array_s1 * const restrict retarray,
 420         gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
 421         const index_type * const restrict pdim,
 422         GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
 423
 424 {
 425   index_type count[GFC_MAX_DIMENSIONS];
 426   index_type extent[GFC_MAX_DIMENSIONS];
 427   index_type dstride[GFC_MAX_DIMENSIONS];
 428   GFC_UINTEGER_1 * restrict dest;
 429   index_type rank;
 430   index_type n;
 431   index_type dim;
 432
 433
 434   if (mask == NULL || *mask)
 435     {
 436       maxval1_s1 (retarray, xlen, array, pdim, string_len);
 437       return;
 438     }
 439   /* Make dim zero based to avoid confusion.  */
 440   dim = (*pdim) - 1;
 441   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 442
 443   if (unlikely (dim < 0 || dim > rank))
 444     {
 445       runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
 446                      "is %ld, should be between 1 and %ld",
 447                      (long int) dim + 1, (long int) rank + 1);
 448     }
 449
 450   for (n = 0; n < dim; n++)
 451     {
 452       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 453
 454       if (extent[n] <= 0)
 455         extent[n] = 0;
 456     }
 457
 458   for (n = dim; n < rank; n++)
 459     {
 460       extent[n] =
 461         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 462
 463       if (extent[n] <= 0)
 464         extent[n] = 0;
 465     }
 466
 467   if (retarray->base_addr == NULL)
 468     {
 469       size_t alloc_size, str;
 470
 471       for (n = 0; n < rank; n++)
 472         {
 473           if (n == 0)
 474             str = 1;
 475           else
 476             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 477
 478           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 479
 480         }
 481
 482       retarray->offset = 0;
 483       retarray->dtype.rank = rank;
 484
 485       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
 486                  * string_len;
 487
 488       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
 489       if (alloc_size == 0)
 490         return;
 491     }
 492   else
 493     {
 494       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 495         runtime_error ("rank of return array incorrect in"
 496                        " MAXVAL intrinsic: is %ld, should be %ld",
 497                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 498                        (long int) rank);
 499
 500       if (unlikely (compile_options.bounds_check))
 501         {
 502           for (n=0; n < rank; n++)
 503             {
 504               index_type ret_extent;
 505
 506               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 507               if (extent[n] != ret_extent)
 508                 runtime_error ("Incorrect extent in return value of"
 509                                " MAXVAL intrinsic in dimension %ld:"
 510                                " is %ld, should be %ld", (long int) n + 1,
 511                                (long int) ret_extent, (long int) extent[n]);
 512             }
 513         }
 514     }
 515
 516   for (n = 0; n < rank; n++)
 517     {
 518       count[n] = 0;
 519       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
 520     }
 521
 522   dest = retarray->base_addr;
 523
 524   while(1)
 525     {
 526       memset (dest, 0, sizeof (*dest) * string_len);
 527       count[0]++;
 528       dest += dstride[0];
 529       n = 0;
 530       while (count[n] == extent[n])
 531         {
 532           /* When we get to the end of a dimension, reset it and increment
 533              the next dimension.  */
 534           count[n] = 0;
 535           /* We could precalculate these products, but this is a less
 536              frequently used path so probably not worth it.  */
 537           dest -= dstride[n] * extent[n];
 538           n++;
 539           if (n >= rank)
 540             return;
 541           else
 542             {
 543               count[n]++;
 544               dest += dstride[n];
 545             }
 546         }
 547     }
 548 }
 549
 550 #endif