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., 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 *, const gfc_array_char *,
  45           int, const gfc_array_char *, int );
  46
  47 static void
  48 eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
  49           int shift, const gfc_array_char *bound, int which)
  50 {
  51   /* r.* indicates the return array.  */
  52   index_type rstride[GFC_MAX_DIMENSIONS];
  53   index_type rstride0;
  54   index_type roffset;
  55   char *rptr;
  56   char *dest;
  57   /* s.* indicates the source array.  */
  58   index_type sstride[GFC_MAX_DIMENSIONS];
  59   index_type sstride0;
  60   index_type soffset;
  61   const char *sptr;
  62   const char *src;
  63   /* b.* indicates the bound array.  */
  64   index_type bstride[GFC_MAX_DIMENSIONS];
  65   index_type bstride0;
  66   const char *bptr;
  67
  68   index_type count[GFC_MAX_DIMENSIONS];
  69   index_type extent[GFC_MAX_DIMENSIONS];
  70   index_type dim;
  71   index_type size;
  72   index_type len;
  73   index_type n;
  74
  75   /* The compiler cannot figure out that these are set, initialize
  76      them to avoid warnings.  */
  77   len = 0;
  78   soffset = 0;
  79   roffset = 0;
  80
  81   size = GFC_DESCRIPTOR_SIZE (ret);
  82
  83   if (ret->data == NULL)
  84     {
  85       int i;
  86
  87       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  88       ret->base = 0;
  89       ret->dtype = array->dtype;
  90       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  91         {
  92           ret->dim[i].lbound = 0;
  93           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  94
  95           if (i == 0)
  96             ret->dim[i].stride = 1;
  97           else
  98             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  99         }
 100     }
 101
 102   which = which - 1;
 103
 104   extent[0] = 1;
 105   count[0] = 0;
 106   size = GFC_DESCRIPTOR_SIZE (array);
 107   n = 0;
 108   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 109     {
 110       if (dim == which)
 111         {
 112           roffset = ret->dim[dim].stride * size;
 113           if (roffset == 0)
 114             roffset = size;
 115           soffset = array->dim[dim].stride * size;
 116           if (soffset == 0)
 117             soffset = size;
 118           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 119         }
 120       else
 121         {
 122           count[n] = 0;
 123           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 124           rstride[n] = ret->dim[dim].stride * size;
 125           sstride[n] = array->dim[dim].stride * size;
 126           if (bound)
 127             bstride[n] = bound->dim[n].stride * size;
 128           else
 129             bstride[n] = 0;
 130           n++;
 131         }
 132     }
 133   if (sstride[0] == 0)
 134     sstride[0] = size;
 135   if (rstride[0] == 0)
 136     rstride[0] = size;
 137   if (bound && bstride[0] == 0)
 138     bstride[0] = size;
 139
 140   dim = GFC_DESCRIPTOR_RANK (array);
 141   rstride0 = rstride[0];
 142   sstride0 = sstride[0];
 143   bstride0 = bstride[0];
 144   rptr = ret->data;
 145   sptr = array->data;
 146   if (bound)
 147     bptr = bound->data;
 148   else
 149     bptr = zeros;
 150
 151   if (shift > 0)
 152     len = len - shift;
 153   else
 154     len = len + shift;
 155
 156   while (rptr)
 157     {
 158       /* Do the shift for this dimension.  */
 159       if (shift > 0)
 160         {
 161           src = &sptr[shift * soffset];
 162           dest = rptr;
 163         }
 164       else
 165         {
 166           src = sptr;
 167           dest = &rptr[-shift * roffset];
 168         }
 169       for (n = 0; n < len; n++)
 170         {
 171           memcpy (dest, src, size);
 172           dest += roffset;
 173           src += soffset;
 174         }
 175       if (shift >= 0)
 176         {
 177           n = shift;
 178         }
 179       else
 180         {
 181           dest = rptr;
 182           n = -shift;
 183         }
 184
 185       while (n--)
 186         {
 187           memcpy (dest, bptr, size);
 188           dest += roffset;
 189         }
 190
 191       /* Advance to the next section.  */
 192       rptr += rstride0;
 193       sptr += sstride0;
 194       bptr += bstride0;
 195       count[0]++;
 196       n = 0;
 197       while (count[n] == extent[n])
 198         {
 199           /* When we get to the end of a dimension, reset it and increment
 200              the next dimension.  */
 201           count[n] = 0;
 202           /* We could precalculate these products, but this is a less
 203              frequently used path so proabably not worth it.  */
 204           rptr -= rstride[n] * extent[n];
 205           sptr -= sstride[n] * extent[n];
 206           bptr -= bstride[n] * extent[n];
 207           n++;
 208           if (n >= dim - 1)
 209             {
 210               /* Break out of the loop.  */
 211               rptr = NULL;
 212               break;
 213             }
 214           else
 215             {
 216               count[n]++;
 217               rptr += rstride[n];
 218               sptr += sstride[n];
 219               bptr += bstride[n];
 220             }
 221         }
 222     }
 223 }
 224
 225
 226 extern void eoshift2_1 (gfc_array_char *, const gfc_array_char *,
 227                         const GFC_INTEGER_1 *, const gfc_array_char *,
 228                         const GFC_INTEGER_1 *);
 229 export_proto(eoshift2_1);
 230
 231 void
 232 eoshift2_1 (gfc_array_char *ret, const gfc_array_char *array,
 233             const GFC_INTEGER_1 *pshift, const gfc_array_char *bound,
 234             const GFC_INTEGER_1 *pdim)
 235 {
 236   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 237 }
 238
 239
 240 extern void eoshift2_2 (gfc_array_char *, const gfc_array_char *,
 241                         const GFC_INTEGER_2 *, const gfc_array_char *,
 242                         const GFC_INTEGER_2 *);
 243 export_proto(eoshift2_2);
 244
 245 void
 246 eoshift2_2 (gfc_array_char *ret, const gfc_array_char *array,
 247             const GFC_INTEGER_2 *pshift, const gfc_array_char *bound,
 248             const GFC_INTEGER_2 *pdim)
 249 {
 250   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 251 }
 252
 253
 254 extern void eoshift2_4 (gfc_array_char *, const gfc_array_char *,
 255                         const GFC_INTEGER_4 *, const gfc_array_char *,
 256                         const GFC_INTEGER_4 *);
 257 export_proto(eoshift2_4);
 258
 259 void
 260 eoshift2_4 (gfc_array_char *ret, const gfc_array_char *array,
 261             const GFC_INTEGER_4 *pshift, const gfc_array_char *bound,
 262             const GFC_INTEGER_4 *pdim)
 263 {
 264   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 265 }
 266
 267
 268 extern void eoshift2_8 (gfc_array_char *, const gfc_array_char *,
 269                         const GFC_INTEGER_8 *, const gfc_array_char *,
 270                         const GFC_INTEGER_8 *);
 271 export_proto(eoshift2_8);
 272
 273 void
 274 eoshift2_8 (gfc_array_char *ret, const gfc_array_char *array,
 275             const GFC_INTEGER_8 *pshift, const gfc_array_char *bound,
 276             const GFC_INTEGER_8 *pdim)
 277 {
 278   eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
 279 }