libgfortran/generated/maxloc0_4_s1.c

   1 /* Implementation of the MAXLOC 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 #include <stdlib.h>
  28 #include <string.h>
  29 #include <assert.h>
  30 #include <limits.h>
  31
  32
  33 #if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
  34
  35 #define HAVE_BACK_ARG 1
  36
  37 static inline int
  38 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
  39 {
  40   if (sizeof (GFC_UINTEGER_1) == 1)
  41     return memcmp (a, b, n);
  42   else
  43     return memcmp_char4 (a, b, n);
  44
  45 }
  46
  47 extern void maxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
  48         gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
  49 export_proto(maxloc0_4_s1);
  50
  51 void
  52 maxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
  53         gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
  54 {
  55   index_type count[GFC_MAX_DIMENSIONS];
  56   index_type extent[GFC_MAX_DIMENSIONS];
  57   index_type sstride[GFC_MAX_DIMENSIONS];
  58   index_type dstride;
  59   const GFC_UINTEGER_1 *base;
  60   GFC_INTEGER_4 * restrict dest;
  61   index_type rank;
  62   index_type n;
  63
  64   rank = GFC_DESCRIPTOR_RANK (array);
  65   if (rank <= 0)
  66     runtime_error ("Rank of array needs to be > 0");
  67
  68   if (retarray->base_addr == NULL)
  69     {
  70       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  71       retarray->dtype.rank = 1;
  72       retarray->offset = 0;
  73       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
  74     }
  75   else
  76     {
  77       if (unlikely (compile_options.bounds_check))
  78         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  79                                 "MAXLOC");
  80     }
  81
  82   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  83   dest = retarray->base_addr;
  84   for (n = 0; n < rank; n++)
  85     {
  86       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
  87       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  88       count[n] = 0;
  89       if (extent[n] <= 0)
  90         {
  91           /* Set the return value.  */
  92           for (n = 0; n < rank; n++)
  93             dest[n * dstride] = 0;
  94           return;
  95         }
  96     }
  97
  98   base = array->base_addr;
  99
 100   /* Initialize the return value.  */
 101   for (n = 0; n < rank; n++)
 102     dest[n * dstride] = 1;
 103   {
 104
 105   const GFC_UINTEGER_1 *maxval;
 106    maxval = NULL;
 107
 108   while (base)
 109     {
 110       do
 111         {
 112           /* Implementation start.  */
 113
 114     if (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0 :
 115                                    compare_fcn (base, maxval, len) > 0))
 116     {
 117       maxval = base;
 118       for (n = 0; n < rank; n++)
 119         dest[n * dstride] = count[n] + 1;
 120     }
 121           /* Implementation end.  */
 122           /* Advance to the next element.  */
 123           base += sstride[0];
 124         }
 125       while (++count[0] != extent[0]);
 126       n = 0;
 127       do
 128         {
 129           /* When we get to the end of a dimension, reset it and increment
 130              the next dimension.  */
 131           count[n] = 0;
 132           /* We could precalculate these products, but this is a less
 133              frequently used path so probably not worth it.  */
 134           base -= sstride[n] * extent[n];
 135           n++;
 136           if (n >= rank)
 137             {
 138               /* Break out of the loop.  */
 139               base = NULL;
 140               break;
 141             }
 142           else
 143             {
 144               count[n]++;
 145               base += sstride[n];
 146             }
 147         }
 148       while (count[n] == extent[n]);
 149     }
 150   }
 151 }
 152
 153
 154 extern void mmaxloc0_4_s1 (gfc_array_i4 * const restrict,
 155         gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
 156         gfc_charlen_type len);
 157 export_proto(mmaxloc0_4_s1);
 158
 159 void
 160 mmaxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
 161         gfc_array_s1 * const restrict array,
 162         gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
 163         gfc_charlen_type len)
 164 {
 165   index_type count[GFC_MAX_DIMENSIONS];
 166   index_type extent[GFC_MAX_DIMENSIONS];
 167   index_type sstride[GFC_MAX_DIMENSIONS];
 168   index_type mstride[GFC_MAX_DIMENSIONS];
 169   index_type dstride;
 170   GFC_INTEGER_4 *dest;
 171   const GFC_UINTEGER_1 *base;
 172   GFC_LOGICAL_1 *mbase;
 173   int rank;
 174   index_type n;
 175   int mask_kind;
 176
 177   if (mask == NULL)
 178     {
 179 #ifdef HAVE_BACK_ARG
 180       maxloc0_4_s1 (retarray, array, back, len);
 181 #else
 182       maxloc0_4_s1 (retarray, array, len);
 183 #endif
 184       return;
 185     }
 186
 187   rank = GFC_DESCRIPTOR_RANK (array);
 188   if (rank <= 0)
 189     runtime_error ("Rank of array needs to be > 0");
 190
 191   if (retarray->base_addr == NULL)
 192     {
 193       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 194       retarray->dtype.rank = 1;
 195       retarray->offset = 0;
 196       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 197     }
 198   else
 199     {
 200       if (unlikely (compile_options.bounds_check))
 201         {
 202
 203           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 204                                   "MAXLOC");
 205           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 206                                   "MASK argument", "MAXLOC");
 207         }
 208     }
 209
 210   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 211
 212   mbase = mask->base_addr;
 213
 214   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 215 #ifdef HAVE_GFC_LOGICAL_16
 216       || mask_kind == 16
 217 #endif
 218       )
 219     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 220   else
 221     runtime_error ("Funny sized logical array");
 222
 223   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 224   dest = retarray->base_addr;
 225   for (n = 0; n < rank; n++)
 226     {
 227       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
 228       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 229       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 230       count[n] = 0;
 231       if (extent[n] <= 0)
 232         {
 233           /* Set the return value.  */
 234           for (n = 0; n < rank; n++)
 235             dest[n * dstride] = 0;
 236           return;
 237         }
 238     }
 239
 240   base = array->base_addr;
 241
 242   /* Initialize the return value.  */
 243   for (n = 0; n < rank; n++)
 244     dest[n * dstride] = 0;
 245   {
 246
 247   const GFC_UINTEGER_1 *maxval;
 248
 249   maxval = NULL;
 250
 251   while (base)
 252     {
 253       do
 254         {
 255           /* Implementation start.  */
 256
 257   if (*mbase &&
 258         (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0:
 259                                    compare_fcn (base, maxval, len) > 0)))
 260     {
 261       maxval = base;
 262       for (n = 0; n < rank; n++)
 263         dest[n * dstride] = count[n] + 1;
 264     }
 265           /* Implementation end.  */
 266           /* Advance to the next element.  */
 267           base += sstride[0];
 268           mbase += mstride[0];
 269         }
 270       while (++count[0] != extent[0]);
 271       n = 0;
 272       do
 273         {
 274           /* When we get to the end of a dimension, reset it and increment
 275              the next dimension.  */
 276           count[n] = 0;
 277           /* We could precalculate these products, but this is a less
 278              frequently used path so probably not worth it.  */
 279           base -= sstride[n] * extent[n];
 280           mbase -= mstride[n] * extent[n];
 281           n++;
 282           if (n >= rank)
 283             {
 284               /* Break out of the loop.  */
 285               base = NULL;
 286               break;
 287             }
 288           else
 289             {
 290               count[n]++;
 291               base += sstride[n];
 292               mbase += mstride[n];
 293             }
 294         }
 295       while (count[n] == extent[n]);
 296     }
 297   }
 298 }
 299
 300
 301 extern void smaxloc0_4_s1 (gfc_array_i4 * const restrict,
 302         gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
 303         gfc_charlen_type len);
 304 export_proto(smaxloc0_4_s1);
 305
 306 void
 307 smaxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
 308         gfc_array_s1 * const restrict array,
 309         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
 310         gfc_charlen_type len)
 311 {
 312   index_type rank;
 313   index_type dstride;
 314   index_type n;
 315   GFC_INTEGER_4 *dest;
 316
 317   if (mask == NULL || *mask)
 318     {
 319 #ifdef HAVE_BACK_ARG
 320       maxloc0_4_s1 (retarray, array, back, len);
 321 #else
 322       maxloc0_4_s1 (retarray, array, len);
 323 #endif
 324       return;
 325     }
 326
 327   rank = GFC_DESCRIPTOR_RANK (array);
 328
 329   if (rank <= 0)
 330     runtime_error ("Rank of array needs to be > 0");
 331
 332   if (retarray->base_addr == NULL)
 333     {
 334       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 335       retarray->dtype.rank = 1;
 336       retarray->offset = 0;
 337       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 338     }
 339   else if (unlikely (compile_options.bounds_check))
 340     {
 341        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 342                                "MAXLOC");
 343     }
 344
 345   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 346   dest = retarray->base_addr;
 347   for (n = 0; n<rank; n++)
 348     dest[n * dstride] = 0 ;
 349 }
 350 #endif