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 (libgfor).
   6
   7 Libgfor is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU Lesser General Public
   9 License as published by the Free Software Foundation; either
  10 version 2.1 of the License, or (at your option) any later version.
  11
  12 Ligbfor is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU Lesser General Public License for more details.
  16
  17 You should have received a copy of the GNU Lesser General Public
  18 License along with libgfor; see the file COPYING.LIB.  If not,
  19 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 #include "config.h"
  23 #include <stdlib.h>
  24 #include <assert.h>
  25 #include <string.h>
  26 #include "libgfortran.h"
  27
  28 static const char zeros[16] =
  29   {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
  30
  31 /* TODO: make this work for large shifts when
  32    sizeof(int) < sizeof (index_type).  */
  33
  34 static void
  35 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
  36           int shift, const char * pbound, int which)
  37 {
  38   /* r.* indicates the return array.  */
  39   index_type rstride[GFC_MAX_DIMENSIONS - 1];
  40   index_type rstride0;
  41   index_type roffset;
  42   char *rptr;
  43   char *dest;
  44   /* s.* indicates the source array.  */
  45   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  46   index_type sstride0;
  47   index_type soffset;
  48   const char *sptr;
  49   const char *src;
  50
  51   index_type count[GFC_MAX_DIMENSIONS - 1];
  52   index_type extent[GFC_MAX_DIMENSIONS - 1];
  53   index_type dim;
  54   index_type size;
  55   index_type len;
  56   index_type n;
  57
  58   if (!pbound)
  59     pbound = zeros;
  60
  61   size = GFC_DESCRIPTOR_SIZE (ret);
  62
  63   if (ret->data == NULL)
  64     {
  65       int i;
  66
  67       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  68       ret->base = 0;
  69       ret->dtype = array->dtype;
  70       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  71         {
  72           ret->dim[i].lbound = 0;
  73           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  74
  75           if (i == 0)
  76             ret->dim[i].stride = 1;
  77           else
  78             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  79         }
  80     }
  81
  82   which = which - 1;
  83
  84   extent[0] = 1;
  85   count[0] = 0;
  86   size = GFC_DESCRIPTOR_SIZE (array);
  87   n = 0;
  88   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
  89     {
  90       if (dim == which)
  91         {
  92           roffset = ret->dim[dim].stride * size;
  93           if (roffset == 0)
  94             roffset = size;
  95           soffset = array->dim[dim].stride * size;
  96           if (soffset == 0)
  97             soffset = size;
  98           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  99         }
 100       else
 101         {
 102           count[n] = 0;
 103           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 104           rstride[n] = ret->dim[dim].stride * size;
 105           sstride[n] = array->dim[dim].stride * size;
 106           n++;
 107         }
 108     }
 109   if (sstride[0] == 0)
 110     sstride[0] = size;
 111   if (rstride[0] == 0)
 112     rstride[0] = size;
 113
 114   dim = GFC_DESCRIPTOR_RANK (array);
 115   rstride0 = rstride[0];
 116   sstride0 = sstride[0];
 117   rptr = ret->data;
 118   sptr = array->data;
 119   if (shift > 0)
 120     len = len - shift;
 121   else
 122     len = len + shift;
 123
 124   while (rptr)
 125     {
 126       /* Do the shift for this dimension.  */
 127       if (shift > 0)
 128         {
 129           src = &sptr[shift * soffset];
 130           dest = rptr;
 131         }
 132       else
 133         {
 134           src = sptr;
 135           dest = &rptr[-shift * roffset];
 136         }
 137       for (n = 0; n < len; n++)
 138         {
 139           memcpy (dest, src, size);
 140           dest += roffset;
 141           src += soffset;
 142         }
 143       if (shift >= 0)
 144         {
 145           n = shift;
 146         }
 147       else
 148         {
 149           dest = rptr;
 150           n = -shift;
 151         }
 152
 153       while (n--)
 154         {
 155           memcpy (dest, pbound, size);
 156           dest += roffset;
 157         }
 158
 159       /* Advance to the next section.  */
 160       rptr += rstride0;
 161       sptr += sstride0;
 162       count[0]++;
 163       n = 0;
 164       while (count[n] == extent[n])
 165         {
 166           /* When we get to the end of a dimension, reset it and increment
 167              the next dimension.  */
 168           count[n] = 0;
 169           /* We could precalculate these products, but this is a less
 170              frequently used path so proabably not worth it.  */
 171           rptr -= rstride[n] * extent[n];
 172           sptr -= sstride[n] * extent[n];
 173           n++;
 174           if (n >= dim - 1)
 175             {
 176               /* Break out of the loop.  */
 177               rptr = NULL;
 178               break;
 179             }
 180           else
 181             {
 182               count[n]++;
 183               rptr += rstride[n];
 184               sptr += sstride[n];
 185             }
 186         }
 187     }
 188 }
 189
 190
 191 extern void eoshift0_1 (gfc_array_char *, const gfc_array_char *,
 192                         const GFC_INTEGER_1 *, const char *,
 193                         const GFC_INTEGER_1 *);
 194 export_proto(eoshift0_1);
 195
 196 void
 197 eoshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
 198             const GFC_INTEGER_1 *pshift, const char *pbound,
 199             const GFC_INTEGER_1 *pdim)
 200 {
 201   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
 202 }
 203
 204
 205 extern void eoshift0_2 (gfc_array_char *, const gfc_array_char *,
 206                         const GFC_INTEGER_2 *, const char *,
 207                         const GFC_INTEGER_2 *);
 208 export_proto(eoshift0_2);
 209
 210 void
 211 eoshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
 212             const GFC_INTEGER_2 *pshift, const char *pbound,
 213             const GFC_INTEGER_2 *pdim)
 214 {
 215   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
 216 }
 217
 218
 219 extern void eoshift0_4 (gfc_array_char *, const gfc_array_char *,
 220                         const GFC_INTEGER_4 *, const char *,
 221                         const GFC_INTEGER_4 *);
 222 export_proto(eoshift0_4);
 223
 224 void
 225 eoshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
 226             const GFC_INTEGER_4 *pshift, const char *pbound,
 227             const GFC_INTEGER_4 *pdim)
 228 {
 229   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
 230 }
 231
 232
 233 extern void eoshift0_8 (gfc_array_char *, const gfc_array_char *,
 234                         const GFC_INTEGER_8 *, const char *,
 235                         const GFC_INTEGER_8 *);
 236 export_proto(eoshift0_8);
 237
 238 void
 239 eoshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
 240             const GFC_INTEGER_8 *pshift, const char *pbound,
 241             const GFC_INTEGER_8 *pdim)
 242 {
 243   eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
 244 }
 245