libgfortran/intrinsics/eoshift2.c

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