libgfortran/intrinsics/eoshift2.c

   1 /* Generic implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005 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 "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35 #include "libgfortran.h"
  36
  37 /* TODO: make this work for large shifts when
  38    sizeof(int) < sizeof (index_type).  */
  39
  40 static void
  41 eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
  42           int shift, const gfc_array_char *bound, int which,
  43           index_type size, char filler)
  44 {
  45   /* r.* indicates the return array.  */
  46   index_type rstride[GFC_MAX_DIMENSIONS];
  47   index_type rstride0;
  48   index_type roffset;
  49   char *rptr;
  50   char *dest;
  51   /* s.* indicates the source array.  */
  52   index_type sstride[GFC_MAX_DIMENSIONS];
  53   index_type sstride0;
  54   index_type soffset;
  55   const char *sptr;
  56   const char *src;
  57   /* b.* indicates the bound array.  */
  58   index_type bstride[GFC_MAX_DIMENSIONS];
  59   index_type bstride0;
  60   const char *bptr;
  61
  62   index_type count[GFC_MAX_DIMENSIONS];
  63   index_type extent[GFC_MAX_DIMENSIONS];
  64   index_type dim;
  65   index_type len;
  66   index_type n;
  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   if (ret->data == NULL)
  75     {
  76       int i;
  77
  78       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  79       ret->offset = 0;
  80       ret->dtype = array->dtype;
  81       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  82         {
  83           ret->dim[i].lbound = 0;
  84           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  85
  86           if (i == 0)
  87             ret->dim[i].stride = 1;
  88           else
  89             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  90         }
  91     }
  92
  93   which = which - 1;
  94
  95   extent[0] = 1;
  96   count[0] = 0;
  97   n = 0;
  98   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
  99     {
 100       if (dim == which)
 101         {
 102           roffset = ret->dim[dim].stride * size;
 103           if (roffset == 0)
 104             roffset = size;
 105           soffset = array->dim[dim].stride * size;
 106           if (soffset == 0)
 107             soffset = size;
 108           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 109         }
 110       else
 111         {
 112           count[n] = 0;
 113           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 114           rstride[n] = ret->dim[dim].stride * size;
 115           sstride[n] = array->dim[dim].stride * size;
 116           if (bound)
 117             bstride[n] = bound->dim[n].stride * size;
 118           else
 119             bstride[n] = 0;
 120           n++;
 121         }
 122     }
 123   if (sstride[0] == 0)
 124     sstride[0] = size;
 125   if (rstride[0] == 0)
 126     rstride[0] = size;
 127   if (bound && bstride[0] == 0)
 128     bstride[0] = size;
 129
 130   dim = GFC_DESCRIPTOR_RANK (array);
 131   rstride0 = rstride[0];
 132   sstride0 = sstride[0];
 133   bstride0 = bstride[0];
 134   rptr = ret->data;
 135   sptr = array->data;
 136
 137   if ((shift >= 0 ? shift : -shift ) > len)
 138     {
 139       shift = len;
 140       len = 0;
 141     }
 142   else
 143     {
 144       if (shift > 0)
 145         len = len - shift;
 146       else
 147         len = len + shift;
 148     }
 149
 150   if (bound)
 151     bptr = bound->data;
 152   else
 153     bptr = NULL;
 154
 155   while (rptr)
 156     {
 157       /* Do the shift for this dimension.  */
 158       if (shift > 0)
 159         {
 160           src = &sptr[shift * soffset];
 161           dest = rptr;
 162         }
 163       else
 164         {
 165           src = sptr;
 166           dest = &rptr[-shift * roffset];
 167         }
 168       for (n = 0; n < len; n++)
 169         {
 170           memcpy (dest, src, size);
 171           dest += roffset;
 172           src += soffset;
 173         }
 174       if (shift >= 0)
 175         {
 176           n = shift;
 177         }
 178       else
 179         {
 180           dest = rptr;
 181           n = -shift;
 182         }
 183
 184       if (bptr)
 185         while (n--)
 186           {
 187             memcpy (dest, bptr, size);
 188             dest += roffset;
 189           }
 190       else
 191         while (n--)
 192           {
 193             memset (dest, filler, size);
 194             dest += roffset;
 195           }
 196
 197       /* Advance to the next section.  */
 198       rptr += rstride0;
 199       sptr += sstride0;
 200       bptr += bstride0;
 201       count[0]++;
 202       n = 0;
 203       while (count[n] == extent[n])
 204         {
 205           /* When we get to the end of a dimension, reset it and increment
 206              the next dimension.  */
 207           count[n] = 0;
 208           /* We could precalculate these products, but this is a less
 209              frequently used path so probably not worth it.  */
 210           rptr -= rstride[n] * extent[n];
 211           sptr -= sstride[n] * extent[n];
 212           bptr -= bstride[n] * extent[n];
 213           n++;
 214           if (n >= dim - 1)
 215             {
 216               /* Break out of the loop.  */
 217               rptr = NULL;
 218               break;
 219             }
 220           else
 221             {
 222               count[n]++;
 223               rptr += rstride[n];
 224               sptr += sstride[n];
 225               bptr += bstride[n];
 226             }
 227         }
 228     }
 229 }
 230
 231
 232 #define DEFINE_EOSHIFT(N)                                                     \
 233   extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *,         \
 234                             const GFC_INTEGER_##N *, const gfc_array_char *,  \
 235                             const GFC_INTEGER_##N *);                         \
 236   export_proto(eoshift2_##N);                                                 \
 237                                                                               \
 238   void                                                                        \
 239   eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 240                 const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound,  \
 241                 const GFC_INTEGER_##N *pdim)                                  \
 242   {                                                                           \
 243     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 244               GFC_DESCRIPTOR_SIZE (array), 0);                                \
 245   }                                                                           \
 246                                                                               \
 247   extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 248                                    const gfc_array_char *,                    \
 249                                    const GFC_INTEGER_##N *,                   \
 250                                    const gfc_array_char *,                    \
 251                                    const GFC_INTEGER_##N *,                   \
 252                                    GFC_INTEGER_4, GFC_INTEGER_4);             \
 253   export_proto(eoshift2_##N##_char);                                          \
 254                                                                               \
 255   void                                                                        \
 256   eoshift2_##N##_char (gfc_array_char *ret,                                   \
 257                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 258                        const gfc_array_char *array,                           \
 259                        const GFC_INTEGER_##N *pshift,                         \
 260                        const gfc_array_char *pbound,                          \
 261                        const GFC_INTEGER_##N *pdim,                           \
 262                        GFC_INTEGER_4 array_length,                            \
 263                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 264   {                                                                           \
 265     eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 266               array_length, ' ');                                             \
 267   }
 268
 269 DEFINE_EOSHIFT (1);
 270 DEFINE_EOSHIFT (2);
 271 DEFINE_EOSHIFT (4);
 272 DEFINE_EOSHIFT (8);