libgfortran/generated/maxloc0_4_s1.c

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