libgfortran/generated/eoshift3_4.c

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