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 * 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 void
 192 __eoshift0_4 (gfc_array_char * ret, const gfc_array_char * array,
 193     const GFC_INTEGER_4 * pshift, const char * pbound,
 194     const GFC_INTEGER_4 * pdim)
 195 {
 196   __eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
 197 }
 198
 199
 200 void
 201 __eoshift0_8 (gfc_array_char * ret, const gfc_array_char * array,
 202     const GFC_INTEGER_8 * pshift, const char * pbound,
 203     const GFC_INTEGER_8 * pdim)
 204 {
 205   __eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
 206 }
 207