libgfortran/intrinsics/eoshift0.c

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