libgfortran/intrinsics/eoshift0.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 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 /* TODO: make this work for large shifts when
  30    sizeof(int) < sizeof (index_type).  */
  31
  32 static void
  33 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
  34           int shift, const char * pbound, int which, index_type size,
  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
  50   index_type count[GFC_MAX_DIMENSIONS];
  51   index_type extent[GFC_MAX_DIMENSIONS];
  52   index_type dim;
  53   index_type len;
  54   index_type n;
  55   index_type arraysize;
  56
  57   /* The compiler cannot figure out that these are set, initialize
  58      them to avoid warnings.  */
  59   len = 0;
  60   soffset = 0;
  61   roffset = 0;
  62
  63   arraysize = size0 ((array_t *) array);
  64
  65   if (ret->base_addr == NULL)
  66     {
  67       int i;
  68
  69       ret->offset = 0;
  70       ret->dtype = array->dtype;
  71       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  72         {
  73           index_type ub, str;
  74
  75           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  76
  77           if (i == 0)
  78             str = 1;
  79           else
  80             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
  81               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
  82
  83           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
  84
  85         }
  86
  87       /* xmallocarray allocates a single byte for zero size.  */
  88       ret->base_addr = xmallocarray (arraysize, size);
  89     }
  90   else if (unlikely (compile_options.bounds_check))
  91     {
  92       bounds_equal_extents ((array_t *) ret, (array_t *) array,
  93                                  "return value", "EOSHIFT");
  94     }
  95
  96   if (arraysize == 0)
  97     return;
  98
  99   which = which - 1;
 100
 101   extent[0] = 1;
 102   count[0] = 0;
 103   sstride[0] = -1;
 104   rstride[0] = -1;
 105   n = 0;
 106   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 107     {
 108       if (dim == which)
 109         {
 110           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 111           if (roffset == 0)
 112             roffset = size;
 113           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 114           if (soffset == 0)
 115             soffset = size;
 116           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 117         }
 118       else
 119         {
 120           count[n] = 0;
 121           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 122           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 123           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 124           n++;
 125         }
 126     }
 127   if (sstride[0] == 0)
 128     sstride[0] = size;
 129   if (rstride[0] == 0)
 130     rstride[0] = size;
 131
 132   dim = GFC_DESCRIPTOR_RANK (array);
 133   rstride0 = rstride[0];
 134   sstride0 = sstride[0];
 135   rptr = ret->base_addr;
 136   sptr = array->base_addr;
 137
 138   if ((shift >= 0 ? shift : -shift) > len)
 139     {
 140       shift = len;
 141       len = 0;
 142     }
 143   else
 144     {
 145       if (shift > 0)
 146         len = len - shift;
 147       else
 148         len = len + shift;
 149     }
 150
 151   while (rptr)
 152     {
 153       /* Do the shift for this dimension.  */
 154       if (shift > 0)
 155         {
 156           src = &sptr[shift * soffset];
 157           dest = rptr;
 158         }
 159       else
 160         {
 161           src = sptr;
 162           dest = &rptr[-shift * roffset];
 163         }
 164       for (n = 0; n < len; n++)
 165         {
 166           memcpy (dest, src, size);
 167           dest += roffset;
 168           src += soffset;
 169         }
 170       if (shift >= 0)
 171         {
 172           n = shift;
 173         }
 174       else
 175         {
 176           dest = rptr;
 177           n = -shift;
 178         }
 179
 180       if (pbound)
 181         while (n--)
 182           {
 183             memcpy (dest, pbound, size);
 184             dest += roffset;
 185           }
 186       else
 187         while (n--)
 188           {
 189             index_type i;
 190
 191             if (filler_len == 1)
 192               memset (dest, filler[0], size);
 193             else
 194               for (i = 0; i < size ; i += filler_len)
 195                 memcpy (&dest[i], filler, filler_len);
 196
 197             dest += roffset;
 198           }
 199
 200       /* Advance to the next section.  */
 201       rptr += rstride0;
 202       sptr += sstride0;
 203       count[0]++;
 204       n = 0;
 205       while (count[n] == extent[n])
 206         {
 207           /* When we get to the end of a dimension, reset it and increment
 208              the next dimension.  */
 209           count[n] = 0;
 210           /* We could precalculate these products, but this is a less
 211              frequently used path so probably not worth it.  */
 212           rptr -= rstride[n] * extent[n];
 213           sptr -= sstride[n] * extent[n];
 214           n++;
 215           if (n >= dim - 1)
 216             {
 217               /* Break out of the loop.  */
 218               rptr = NULL;
 219               break;
 220             }
 221           else
 222             {
 223               count[n]++;
 224               rptr += rstride[n];
 225               sptr += sstride[n];
 226             }
 227         }
 228     }
 229 }
 230
 231
 232 #define DEFINE_EOSHIFT(N)                                                     \
 233   extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *,         \
 234                             const GFC_INTEGER_##N *, const char *,            \
 235                             const GFC_INTEGER_##N *);                         \
 236   export_proto(eoshift0_##N);                                                 \
 237                                                                               \
 238   void                                                                        \
 239   eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 240                 const GFC_INTEGER_##N *pshift, const char *pbound,            \
 241                 const GFC_INTEGER_##N *pdim)                                  \
 242   {                                                                           \
 243     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 244               GFC_DESCRIPTOR_SIZE (array), "\0", 1);                          \
 245   }                                                                           \
 246                                                                               \
 247   extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 248                                    const gfc_array_char *,                    \
 249                                    const GFC_INTEGER_##N *, const char *,     \
 250                                    const GFC_INTEGER_##N *, GFC_INTEGER_4,    \
 251                                    GFC_INTEGER_4);                            \
 252   export_proto(eoshift0_##N##_char);                                          \
 253                                                                               \
 254   void                                                                        \
 255   eoshift0_##N##_char (gfc_array_char *ret,                                   \
 256                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 257                        const gfc_array_char *array,                           \
 258                        const GFC_INTEGER_##N *pshift,                         \
 259                        const char *pbound,                                    \
 260                        const GFC_INTEGER_##N *pdim,                           \
 261                        GFC_INTEGER_4 array_length,                            \
 262                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 263   {                                                                           \
 264     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 265               array_length, " ", 1);                                          \
 266   }                                                                           \
 267                                                                               \
 268   extern void eoshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,          \
 269                                     const gfc_array_char *,                   \
 270                                     const GFC_INTEGER_##N *, const char *,    \
 271                                     const GFC_INTEGER_##N *, GFC_INTEGER_4,   \
 272                                     GFC_INTEGER_4);                           \
 273   export_proto(eoshift0_##N##_char4);                                         \
 274                                                                               \
 275   void                                                                        \
 276   eoshift0_##N##_char4 (gfc_array_char *ret,                                  \
 277                         GFC_INTEGER_4 ret_length __attribute__((unused)),     \
 278                         const gfc_array_char *array,                          \
 279                         const GFC_INTEGER_##N *pshift,                        \
 280                         const char *pbound,                                   \
 281                         const GFC_INTEGER_##N *pdim,                          \
 282                         GFC_INTEGER_4 array_length,                           \
 283                         GFC_INTEGER_4 bound_length __attribute__((unused)))   \
 284   {                                                                           \
 285     static const gfc_char4_t space = (unsigned char) ' ';                     \
 286     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 287               array_length * sizeof (gfc_char4_t), (const char *) &space,     \
 288               sizeof (gfc_char4_t));                                          \
 289   }
 290
 291 DEFINE_EOSHIFT (1);
 292 DEFINE_EOSHIFT (2);
 293 DEFINE_EOSHIFT (4);
 294 DEFINE_EOSHIFT (8);
 295 #ifdef HAVE_GFC_INTEGER_16
 296 DEFINE_EOSHIFT (16);
 297 #endif