libgfortran/generated/minloc0_4_s1.c

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