libgfortran/intrinsics/eoshift0.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 Libgfortran 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 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
  42           int shift, const char * pbound, int which, index_type size,
  43           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
  58   index_type count[GFC_MAX_DIMENSIONS];
  59   index_type extent[GFC_MAX_DIMENSIONS];
  60   index_type dim;
  61   index_type len;
  62   index_type n;
  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   if (ret->data == NULL)
  71     {
  72       int i;
  73
  74       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  75       ret->offset = 0;
  76       ret->dtype = array->dtype;
  77       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  78         {
  79           ret->dim[i].lbound = 0;
  80           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  81
  82           if (i == 0)
  83             ret->dim[i].stride = 1;
  84           else
  85             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  86         }
  87     }
  88
  89   which = which - 1;
  90
  91   extent[0] = 1;
  92   count[0] = 0;
  93   sstride[0] = -1;
  94   rstride[0] = -1;
  95   n = 0;
  96   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
  97     {
  98       if (dim == which)
  99         {
 100           roffset = ret->dim[dim].stride * size;
 101           if (roffset == 0)
 102             roffset = size;
 103           soffset = array->dim[dim].stride * size;
 104           if (soffset == 0)
 105             soffset = size;
 106           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 107         }
 108       else
 109         {
 110           count[n] = 0;
 111           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 112           rstride[n] = ret->dim[dim].stride * size;
 113           sstride[n] = array->dim[dim].stride * size;
 114           n++;
 115         }
 116     }
 117   if (sstride[0] == 0)
 118     sstride[0] = size;
 119   if (rstride[0] == 0)
 120     rstride[0] = size;
 121
 122   dim = GFC_DESCRIPTOR_RANK (array);
 123   rstride0 = rstride[0];
 124   sstride0 = sstride[0];
 125   rptr = ret->data;
 126   sptr = array->data;
 127
 128   if ((shift >= 0 ? shift : -shift) > len)
 129     {
 130       shift = len;
 131       len = 0;
 132     }
 133   else
 134     {
 135       if (shift > 0)
 136         len = len - shift;
 137       else
 138         len = len + shift;
 139     }
 140
 141   while (rptr)
 142     {
 143       /* Do the shift for this dimension.  */
 144       if (shift > 0)
 145         {
 146           src = &sptr[shift * soffset];
 147           dest = rptr;
 148         }
 149       else
 150         {
 151           src = sptr;
 152           dest = &rptr[-shift * roffset];
 153         }
 154       for (n = 0; n < len; n++)
 155         {
 156           memcpy (dest, src, size);
 157           dest += roffset;
 158           src += soffset;
 159         }
 160       if (shift >= 0)
 161         {
 162           n = shift;
 163         }
 164       else
 165         {
 166           dest = rptr;
 167           n = -shift;
 168         }
 169
 170       if (pbound)
 171         while (n--)
 172           {
 173             memcpy (dest, pbound, size);
 174             dest += roffset;
 175           }
 176       else
 177         while (n--)
 178           {
 179             memset (dest, filler, size);
 180             dest += roffset;
 181           }
 182
 183       /* Advance to the next section.  */
 184       rptr += rstride0;
 185       sptr += sstride0;
 186       count[0]++;
 187       n = 0;
 188       while (count[n] == extent[n])
 189         {
 190           /* When we get to the end of a dimension, reset it and increment
 191              the next dimension.  */
 192           count[n] = 0;
 193           /* We could precalculate these products, but this is a less
 194              frequently used path so probably not worth it.  */
 195           rptr -= rstride[n] * extent[n];
 196           sptr -= sstride[n] * extent[n];
 197           n++;
 198           if (n >= dim - 1)
 199             {
 200               /* Break out of the loop.  */
 201               rptr = NULL;
 202               break;
 203             }
 204           else
 205             {
 206               count[n]++;
 207               rptr += rstride[n];
 208               sptr += sstride[n];
 209             }
 210         }
 211     }
 212 }
 213
 214
 215 #define DEFINE_EOSHIFT(N)                                                     \
 216   extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *,         \
 217                             const GFC_INTEGER_##N *, const char *,            \
 218                             const GFC_INTEGER_##N *);                         \
 219   export_proto(eoshift0_##N);                                                 \
 220                                                                               \
 221   void                                                                        \
 222   eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 223                 const GFC_INTEGER_##N *pshift, const char *pbound,            \
 224                 const GFC_INTEGER_##N *pdim)                                  \
 225   {                                                                           \
 226     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 227               GFC_DESCRIPTOR_SIZE (array), 0);                                \
 228   }                                                                           \
 229                                                                               \
 230   extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 231                                    const gfc_array_char *,                    \
 232                                    const GFC_INTEGER_##N *, const char *,     \
 233                                    const GFC_INTEGER_##N *, GFC_INTEGER_4,    \
 234                                    GFC_INTEGER_4);                            \
 235   export_proto(eoshift0_##N##_char);                                          \
 236                                                                               \
 237   void                                                                        \
 238   eoshift0_##N##_char (gfc_array_char *ret,                                   \
 239                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 240                        const gfc_array_char *array,                           \
 241                        const GFC_INTEGER_##N *pshift,                         \
 242                        const char *pbound,                                    \
 243                        const GFC_INTEGER_##N *pdim,                           \
 244                        GFC_INTEGER_4 array_length,                            \
 245                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 246   {                                                                           \
 247     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 248               array_length, ' ');                                             \
 249   }
 250
 251 DEFINE_EOSHIFT (1);
 252 DEFINE_EOSHIFT (2);
 253 DEFINE_EOSHIFT (4);
 254 DEFINE_EOSHIFT (8);