libgfortran/generated/eoshift3_8.c

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