libgfortran/generated/eoshift1_4.c

   1 /* Implementation of the EOSHIFT intrinsic
   2    Copyright (C) 2002-2016 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 <stdlib.h>
  28 #include <assert.h>
  29 #include <string.h>
  30
  31
  32 #if defined (HAVE_GFC_INTEGER_4)
  33
  34 static void
  35 eoshift1 (gfc_array_char * const restrict ret,
  36         const gfc_array_char * const restrict array,
  37         const gfc_array_i4 * const restrict h,
  38         const char * const restrict pbound,
  39         const GFC_INTEGER_4 * const restrict pwhich,
  40         const char * filler, index_type filler_len)
  41 {
  42   /* r.* indicates the return array.  */
  43   index_type rstride[GFC_MAX_DIMENSIONS];
  44   index_type rstride0;
  45   index_type roffset;
  46   char *rptr;
  47   char * restrict dest;
  48   /* s.* indicates the source array.  */
  49   index_type sstride[GFC_MAX_DIMENSIONS];
  50   index_type sstride0;
  51   index_type soffset;
  52   const char *sptr;
  53   const char *src;
  54   /* h.* indicates the shift array.  */
  55   index_type hstride[GFC_MAX_DIMENSIONS];
  56   index_type hstride0;
  57   const GFC_INTEGER_4 *hptr;
  58
  59   index_type count[GFC_MAX_DIMENSIONS];
  60   index_type extent[GFC_MAX_DIMENSIONS];
  61   index_type dim;
  62   index_type len;
  63   index_type n;
  64   index_type size;
  65   index_type arraysize;
  66   int which;
  67   GFC_INTEGER_4 sh;
  68   GFC_INTEGER_4 delta;
  69
  70   /* The compiler cannot figure out that these are set, initialize
  71      them to avoid warnings.  */
  72   len = 0;
  73   soffset = 0;
  74   roffset = 0;
  75
  76   size = GFC_DESCRIPTOR_SIZE(array);
  77
  78   if (pwhich)
  79     which = *pwhich - 1;
  80   else
  81     which = 0;
  82
  83   extent[0] = 1;
  84   count[0] = 0;
  85
  86   arraysize = size0 ((array_t *) array);
  87   if (ret->base_addr == NULL)
  88     {
  89       int i;
  90
  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   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           n++;
 149         }
 150     }
 151   if (sstride[0] == 0)
 152     sstride[0] = size;
 153   if (rstride[0] == 0)
 154     rstride[0] = size;
 155   if (hstride[0] == 0)
 156     hstride[0] = 1;
 157
 158   dim = GFC_DESCRIPTOR_RANK (array);
 159   rstride0 = rstride[0];
 160   sstride0 = sstride[0];
 161   hstride0 = hstride[0];
 162   rptr = ret->base_addr;
 163   sptr = array->base_addr;
 164   hptr = h->base_addr;
 165
 166   while (rptr)
 167     {
 168       /* Do the shift for this dimension.  */
 169       sh = *hptr;
 170       if (( sh >= 0 ? sh : -sh ) > len)
 171         {
 172           delta = len;
 173           sh = len;
 174         }
 175       else
 176         delta = (sh >= 0) ? sh: -sh;
 177
 178       if (sh > 0)
 179         {
 180           src = &sptr[delta * soffset];
 181           dest = rptr;
 182         }
 183       else
 184         {
 185           src = sptr;
 186           dest = &rptr[delta * roffset];
 187         }
 188       for (n = 0; n < len - delta; n++)
 189         {
 190           memcpy (dest, src, size);
 191           dest += roffset;
 192           src += soffset;
 193         }
 194       if (sh < 0)
 195         dest = rptr;
 196       n = delta;
 197
 198       if (pbound)
 199         while (n--)
 200           {
 201             memcpy (dest, pbound, size);
 202             dest += roffset;
 203           }
 204       else
 205         while (n--)
 206           {
 207             index_type i;
 208
 209             if (filler_len == 1)
 210               memset (dest, filler[0], size);
 211             else
 212               for (i = 0; i < size; i += filler_len)
 213                 memcpy (&dest[i], filler, filler_len);
 214
 215             dest += roffset;
 216           }
 217
 218       /* Advance to the next section.  */
 219       rptr += rstride0;
 220       sptr += sstride0;
 221       hptr += hstride0;
 222       count[0]++;
 223       n = 0;
 224       while (count[n] == extent[n])
 225         {
 226           /* When we get to the end of a dimension, reset it and increment
 227              the next dimension.  */
 228           count[n] = 0;
 229           /* We could precalculate these products, but this is a less
 230              frequently used path so probably not worth it.  */
 231           rptr -= rstride[n] * extent[n];
 232           sptr -= sstride[n] * extent[n];
 233           hptr -= hstride[n] * extent[n];
 234           n++;
 235           if (n >= dim - 1)
 236             {
 237               /* Break out of the loop.  */
 238               rptr = NULL;
 239               break;
 240             }
 241           else
 242             {
 243               count[n]++;
 244               rptr += rstride[n];
 245               sptr += sstride[n];
 246               hptr += hstride[n];
 247             }
 248         }
 249     }
 250 }
 251
 252 void eoshift1_4 (gfc_array_char * const restrict,
 253         const gfc_array_char * const restrict,
 254         const gfc_array_i4 * const restrict, const char * const restrict,
 255         const GFC_INTEGER_4 * const restrict);
 256 export_proto(eoshift1_4);
 257
 258 void
 259 eoshift1_4 (gfc_array_char * const restrict ret,
 260         const gfc_array_char * const restrict array,
 261         const gfc_array_i4 * const restrict h,
 262         const char * const restrict pbound,
 263         const GFC_INTEGER_4 * const restrict pwhich)
 264 {
 265   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
 266 }
 267
 268
 269 void eoshift1_4_char (gfc_array_char * const restrict,
 270         GFC_INTEGER_4,
 271         const gfc_array_char * const restrict,
 272         const gfc_array_i4 * const restrict,
 273         const char * const restrict,
 274         const GFC_INTEGER_4 * const restrict,
 275         GFC_INTEGER_4, GFC_INTEGER_4);
 276 export_proto(eoshift1_4_char);
 277
 278 void
 279 eoshift1_4_char (gfc_array_char * const restrict ret,
 280         GFC_INTEGER_4 ret_length __attribute__((unused)),
 281         const gfc_array_char * const restrict array,
 282         const gfc_array_i4 * const restrict h,
 283         const char *  const restrict pbound,
 284         const GFC_INTEGER_4 * const restrict pwhich,
 285         GFC_INTEGER_4 array_length __attribute__((unused)),
 286         GFC_INTEGER_4 bound_length __attribute__((unused)))
 287 {
 288   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
 289 }
 290
 291
 292 void eoshift1_4_char4 (gfc_array_char * const restrict,
 293         GFC_INTEGER_4,
 294         const gfc_array_char * const restrict,
 295         const gfc_array_i4 * const restrict,
 296         const char * const restrict,
 297         const GFC_INTEGER_4 * const restrict,
 298         GFC_INTEGER_4, GFC_INTEGER_4);
 299 export_proto(eoshift1_4_char4);
 300
 301 void
 302 eoshift1_4_char4 (gfc_array_char * const restrict ret,
 303         GFC_INTEGER_4 ret_length __attribute__((unused)),
 304         const gfc_array_char * const restrict array,
 305         const gfc_array_i4 * const restrict h,
 306         const char *  const restrict pbound,
 307         const GFC_INTEGER_4 * const restrict pwhich,
 308         GFC_INTEGER_4 array_length __attribute__((unused)),
 309         GFC_INTEGER_4 bound_length __attribute__((unused)))
 310 {
 311   static const gfc_char4_t space = (unsigned char) ' ';
 312   eoshift1 (ret, array, h, pbound, pwhich,
 313             (const char *) &space, sizeof (gfc_char4_t));
 314 }
 315
 316 #endif