libgfortran/generated/minloc0_4_s1.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright (C) 2017-2018 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 minloc0_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(minloc0_4_s1);
  50
  51 void
  52 minloc0_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                                 "MINLOC");
  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 *minval;
 106    minval = NULL;
 107
 108   while (base)
 109     {
 110       do
 111         {
 112           /* Implementation start.  */
 113
 114     if (minval == NULL || (back ? compare_fcn (base, minval, len) <= 0 :
 115                                    compare_fcn (base, minval, len) < 0))
 116     {
 117       minval = 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 mminloc0_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(mminloc0_4_s1);
 158
 159 void
 160 mminloc0_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   rank = GFC_DESCRIPTOR_RANK (array);
 178   if (rank <= 0)
 179     runtime_error ("Rank of array needs to be > 0");
 180
 181   if (retarray->base_addr == NULL)
 182     {
 183       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 184       retarray->dtype.rank = 1;
 185       retarray->offset = 0;
 186       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 187     }
 188   else
 189     {
 190       if (unlikely (compile_options.bounds_check))
 191         {
 192
 193           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 194                                   "MINLOC");
 195           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 196                                   "MASK argument", "MINLOC");
 197         }
 198     }
 199
 200   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 201
 202   mbase = mask->base_addr;
 203
 204   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 205 #ifdef HAVE_GFC_LOGICAL_16
 206       || mask_kind == 16
 207 #endif
 208       )
 209     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 210   else
 211     runtime_error ("Funny sized logical array");
 212
 213   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 214   dest = retarray->base_addr;
 215   for (n = 0; n < rank; n++)
 216     {
 217       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
 218       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 219       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 220       count[n] = 0;
 221       if (extent[n] <= 0)
 222         {
 223           /* Set the return value.  */
 224           for (n = 0; n < rank; n++)
 225             dest[n * dstride] = 0;
 226           return;
 227         }
 228     }
 229
 230   base = array->base_addr;
 231
 232   /* Initialize the return value.  */
 233   for (n = 0; n < rank; n++)
 234     dest[n * dstride] = 0;
 235   {
 236
 237   const GFC_UINTEGER_1 *minval;
 238
 239   minval = NULL;
 240
 241   while (base)
 242     {
 243       do
 244         {
 245           /* Implementation start.  */
 246
 247   if (*mbase &&
 248       (minval == NULL || (back ? compare_fcn (base, minval, len) <= 0 :
 249                                  compare_fcn (base, minval, len) < 0)))
 250     {
 251       minval = base;
 252       for (n = 0; n < rank; n++)
 253         dest[n * dstride] = count[n] + 1;
 254     }
 255           /* Implementation end.  */
 256           /* Advance to the next element.  */
 257           base += sstride[0];
 258           mbase += mstride[0];
 259         }
 260       while (++count[0] != extent[0]);
 261       n = 0;
 262       do
 263         {
 264           /* When we get to the end of a dimension, reset it and increment
 265              the next dimension.  */
 266           count[n] = 0;
 267           /* We could precalculate these products, but this is a less
 268              frequently used path so probably not worth it.  */
 269           base -= sstride[n] * extent[n];
 270           mbase -= mstride[n] * extent[n];
 271           n++;
 272           if (n >= rank)
 273             {
 274               /* Break out of the loop.  */
 275               base = NULL;
 276               break;
 277             }
 278           else
 279             {
 280               count[n]++;
 281               base += sstride[n];
 282               mbase += mstride[n];
 283             }
 284         }
 285       while (count[n] == extent[n]);
 286     }
 287   }
 288 }
 289
 290
 291 extern void sminloc0_4_s1 (gfc_array_i4 * const restrict,
 292         gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
 293         gfc_charlen_type len);
 294 export_proto(sminloc0_4_s1);
 295
 296 void
 297 sminloc0_4_s1 (gfc_array_i4 * const restrict retarray,
 298         gfc_array_s1 * const restrict array,
 299         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
 300         gfc_charlen_type len)
 301 {
 302   index_type rank;
 303   index_type dstride;
 304   index_type n;
 305   GFC_INTEGER_4 *dest;
 306
 307   if (*mask)
 308     {
 309 #ifdef HAVE_BACK_ARG
 310       minloc0_4_s1 (retarray, array, back, len);
 311 #else
 312       minloc0_4_s1 (retarray, array, len);
 313 #endif
 314       return;
 315     }
 316
 317   rank = GFC_DESCRIPTOR_RANK (array);
 318
 319   if (rank <= 0)
 320     runtime_error ("Rank of array needs to be > 0");
 321
 322   if (retarray->base_addr == NULL)
 323     {
 324       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 325       retarray->dtype.rank = 1;
 326       retarray->offset = 0;
 327       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 328     }
 329   else if (unlikely (compile_options.bounds_check))
 330     {
 331        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 332                                "MINLOC");
 333     }
 334
 335   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 336   dest = retarray->base_addr;
 337   for (n = 0; n<rank; n++)
 338     dest[n * dstride] = 0 ;
 339 }
 340 #endif