libgfortran/generated/eoshift1_4.c

   1 /* Implementation of the EOSHIFT intrinsic
   2    Copyright (C) 2002-2024 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   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 <string.h>
  28
  29
  30 #if defined (HAVE_GFC_INTEGER_4)
  31
  32 static void
  33 eoshift1 (gfc_array_char * const restrict ret,
  34         const gfc_array_char * const restrict array,
  35         const gfc_array_i4 * const restrict h,
  36         const char * const restrict pbound,
  37         const GFC_INTEGER_4 * const restrict pwhich,
  38         const char * filler, index_type filler_len)
  39 {
  40   /* r.* indicates the return array.  */
  41   index_type rstride[GFC_MAX_DIMENSIONS];
  42   index_type rstride0;
  43   index_type roffset;
  44   char *rptr;
  45   char * restrict dest;
  46   /* s.* indicates the source array.  */
  47   index_type sstride[GFC_MAX_DIMENSIONS];
  48   index_type sstride0;
  49   index_type soffset;
  50   const char *sptr;
  51   const char *src;
  52   /* h.* indicates the shift array.  */
  53   index_type hstride[GFC_MAX_DIMENSIONS];
  54   index_type hstride0;
  55   const GFC_INTEGER_4 *hptr;
  56
  57   index_type count[GFC_MAX_DIMENSIONS];
  58   index_type extent[GFC_MAX_DIMENSIONS];
  59   index_type dim;
  60   index_type len;
  61   index_type n;
  62   index_type size;
  63   index_type arraysize;
  64   int which;
  65   GFC_INTEGER_4 sh;
  66   GFC_INTEGER_4 delta;
  67
  68   /* The compiler cannot figure out that these are set, initialize
  69      them to avoid warnings.  */
  70   len = 0;
  71   soffset = 0;
  72   roffset = 0;
  73
  74   size = GFC_DESCRIPTOR_SIZE(array);
  75
  76   if (pwhich)
  77     which = *pwhich - 1;
  78   else
  79     which = 0;
  80
  81   extent[0] = 1;
  82   count[0] = 0;
  83
  84   arraysize = size0 ((array_t *) array);
  85   if (ret->base_addr == NULL)
  86     {
  87       ret->offset = 0;
  88       GFC_DTYPE_COPY(ret,array);
  89       for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  90         {
  91           index_type ub, str;
  92
  93           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  94
  95           if (i == 0)
  96             str = 1;
  97           else
  98             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
  99               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
 100
 101           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 102
 103         }
 104       /* xmallocarray allocates a single byte for zero size.  */
 105       ret->base_addr = xmallocarray (arraysize, size);
 106
 107     }
 108   else if (unlikely (compile_options.bounds_check))
 109     {
 110       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 111                                  "return value", "EOSHIFT");
 112     }
 113
 114   if (unlikely (compile_options.bounds_check))
 115     {
 116       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 117                               "SHIFT argument", "EOSHIFT");
 118     }
 119
 120   if (arraysize == 0)
 121     return;
 122
 123   n = 0;
 124   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 125     {
 126       if (dim == which)
 127         {
 128           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 129           if (roffset == 0)
 130             roffset = size;
 131           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 132           if (soffset == 0)
 133             soffset = size;
 134           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 135         }
 136       else
 137         {
 138           count[n] = 0;
 139           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 140           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 141           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 142
 143           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 144           n++;
 145         }
 146     }
 147   if (sstride[0] == 0)
 148     sstride[0] = size;
 149   if (rstride[0] == 0)
 150     rstride[0] = size;
 151   if (hstride[0] == 0)
 152     hstride[0] = 1;
 153
 154   dim = GFC_DESCRIPTOR_RANK (array);
 155   rstride0 = rstride[0];
 156   sstride0 = sstride[0];
 157   hstride0 = hstride[0];
 158   rptr = ret->base_addr;
 159   sptr = array->base_addr;
 160   hptr = h->base_addr;
 161
 162   while (rptr)
 163     {
 164       /* Do the shift for this dimension.  */
 165       sh = *hptr;
 166       if (( sh >= 0 ? sh : -sh ) > len)
 167         {
 168           delta = len;
 169           sh = len;
 170         }
 171       else
 172         delta = (sh >= 0) ? sh: -sh;
 173
 174       if (sh > 0)
 175         {
 176           src = &sptr[delta * soffset];
 177           dest = rptr;
 178         }
 179       else
 180         {
 181           src = sptr;
 182           dest = &rptr[delta * roffset];
 183         }
 184
 185       /* If the elements are contiguous, perform a single block move.  */
 186       if (soffset == size && roffset == size)
 187         {
 188           size_t chunk = size * (len - delta);
 189           memcpy (dest, src, chunk);
 190           dest += chunk;
 191         }
 192       else
 193         {
 194           for (n = 0; n < len - delta; n++)
 195             {
 196               memcpy (dest, src, size);
 197               dest += roffset;
 198               src += soffset;
 199             }
 200         }
 201       if (sh < 0)
 202         dest = rptr;
 203       n = delta;
 204
 205       if (pbound)
 206         while (n--)
 207           {
 208             memcpy (dest, pbound, size);
 209             dest += roffset;
 210           }
 211       else
 212         while (n--)
 213           {
 214             index_type i;
 215
 216             if (filler_len == 1)
 217               memset (dest, filler[0], size);
 218             else
 219               for (i = 0; i < size; i += filler_len)
 220                 memcpy (&dest[i], filler, filler_len);
 221
 222             dest += roffset;
 223           }
 224
 225       /* Advance to the next section.  */
 226       rptr += rstride0;
 227       sptr += sstride0;
 228       hptr += hstride0;
 229       count[0]++;
 230       n = 0;
 231       while (count[n] == extent[n])
 232         {
 233           /* When we get to the end of a dimension, reset it and increment
 234              the next dimension.  */
 235           count[n] = 0;
 236           /* We could precalculate these products, but this is a less
 237              frequently used path so probably not worth it.  */
 238           rptr -= rstride[n] * extent[n];
 239           sptr -= sstride[n] * extent[n];
 240           hptr -= hstride[n] * extent[n];
 241           n++;
 242           if (n >= dim - 1)
 243             {
 244               /* Break out of the loop.  */
 245               rptr = NULL;
 246               break;
 247             }
 248           else
 249             {
 250               count[n]++;
 251               rptr += rstride[n];
 252               sptr += sstride[n];
 253               hptr += hstride[n];
 254             }
 255         }
 256     }
 257 }
 258
 259 void eoshift1_4 (gfc_array_char * const restrict,
 260         const gfc_array_char * const restrict,
 261         const gfc_array_i4 * const restrict, const char * const restrict,
 262         const GFC_INTEGER_4 * const restrict);
 263 export_proto(eoshift1_4);
 264
 265 void
 266 eoshift1_4 (gfc_array_char * const restrict ret,
 267         const gfc_array_char * const restrict array,
 268         const gfc_array_i4 * const restrict h,
 269         const char * const restrict pbound,
 270         const GFC_INTEGER_4 * const restrict pwhich)
 271 {
 272   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
 273 }
 274
 275
 276 void eoshift1_4_char (gfc_array_char * const restrict,
 277         GFC_INTEGER_4,
 278         const gfc_array_char * const restrict,
 279         const gfc_array_i4 * const restrict,
 280         const char * const restrict,
 281         const GFC_INTEGER_4 * const restrict,
 282         GFC_INTEGER_4, GFC_INTEGER_4);
 283 export_proto(eoshift1_4_char);
 284
 285 void
 286 eoshift1_4_char (gfc_array_char * const restrict ret,
 287         GFC_INTEGER_4 ret_length __attribute__((unused)),
 288         const gfc_array_char * const restrict array,
 289         const gfc_array_i4 * const restrict h,
 290         const char *  const restrict pbound,
 291         const GFC_INTEGER_4 * const restrict pwhich,
 292         GFC_INTEGER_4 array_length __attribute__((unused)),
 293         GFC_INTEGER_4 bound_length __attribute__((unused)))
 294 {
 295   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
 296 }
 297
 298
 299 void eoshift1_4_char4 (gfc_array_char * const restrict,
 300         GFC_INTEGER_4,
 301         const gfc_array_char * const restrict,
 302         const gfc_array_i4 * const restrict,
 303         const char * const restrict,
 304         const GFC_INTEGER_4 * const restrict,
 305         GFC_INTEGER_4, GFC_INTEGER_4);
 306 export_proto(eoshift1_4_char4);
 307
 308 void
 309 eoshift1_4_char4 (gfc_array_char * const restrict ret,
 310         GFC_INTEGER_4 ret_length __attribute__((unused)),
 311         const gfc_array_char * const restrict array,
 312         const gfc_array_i4 * const restrict h,
 313         const char *  const restrict pbound,
 314         const GFC_INTEGER_4 * const restrict pwhich,
 315         GFC_INTEGER_4 array_length __attribute__((unused)),
 316         GFC_INTEGER_4 bound_length __attribute__((unused)))
 317 {
 318   static const gfc_char4_t space = (unsigned char) ' ';
 319   eoshift1 (ret, array, h, pbound, pwhich,
 320             (const char *) &space, sizeof (gfc_char4_t));
 321 }
 322
 323 #endif