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