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       for (n = 0; n < len - delta; n++)
 202         {
 203           memcpy (dest, src, size);
 204           dest += roffset;
 205           src += soffset;
 206         }
 207       if (sh < 0)
 208         dest = rptr;
 209       n = delta;
 210
 211       if (bptr)
 212         while (n--)
 213           {
 214             memcpy (dest, bptr, size);
 215             dest += roffset;
 216           }
 217       else
 218         while (n--)
 219           {
 220             index_type i;
 221
 222             if (filler_len == 1)
 223               memset (dest, filler[0], size);
 224             else
 225               for (i = 0; i < size; i += filler_len)
 226                 memcpy (&dest[i], filler, filler_len);
 227
 228             dest += roffset;
 229           }
 230
 231       /* Advance to the next section.  */
 232       rptr += rstride0;
 233       sptr += sstride0;
 234       hptr += hstride0;
 235       bptr += bstride0;
 236       count[0]++;
 237       n = 0;
 238       while (count[n] == extent[n])
 239         {
 240           /* When we get to the end of a dimension, reset it and increment
 241              the next dimension.  */
 242           count[n] = 0;
 243           /* We could precalculate these products, but this is a less
 244              frequently used path so probably not worth it.  */
 245           rptr -= rstride[n] * extent[n];
 246           sptr -= sstride[n] * extent[n];
 247           hptr -= hstride[n] * extent[n];
 248           bptr -= bstride[n] * extent[n];
 249           n++;
 250           if (n >= dim - 1)
 251             {
 252               /* Break out of the loop.  */
 253               rptr = NULL;
 254               break;
 255             }
 256           else
 257             {
 258               count[n]++;
 259               rptr += rstride[n];
 260               sptr += sstride[n];
 261               hptr += hstride[n];
 262               bptr += bstride[n];
 263             }
 264         }
 265     }
 266 }
 267
 268 extern void eoshift3_4 (gfc_array_char * const restrict,
 269         const gfc_array_char * const restrict,
 270         const gfc_array_i4 * const restrict,
 271         const gfc_array_char * const restrict,
 272         const GFC_INTEGER_4 *);
 273 export_proto(eoshift3_4);
 274
 275 void
 276 eoshift3_4 (gfc_array_char * const restrict ret,
 277         const gfc_array_char * const restrict array,
 278         const gfc_array_i4 * const restrict h,
 279         const gfc_array_char * const restrict bound,
 280         const GFC_INTEGER_4 * const restrict pwhich)
 281 {
 282   eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
 283 }
 284
 285
 286 extern void eoshift3_4_char (gfc_array_char * const restrict,
 287         GFC_INTEGER_4,
 288         const gfc_array_char * const restrict,
 289         const gfc_array_i4 * const restrict,
 290         const gfc_array_char * const restrict,
 291         const GFC_INTEGER_4 * const restrict,
 292         GFC_INTEGER_4, GFC_INTEGER_4);
 293 export_proto(eoshift3_4_char);
 294
 295 void
 296 eoshift3_4_char (gfc_array_char * const restrict ret,
 297         GFC_INTEGER_4 ret_length __attribute__((unused)),
 298         const gfc_array_char * const restrict array,
 299         const gfc_array_i4 *  const restrict h,
 300         const gfc_array_char * const restrict bound,
 301         const GFC_INTEGER_4 * const restrict pwhich,
 302         GFC_INTEGER_4 array_length __attribute__((unused)),
 303         GFC_INTEGER_4 bound_length __attribute__((unused)))
 304 {
 305   eoshift3 (ret, array, h, bound, pwhich, " ", 1);
 306 }
 307
 308
 309 extern void eoshift3_4_char4 (gfc_array_char * const restrict,
 310         GFC_INTEGER_4,
 311         const gfc_array_char * const restrict,
 312         const gfc_array_i4 * const restrict,
 313         const gfc_array_char * const restrict,
 314         const GFC_INTEGER_4 * const restrict,
 315         GFC_INTEGER_4, GFC_INTEGER_4);
 316 export_proto(eoshift3_4_char4);
 317
 318 void
 319 eoshift3_4_char4 (gfc_array_char * const restrict ret,
 320         GFC_INTEGER_4 ret_length __attribute__((unused)),
 321         const gfc_array_char * const restrict array,
 322         const gfc_array_i4 *  const restrict h,
 323         const gfc_array_char * const restrict bound,
 324         const GFC_INTEGER_4 * const restrict pwhich,
 325         GFC_INTEGER_4 array_length __attribute__((unused)),
 326         GFC_INTEGER_4 bound_length __attribute__((unused)))
 327 {
 328   static const gfc_char4_t space = (unsigned char) ' ';
 329   eoshift3 (ret, array, h, bound, pwhich,
 330             (const char *) &space, sizeof (gfc_char4_t));
 331 }
 332
 333 #endif