libgfortran/generated/maxval0_s1.c

   1 /* Implementation of the MAXLOC intrinsic
   2    Copyright (C) 2017-2024 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_UINTEGER_1)
  34
  35 static inline int
  36 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
  37 {
  38   if (sizeof (GFC_UINTEGER_1) == 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_s1 (GFC_UINTEGER_1 * restrict,
  48         gfc_charlen_type,
  49         gfc_array_s1 * const restrict array, gfc_charlen_type);
  50 export_proto(maxval0_s1);
  51
  52 void
  53 maxval0_s1 (GFC_UINTEGER_1 * restrict ret,
  54         gfc_charlen_type xlen,
  55         gfc_array_s1 * 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_1 *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_1 *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_s1 (GFC_UINTEGER_1 * restrict,
 134        gfc_charlen_type, gfc_array_s1 * const restrict array,
 135        gfc_array_l1 * const restrict mask, gfc_charlen_type len);
 136 export_proto(mmaxval0_s1);
 137
 138 void
 139 mmaxval0_s1 (GFC_UINTEGER_1 * const restrict ret,
 140         gfc_charlen_type xlen, gfc_array_s1 * 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_1 *base;
 148   GFC_LOGICAL_1 *mbase;
 149   int rank;
 150   index_type n;
 151   int mask_kind;
 152
 153   if (mask == NULL)
 154     {
 155       maxval0_s1 (ret, xlen, array, len);
 156       return;
 157     }
 158
 159   rank = GFC_DESCRIPTOR_RANK (array);
 160   if (rank <= 0)
 161     runtime_error ("Rank of array needs to be > 0");
 162
 163   assert (xlen == len);
 164
 165 /* Initialize return value.  */
 166   memset (ret, INITVAL, sizeof(*ret) * len);
 167
 168   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 169
 170   mbase = mask->base_addr;
 171
 172   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 173 #ifdef HAVE_GFC_LOGICAL_16
 174       || mask_kind == 16
 175 #endif
 176       )
 177     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 178   else
 179     runtime_error ("Funny sized logical array");
 180
 181   for (n = 0; n < rank; n++)
 182     {
 183       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
 184       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 185       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 186       count[n] = 0;
 187       if (extent[n] <= 0)
 188         return;
 189     }
 190
 191   base = array->base_addr;
 192   {
 193
 194   const GFC_UINTEGER_1 *retval;
 195
 196   retval = ret;
 197
 198   while (base)
 199     {
 200       do
 201         {
 202           /* Implementation start.  */
 203
 204   if (*mbase && compare_fcn (base, retval, len) > 0)
 205     {
 206       retval = base;
 207     }
 208           /* Implementation end.  */
 209           /* Advance to the next element.  */
 210           base += sstride[0];
 211           mbase += mstride[0];
 212         }
 213       while (++count[0] != extent[0]);
 214       n = 0;
 215       do
 216         {
 217           /* When we get to the end of a dimension, reset it and increment
 218              the next dimension.  */
 219           count[n] = 0;
 220           /* We could precalculate these products, but this is a less
 221              frequently used path so probably not worth it.  */
 222           base -= sstride[n] * extent[n];
 223           mbase -= mstride[n] * extent[n];
 224           n++;
 225           if (n >= rank)
 226             {
 227               /* Break out of the loop.  */
 228               base = NULL;
 229               break;
 230             }
 231           else
 232             {
 233               count[n]++;
 234               base += sstride[n];
 235               mbase += mstride[n];
 236             }
 237         }
 238       while (count[n] == extent[n]);
 239     }
 240     memcpy (ret, retval, len * sizeof (*ret));
 241   }
 242 }
 243
 244
 245 extern void smaxval0_s1 (GFC_UINTEGER_1 * restrict,
 246         gfc_charlen_type,
 247         gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
 248 export_proto(smaxval0_s1);
 249
 250 void
 251 smaxval0_s1 (GFC_UINTEGER_1 * restrict ret,
 252         gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
 253         GFC_LOGICAL_4 *mask, gfc_charlen_type len)
 254
 255 {
 256   if (mask == NULL || *mask)
 257     {
 258       maxval0_s1 (ret, xlen, array, len);
 259       return;
 260     }
 261   memset (ret, INITVAL, sizeof (*ret) * len);
 262 }
 263
 264 #endif