libgfortran/intrinsics/eoshift2.c

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