libgfortran/intrinsics/eoshift2.c

   1 /* Generic implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005, 2007 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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Ligbfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35
  36 /* TODO: make this work for large shifts when
  37    sizeof(int) < sizeof (index_type).  */
  38
  39 static void
  40 eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
  41           int shift, const gfc_array_char *bound, int which,
  42           index_type size, const char *filler, index_type filler_len)
  43 {
  44   /* r.* indicates the return array.  */
  45   index_type rstride[GFC_MAX_DIMENSIONS];
  46   index_type rstride0;
  47   index_type roffset;
  48   char * restrict rptr;
  49   char *dest;
  50   /* s.* indicates the source array.  */
  51   index_type sstride[GFC_MAX_DIMENSIONS];
  52   index_type sstride0;
  53   index_type soffset;
  54   const char *sptr;
  55   const char *src;
  56   /* b.* indicates the bound array.  */
  57   index_type bstride[GFC_MAX_DIMENSIONS];
  58   index_type bstride0;
  59   const char *bptr;
  60
  61   index_type count[GFC_MAX_DIMENSIONS];
  62   index_type extent[GFC_MAX_DIMENSIONS];
  63   index_type dim;
  64   index_type len;
  65   index_type n;
  66   index_type arraysize;
  67
  68   /* The compiler cannot figure out that these are set, initialize
  69      them to avoid warnings.  */
  70   len = 0;
  71   soffset = 0;
  72   roffset = 0;
  73
  74   arraysize = size0 ((array_t *) array);
  75
  76   if (ret->data == NULL)
  77     {
  78       int i;
  79
  80       ret->data = internal_malloc_size (size * arraysize);
  81       ret->offset = 0;
  82       ret->dtype = array->dtype;
  83       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  84         {
  85           ret->dim[i].lbound = 0;
  86           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  87
  88           if (i == 0)
  89             ret->dim[i].stride = 1;
  90           else
  91             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  92         }
  93     }
  94   else
  95     {
  96       if (size0 ((array_t *) ret) == 0)
  97         return;
  98     }
  99
 100   if (arraysize == 0 && filler == NULL)
 101     return;
 102
 103   which = which - 1;
 104
 105   extent[0] = 1;
 106   count[0] = 0;
 107   sstride[0] = -1;
 108   rstride[0] = -1;
 109   bstride[0] = -1;
 110   n = 0;
 111   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 112     {
 113       if (dim == which)
 114         {
 115           roffset = ret->dim[dim].stride * size;
 116           if (roffset == 0)
 117             roffset = size;
 118           soffset = array->dim[dim].stride * size;
 119           if (soffset == 0)
 120             soffset = size;
 121           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 122         }
 123       else
 124         {
 125           count[n] = 0;
 126           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 127           rstride[n] = ret->dim[dim].stride * size;
 128           sstride[n] = array->dim[dim].stride * size;
 129           if (bound)
 130             bstride[n] = bound->dim[n].stride * size;
 131           else
 132             bstride[n] = 0;
 133           n++;
 134         }
 135     }
 136   if (sstride[0] == 0)
 137     sstride[0] = size;
 138   if (rstride[0] == 0)
 139     rstride[0] = size;
 140   if (bound && bstride[0] == 0)
 141     bstride[0] = size;
 142
 143   dim = GFC_DESCRIPTOR_RANK (array);
 144   rstride0 = rstride[0];
 145   sstride0 = sstride[0];
 146   bstride0 = bstride[0];
 147   rptr = ret->data;
 148   sptr = array->data;
 149
 150   if ((shift >= 0 ? shift : -shift ) > len)
 151     {
 152       shift = len;
 153       len = 0;
 154     }
 155   else
 156     {
 157       if (shift > 0)
 158         len = len - shift;
 159       else
 160         len = len + shift;
 161     }
 162
 163   if (bound)
 164     bptr = bound->data;
 165   else
 166     bptr = NULL;
 167
 168   while (rptr)
 169     {
 170       /* Do the shift for this dimension.  */
 171       if (shift > 0)
 172         {
 173           src = &sptr[shift * soffset];
 174           dest = rptr;
 175         }
 176       else
 177         {
 178           src = sptr;
 179           dest = &rptr[-shift * roffset];
 180         }
 181       for (n = 0; n < len; n++)
 182         {
 183           memcpy (dest, src, size);
 184           dest += roffset;
 185           src += soffset;
 186         }
 187       if (shift >= 0)
 188         {
 189           n = shift;
 190         }
 191       else
 192         {
 193           dest = rptr;
 194           n = -shift;
 195         }
 196
 197       if (bptr)
 198         while (n--)
 199           {
 200             memcpy (dest, bptr, size);
 201             dest += roffset;
 202           }
 203       else
 204         while (n--)
 205           {
 206             index_type i;
 207
 208             if (filler_len == 1)
 209               memset (dest, filler[0], size);
 210             else
 211               for (i = 0; i < size ; i += filler_len)
 212                 memcpy (&dest[i], filler, filler_len);
 213
 214             dest += roffset;
 215           }
 216
 217       /* Advance to the next section.  */
 218       rptr += rstride0;
 219       sptr += sstride0;
 220       bptr += bstride0;
 221       count[0]++;
 222       n = 0;
 223       while (count[n] == extent[n])
 224         {
 225           /* When we get to the end of a dimension, reset it and increment
 226              the next dimension.  */
 227           count[n] = 0;
 228           /* We could precalculate these products, but this is a less
 229              frequently used path so probably not worth it.  */
 230           rptr -= rstride[n] * extent[n];
 231           sptr -= sstride[n] * extent[n];
 232           bptr -= bstride[n] * extent[n];
 233           n++;
 234           if (n >= dim - 1)
 235             {
 236               /* Break out of the loop.  */
 237               rptr = NULL;
 238               break;
 239             }
 240           else
 241             {
 242               count[n]++;
 243               rptr += rstride[n];
 244               sptr += sstride[n];
 245               bptr += bstride[n];
 246             }
 247         }
 248     }
 249 }
 250
 251
 252 #define DEFINE_EOSHIFT(N)                                                     \
 253   extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *,         \
 254                             const GFC_INTEGER_##N *, const gfc_array_char *,  \
 255                             const GFC_INTEGER_##N *);                         \
 256   export_proto(eoshift2_##N);                                                 \
 257                                                                               \
 258   void                                                                        \
 259   eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 260                 const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound,  \
 261                 const GFC_INTEGER_##N *pdim)                                  \
 262   {                                                                           \
 263     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 264               GFC_DESCRIPTOR_SIZE (array), "\0", 1);                          \
 265   }                                                                           \
 266                                                                               \
 267   extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 268                                    const gfc_array_char *,                    \
 269                                    const GFC_INTEGER_##N *,                   \
 270                                    const gfc_array_char *,                    \
 271                                    const GFC_INTEGER_##N *,                   \
 272                                    GFC_INTEGER_4, GFC_INTEGER_4);             \
 273   export_proto(eoshift2_##N##_char);                                          \
 274                                                                               \
 275   void                                                                        \
 276   eoshift2_##N##_char (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 gfc_array_char *pbound,                          \
 281                        const GFC_INTEGER_##N *pdim,                           \
 282                        GFC_INTEGER_4 array_length,                            \
 283                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 284   {                                                                           \
 285     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 286               array_length, " ", 1);                                          \
 287   }                                                                           \
 288                                                                               \
 289   extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,          \
 290                                     const gfc_array_char *,                   \
 291                                     const GFC_INTEGER_##N *,                  \
 292                                     const gfc_array_char *,                   \
 293                                     const GFC_INTEGER_##N *,                  \
 294                                     GFC_INTEGER_4, GFC_INTEGER_4);            \
 295   export_proto(eoshift2_##N##_char4);                                         \
 296                                                                               \
 297   void                                                                        \
 298   eoshift2_##N##_char4 (gfc_array_char *ret,                                  \
 299                         GFC_INTEGER_4 ret_length __attribute__((unused)),     \
 300                         const gfc_array_char *array,                          \
 301                         const GFC_INTEGER_##N *pshift,                        \
 302                         const gfc_array_char *pbound,                         \
 303                         const GFC_INTEGER_##N *pdim,                          \
 304                         GFC_INTEGER_4 array_length,                           \
 305                         GFC_INTEGER_4 bound_length __attribute__((unused)))   \
 306   {                                                                           \
 307     static const gfc_char4_t space = (unsigned char) ' ';                     \
 308     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 309               array_length * sizeof (gfc_char4_t), (const char *) &space,     \
 310               sizeof (gfc_char4_t));                                          \
 311   }
 312
 313 DEFINE_EOSHIFT (1);
 314 DEFINE_EOSHIFT (2);
 315 DEFINE_EOSHIFT (4);
 316 DEFINE_EOSHIFT (8);
 317 #ifdef HAVE_GFC_INTEGER_16
 318 DEFINE_EOSHIFT (16);
 319 #endif