libgfortran/generated/maxval0_s4.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_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
  34
  35 static inline int
  36 compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
  37 {
  38   if (sizeof (GFC_UINTEGER_4) == 1)
  39     return memcmp (a, b, n);
  40   else
  41     return memcmp_char4 (a, b, n);
  42
  43 }
  44
  45 #define INITVAL 0
  46
  47 extern void maxval0_s4 (GFC_UINTEGER_4 * restrict,
  48         gfc_charlen_type,
  49         gfc_array_s4 * const restrict array, gfc_charlen_type);
  50 export_proto(maxval0_s4);
  51
  52 void
  53 maxval0_s4 (GFC_UINTEGER_4 * restrict ret,
  54         gfc_charlen_type xlen,
  55         gfc_array_s4 * const restrict array, gfc_charlen_type len)
  56 {
  57   index_type count[GFC_MAX_DIMENSIONS];
  58   index_type extent[GFC_MAX_DIMENSIONS];
  59   index_type sstride[GFC_MAX_DIMENSIONS];
  60   const GFC_UINTEGER_4 *base;
  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   assert (xlen == len);
  69
  70   /* Initialize return value.  */
  71   memset (ret, INITVAL, sizeof(*ret) * len);
  72
  73   for (n = 0; n < rank; n++)
  74     {
  75       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
  76       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  77       count[n] = 0;
  78       if (extent[n] <= 0)
  79         return;
  80     }
  81
  82   base = array->base_addr;
  83
  84   {
  85
  86   const GFC_UINTEGER_4 *retval;
  87    retval = ret;
  88
  89   while (base)
  90     {
  91       do
  92         {
  93           /* Implementation start.  */
  94
  95   if (compare_fcn (base, retval, len) > 0)
  96     {
  97       retval = base;
  98     }
  99           /* Implementation end.  */
 100           /* Advance to the next element.  */
 101           base += sstride[0];
 102         }
 103       while (++count[0] != extent[0]);
 104       n = 0;
 105       do
 106         {
 107           /* When we get to the end of a dimension, reset it and increment
 108              the next dimension.  */
 109           count[n] = 0;
 110           /* We could precalculate these products, but this is a less
 111              frequently used path so probably not worth it.  */
 112           base -= sstride[n] * extent[n];
 113           n++;
 114           if (n >= rank)
 115             {
 116               /* Break out of the loop.  */
 117               base = NULL;
 118               break;
 119             }
 120           else
 121             {
 122               count[n]++;
 123               base += sstride[n];
 124             }
 125         }
 126       while (count[n] == extent[n]);
 127     }
 128    memcpy (ret, retval, len * sizeof (*ret));
 129   }
 130 }
 131
 132
 133 extern void mmaxval0_s4 (GFC_UINTEGER_4 * restrict,
 134        gfc_charlen_type, gfc_array_s4 * const restrict array,
 135        gfc_array_l1 * const restrict mask, gfc_charlen_type len);
 136 export_proto(mmaxval0_s4);
 137
 138 void
 139 mmaxval0_s4 (GFC_UINTEGER_4 * const restrict ret,
 140         gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
 141         gfc_array_l1 * const restrict mask, gfc_charlen_type len)
 142 {
 143   index_type count[GFC_MAX_DIMENSIONS];
 144   index_type extent[GFC_MAX_DIMENSIONS];
 145   index_type sstride[GFC_MAX_DIMENSIONS];
 146   index_type mstride[GFC_MAX_DIMENSIONS];
 147   const GFC_UINTEGER_4 *base;
 148   GFC_LOGICAL_1 *mbase;
 149   int rank;
 150   index_type n;
 151   int mask_kind;
 152
 153   rank = GFC_DESCRIPTOR_RANK (array);
 154   if (rank <= 0)
 155     runtime_error ("Rank of array needs to be > 0");
 156
 157   assert (xlen == len);
 158
 159 /* Initialize return value.  */
 160   memset (ret, INITVAL, sizeof(*ret) * len);
 161
 162   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 163
 164   mbase = mask->base_addr;
 165
 166   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 167 #ifdef HAVE_GFC_LOGICAL_16
 168       || mask_kind == 16
 169 #endif
 170       )
 171     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 172   else
 173     runtime_error ("Funny sized logical array");
 174
 175   for (n = 0; n < rank; n++)
 176     {
 177       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
 178       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 179       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 180       count[n] = 0;
 181       if (extent[n] <= 0)
 182         return;
 183     }
 184
 185   base = array->base_addr;
 186   {
 187
 188   const GFC_UINTEGER_4 *retval;
 189
 190   retval = ret;
 191
 192   while (base)
 193     {
 194       do
 195         {
 196           /* Implementation start.  */
 197
 198   if (*mbase && compare_fcn (base, retval, len) > 0)
 199     {
 200       retval = base;
 201     }
 202           /* Implementation end.  */
 203           /* Advance to the next element.  */
 204           base += sstride[0];
 205           mbase += mstride[0];
 206         }
 207       while (++count[0] != extent[0]);
 208       n = 0;
 209       do
 210         {
 211           /* When we get to the end of a dimension, reset it and increment
 212              the next dimension.  */
 213           count[n] = 0;
 214           /* We could precalculate these products, but this is a less
 215              frequently used path so probably not worth it.  */
 216           base -= sstride[n] * extent[n];
 217           mbase -= mstride[n] * extent[n];
 218           n++;
 219           if (n >= rank)
 220             {
 221               /* Break out of the loop.  */
 222               base = NULL;
 223               break;
 224             }
 225           else
 226             {
 227               count[n]++;
 228               base += sstride[n];
 229               mbase += mstride[n];
 230             }
 231         }
 232       while (count[n] == extent[n]);
 233     }
 234     memcpy (ret, retval, len * sizeof (*ret));
 235   }
 236 }
 237
 238
 239 extern void smaxval0_s4 (GFC_UINTEGER_4 * restrict,
 240         gfc_charlen_type,
 241         gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
 242 export_proto(smaxval0_s4);
 243
 244 void
 245 smaxval0_s4 (GFC_UINTEGER_4 * restrict ret,
 246         gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
 247         GFC_LOGICAL_4 *mask, gfc_charlen_type len)
 248
 249 {
 250   if (*mask)
 251     {
 252       maxval0_s4 (ret, xlen, array, len);
 253       return;
 254     }
 255   memset (ret, INITVAL, sizeof (*ret) * len);
 256 }
 257
 258 #endif