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       for (n = 0; n < len; n++)
 185         {
 186           memcpy (dest, src, size);
 187           dest += roffset;
 188           src += soffset;
 189         }
 190       if (shift >= 0)
 191         {
 192           n = shift;
 193         }
 194       else
 195         {
 196           dest = rptr;
 197           n = -shift;
 198         }
 199
 200       if (bptr)
 201         while (n--)
 202           {
 203             memcpy (dest, bptr, size);
 204             dest += roffset;
 205           }
 206       else
 207         while (n--)
 208           {
 209             index_type i;
 210
 211             if (filler_len == 1)
 212               memset (dest, filler[0], size);
 213             else
 214               for (i = 0; i < size ; i += filler_len)
 215                 memcpy (&dest[i], filler, filler_len);
 216
 217             dest += roffset;
 218           }
 219
 220       /* Advance to the next section.  */
 221       rptr += rstride0;
 222       sptr += sstride0;
 223       bptr += bstride0;
 224       count[0]++;
 225       n = 0;
 226       while (count[n] == extent[n])
 227         {
 228           /* When we get to the end of a dimension, reset it and increment
 229              the next dimension.  */
 230           count[n] = 0;
 231           /* We could precalculate these products, but this is a less
 232              frequently used path so probably not worth it.  */
 233           rptr -= rstride[n] * extent[n];
 234           sptr -= sstride[n] * extent[n];
 235           bptr -= bstride[n] * extent[n];
 236           n++;
 237           if (n >= dim - 1)
 238             {
 239               /* Break out of the loop.  */
 240               rptr = NULL;
 241               break;
 242             }
 243           else
 244             {
 245               count[n]++;
 246               rptr += rstride[n];
 247               sptr += sstride[n];
 248               bptr += bstride[n];
 249             }
 250         }
 251     }
 252 }
 253
 254
 255 #define DEFINE_EOSHIFT(N)                                                     \
 256   extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *,         \
 257                             const GFC_INTEGER_##N *, const gfc_array_char *,  \
 258                             const GFC_INTEGER_##N *);                         \
 259   export_proto(eoshift2_##N);                                                 \
 260                                                                               \
 261   void                                                                        \
 262   eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 263                 const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound,  \
 264                 const GFC_INTEGER_##N *pdim)                                  \
 265   {                                                                           \
 266     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 267               "\0", 1);                       \
 268   }                                                                           \
 269                                                                               \
 270   extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 271                                    const gfc_array_char *,                    \
 272                                    const GFC_INTEGER_##N *,                   \
 273                                    const gfc_array_char *,                    \
 274                                    const GFC_INTEGER_##N *,                   \
 275                                    GFC_INTEGER_4, GFC_INTEGER_4);             \
 276   export_proto(eoshift2_##N##_char);                                          \
 277                                                                               \
 278   void                                                                        \
 279   eoshift2_##N##_char (gfc_array_char *ret,                                   \
 280                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 281                        const gfc_array_char *array,                           \
 282                        const GFC_INTEGER_##N *pshift,                         \
 283                        const gfc_array_char *pbound,                          \
 284                        const GFC_INTEGER_##N *pdim,                           \
 285                        GFC_INTEGER_4 array_length __attribute__((unused)),    \
 286                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 287   {                                                                           \
 288     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 289               " ", 1);                                                        \
 290   }                                                                           \
 291                                                                               \
 292   extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,          \
 293                                     const gfc_array_char *,                   \
 294                                     const GFC_INTEGER_##N *,                  \
 295                                     const gfc_array_char *,                   \
 296                                     const GFC_INTEGER_##N *,                  \
 297                                     GFC_INTEGER_4, GFC_INTEGER_4);            \
 298   export_proto(eoshift2_##N##_char4);                                         \
 299                                                                               \
 300   void                                                                        \
 301   eoshift2_##N##_char4 (gfc_array_char *ret,                                  \
 302                         GFC_INTEGER_4 ret_length __attribute__((unused)),     \
 303                         const gfc_array_char *array,                          \
 304                         const GFC_INTEGER_##N *pshift,                        \
 305                         const gfc_array_char *pbound,                         \
 306                         const GFC_INTEGER_##N *pdim,                          \
 307                         GFC_INTEGER_4 array_length __attribute__((unused)),   \
 308                         GFC_INTEGER_4 bound_length __attribute__((unused)))   \
 309   {                                                                           \
 310     static const gfc_char4_t space = (unsigned char) ' ';                     \
 311     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 312               (const char *) &space,                                          \
 313               sizeof (gfc_char4_t));                                          \
 314   }
 315
 316 DEFINE_EOSHIFT (1);
 317 DEFINE_EOSHIFT (2);
 318 DEFINE_EOSHIFT (4);
 319 DEFINE_EOSHIFT (8);
 320 #ifdef HAVE_GFC_INTEGER_16
 321 DEFINE_EOSHIFT (16);
 322 #endif