libgfortran/generated/minval1_s4.c

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