libgfortran/intrinsics/eoshift2.c

   1 /* Generic 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 Ligbfortran 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 /* TODO: make this work for large shifts when
  30    sizeof(int) < sizeof (index_type).  */
  31
  32 static void
  33 eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
  34           int shift, const gfc_array_char *bound, int which,
  35           const char *filler, index_type filler_len)
  36 {
  37   /* r.* indicates the return array.  */
  38   index_type rstride[GFC_MAX_DIMENSIONS];
  39   index_type rstride0;
  40   index_type roffset;
  41   char * restrict rptr;
  42   char *dest;
  43   /* s.* indicates the source array.  */
  44   index_type sstride[GFC_MAX_DIMENSIONS];
  45   index_type sstride0;
  46   index_type soffset;
  47   const char *sptr;
  48   const char *src;
  49   /* b.* indicates the bound array.  */
  50   index_type bstride[GFC_MAX_DIMENSIONS];
  51   index_type bstride0;
  52   const char *bptr;
  53
  54   index_type count[GFC_MAX_DIMENSIONS];
  55   index_type extent[GFC_MAX_DIMENSIONS];
  56   index_type dim;
  57   index_type len;
  58   index_type n;
  59   index_type arraysize;
  60   index_type size;
  61
  62   /* The compiler cannot figure out that these are set, initialize
  63      them to avoid warnings.  */
  64   len = 0;
  65   soffset = 0;
  66   roffset = 0;
  67
  68   size = GFC_DESCRIPTOR_SIZE (array);
  69
  70   arraysize = size0 ((array_t *) array);
  71
  72   if (ret->base_addr == NULL)
  73     {
  74       int i;
  75
  76       ret->offset = 0;
  77       ret->dtype = array->dtype;
  78
  79       /* xmallocarray allocates a single byte for zero size.  */
  80       ret->base_addr = xmallocarray (arraysize, size);
  81
  82       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  83         {
  84           index_type ub, str;
  85
  86           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  87
  88           if (i == 0)
  89             str = 1;
  90           else
  91             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
  92               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
  93
  94           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
  95         }
  96     }
  97   else if (unlikely (compile_options.bounds_check))
  98     {
  99       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 100                                  "return value", "EOSHIFT");
 101     }
 102
 103   if (arraysize == 0)
 104     return;
 105
 106   which = which - 1;
 107
 108   extent[0] = 1;
 109   count[0] = 0;
 110   sstride[0] = -1;
 111   rstride[0] = -1;
 112   bstride[0] = -1;
 113   n = 0;
 114   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 115     {
 116       if (dim == which)
 117         {
 118           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 119           if (roffset == 0)
 120             roffset = size;
 121           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 122           if (soffset == 0)
 123             soffset = size;
 124           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 125         }
 126       else
 127         {
 128           count[n] = 0;
 129           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 130           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 131           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 132           if (bound)
 133             bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
 134           else
 135             bstride[n] = 0;
 136           n++;
 137         }
 138     }
 139   if (sstride[0] == 0)
 140     sstride[0] = size;
 141   if (rstride[0] == 0)
 142     rstride[0] = size;
 143   if (bound && bstride[0] == 0)
 144     bstride[0] = size;
 145
 146   dim = GFC_DESCRIPTOR_RANK (array);
 147   rstride0 = rstride[0];
 148   sstride0 = sstride[0];
 149   bstride0 = bstride[0];
 150   rptr = ret->base_addr;
 151   sptr = array->base_addr;
 152
 153   if ((shift >= 0 ? shift : -shift ) > len)
 154     {
 155       shift = len;
 156       len = 0;
 157     }
 158   else
 159     {
 160       if (shift > 0)
 161         len = len - shift;
 162       else
 163         len = len + shift;
 164     }
 165
 166   if (bound)
 167     bptr = bound->base_addr;
 168   else
 169     bptr = NULL;
 170
 171   while (rptr)
 172     {
 173       /* Do the shift for this dimension.  */
 174       if (shift > 0)
 175         {
 176           src = &sptr[shift * soffset];
 177           dest = rptr;
 178         }
 179       else
 180         {
 181           src = sptr;
 182           dest = &rptr[-shift * 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;
 189           memcpy (dest, src, chunk);
 190           dest += chunk;
 191         }
 192       else
 193         {
 194           for (n = 0; n < len; n++)
 195             {
 196               memcpy (dest, src, size);
 197               dest += roffset;
 198               src += soffset;
 199             }
 200         }
 201       if (shift >= 0)
 202         {
 203           n = shift;
 204         }
 205       else
 206         {
 207           dest = rptr;
 208           n = -shift;
 209         }
 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       bptr += bstride0;
 235       count[0]++;
 236       n = 0;
 237       while (count[n] == extent[n])
 238         {
 239           /* When we get to the end of a dimension, reset it and increment
 240              the next dimension.  */
 241           count[n] = 0;
 242           /* We could precalculate these products, but this is a less
 243              frequently used path so probably not worth it.  */
 244           rptr -= rstride[n] * extent[n];
 245           sptr -= sstride[n] * extent[n];
 246           bptr -= bstride[n] * extent[n];
 247           n++;
 248           if (n >= dim - 1)
 249             {
 250               /* Break out of the loop.  */
 251               rptr = NULL;
 252               break;
 253             }
 254           else
 255             {
 256               count[n]++;
 257               rptr += rstride[n];
 258               sptr += sstride[n];
 259               bptr += bstride[n];
 260             }
 261         }
 262     }
 263 }
 264
 265
 266 #define DEFINE_EOSHIFT(N)                                                     \
 267   extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *,         \
 268                             const GFC_INTEGER_##N *, const gfc_array_char *,  \
 269                             const GFC_INTEGER_##N *);                         \
 270   export_proto(eoshift2_##N);                                                 \
 271                                                                               \
 272   void                                                                        \
 273   eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 274                 const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound,  \
 275                 const GFC_INTEGER_##N *pdim)                                  \
 276   {                                                                           \
 277     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 278               "\0", 1);                       \
 279   }                                                                           \
 280                                                                               \
 281   extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 282                                    const gfc_array_char *,                    \
 283                                    const GFC_INTEGER_##N *,                   \
 284                                    const gfc_array_char *,                    \
 285                                    const GFC_INTEGER_##N *,                   \
 286                                    GFC_INTEGER_4, GFC_INTEGER_4);             \
 287   export_proto(eoshift2_##N##_char);                                          \
 288                                                                               \
 289   void                                                                        \
 290   eoshift2_##N##_char (gfc_array_char *ret,                                   \
 291                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 292                        const gfc_array_char *array,                           \
 293                        const GFC_INTEGER_##N *pshift,                         \
 294                        const gfc_array_char *pbound,                          \
 295                        const GFC_INTEGER_##N *pdim,                           \
 296                        GFC_INTEGER_4 array_length __attribute__((unused)),    \
 297                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 298   {                                                                           \
 299     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 300               " ", 1);                                                        \
 301   }                                                                           \
 302                                                                               \
 303   extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,          \
 304                                     const gfc_array_char *,                   \
 305                                     const GFC_INTEGER_##N *,                  \
 306                                     const gfc_array_char *,                   \
 307                                     const GFC_INTEGER_##N *,                  \
 308                                     GFC_INTEGER_4, GFC_INTEGER_4);            \
 309   export_proto(eoshift2_##N##_char4);                                         \
 310                                                                               \
 311   void                                                                        \
 312   eoshift2_##N##_char4 (gfc_array_char *ret,                                  \
 313                         GFC_INTEGER_4 ret_length __attribute__((unused)),     \
 314                         const gfc_array_char *array,                          \
 315                         const GFC_INTEGER_##N *pshift,                        \
 316                         const gfc_array_char *pbound,                         \
 317                         const GFC_INTEGER_##N *pdim,                          \
 318                         GFC_INTEGER_4 array_length __attribute__((unused)),   \
 319                         GFC_INTEGER_4 bound_length __attribute__((unused)))   \
 320   {                                                                           \
 321     static const gfc_char4_t space = (unsigned char) ' ';                     \
 322     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 323               (const char *) &space,                                          \
 324               sizeof (gfc_char4_t));                                          \
 325   }
 326
 327 DEFINE_EOSHIFT (1);
 328 DEFINE_EOSHIFT (2);
 329 DEFINE_EOSHIFT (4);
 330 DEFINE_EOSHIFT (8);
 331 #ifdef HAVE_GFC_INTEGER_16
 332 DEFINE_EOSHIFT (16);
 333 #endif