libgfortran/intrinsics/eoshift2.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 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., 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 eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
  45           int shift, const gfc_array_char *bound, int which)
  46 {
  47   /* r.* indicates the return array.  */
  48   index_type rstride[GFC_MAX_DIMENSIONS];
  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];
  55   index_type sstride0;
  56   index_type soffset;
  57   const char *sptr;
  58   const char *src;
  59   /* b.* indicates the bound array.  */
  60   index_type bstride[GFC_MAX_DIMENSIONS];
  61   index_type bstride0;
  62   const char *bptr;
  63
  64   index_type count[GFC_MAX_DIMENSIONS];
  65   index_type extent[GFC_MAX_DIMENSIONS];
  66   index_type dim;
  67   index_type size;
  68   index_type len;
  69   index_type n;
  70
  71   size = GFC_DESCRIPTOR_SIZE (ret);
  72
  73   if (ret->data == NULL)
  74     {
  75       int i;
  76
  77       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  78       ret->base = 0;
  79       ret->dtype = array->dtype;
  80       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  81         {
  82           ret->dim[i].lbound = 0;
  83           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  84
  85           if (i == 0)
  86             ret->dim[i].stride = 1;
  87           else
  88             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  89         }
  90     }
  91
  92   which = which - 1;
  93
  94   extent[0] = 1;
  95   count[0] = 0;
  96   size = GFC_DESCRIPTOR_SIZE (array);
  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   if (bound)
 137     bptr = bound->data;
 138   else
 139     bptr = zeros;
 140
 141   if (shift > 0)
 142     len = len - shift;
 143   else
 144     len = len + shift;
 145
 146   while (rptr)
 147     {
 148       /* Do the shift for this dimension.  */
 149       if (shift > 0)
 150         {
 151           src = &sptr[shift * soffset];
 152           dest = rptr;
 153         }
 154       else
 155         {
 156           src = sptr;
 157           dest = &rptr[-shift * roffset];
 158         }
 159       for (n = 0; n < len; n++)
 160         {
 161           memcpy (dest, src, size);
 162           dest += roffset;
 163           src += soffset;
 164         }
 165       if (shift >= 0)
 166         {
 167           n = shift;
 168         }
 169       else
 170         {
 171           dest = rptr;
 172           n = -shift;
 173         }
 174
 175       while (n--)
 176         {
 177           memcpy (dest, bptr, size);
 178           dest += roffset;
 179         }
 180
 181       /* Advance to the next section.  */
 182       rptr += rstride0;
 183       sptr += sstride0;
 184       bptr += bstride0;
 185       count[0]++;
 186       n = 0;
 187       while (count[n] == extent[n])
 188         {
 189           /* When we get to the end of a dimension, reset it and increment
 190              the next dimension.  */
 191           count[n] = 0;
 192           /* We could precalculate these products, but this is a less
 193              frequently used path so proabably not worth it.  */
 194           rptr -= rstride[n] * extent[n];
 195           sptr -= sstride[n] * extent[n];
 196           bptr -= bstride[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               bptr += bstride[n];
 210             }
 211         }
 212     }
 213 }
 214
 215
 216 extern void eoshift2_1 (gfc_array_char *, const gfc_array_char *,
 217                         const GFC_INTEGER_1 *, const gfc_array_char *,
 218                         const GFC_INTEGER_1 *);
 219 export_proto(eoshift2_1);
 220
 221 void
 222 eoshift2_1 (gfc_array_char *ret, const gfc_array_char *array,
 223             const GFC_INTEGER_1 *pshift, const gfc_array_char *bound,
 224             const GFC_INTEGER_1 *pdim)
 225 {
 226   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 227 }
 228
 229
 230 extern void eoshift2_2 (gfc_array_char *, const gfc_array_char *,
 231                         const GFC_INTEGER_2 *, const gfc_array_char *,
 232                         const GFC_INTEGER_2 *);
 233 export_proto(eoshift2_2);
 234
 235 void
 236 eoshift2_2 (gfc_array_char *ret, const gfc_array_char *array,
 237             const GFC_INTEGER_2 *pshift, const gfc_array_char *bound,
 238             const GFC_INTEGER_2 *pdim)
 239 {
 240   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 241 }
 242
 243
 244 extern void eoshift2_4 (gfc_array_char *, const gfc_array_char *,
 245                         const GFC_INTEGER_4 *, const gfc_array_char *,
 246                         const GFC_INTEGER_4 *);
 247 export_proto(eoshift2_4);
 248
 249 void
 250 eoshift2_4 (gfc_array_char *ret, const gfc_array_char *array,
 251             const GFC_INTEGER_4 *pshift, const gfc_array_char *bound,
 252             const GFC_INTEGER_4 *pdim)
 253 {
 254   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 255 }
 256
 257
 258 extern void eoshift2_8 (gfc_array_char *, const gfc_array_char *,
 259                         const GFC_INTEGER_8 *, const gfc_array_char *,
 260                         const GFC_INTEGER_8 *);
 261 export_proto(eoshift2_8);
 262
 263 void
 264 eoshift2_8 (gfc_array_char *ret, const gfc_array_char *array,
 265             const GFC_INTEGER_8 *pshift, const gfc_array_char *bound,
 266             const GFC_INTEGER_8 *pdim)
 267 {
 268   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 269 }
 270