libgfortran/m4/eoshift3.m4

   1 `/* 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 include(iparm.m4)dnl
  28
  29 static const char zeros[16] =
  30   {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
  31
  32 void
  33 `__eoshift3_'atype_kind (gfc_array_char * ret, gfc_array_char * array,
  34     atype * h, const gfc_array_char * bound, atype_name * pwhich)
  35 {
  36   /* r.* indicates the return array.  */
  37   index_type rstride[GFC_MAX_DIMENSIONS - 1];
  38   index_type rstride0;
  39   index_type roffset;
  40   char *rptr;
  41   char *dest;
  42   /* s.* indicates the source array.  */
  43   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  44   index_type sstride0;
  45   index_type soffset;
  46   const char *sptr;
  47   const char *src;
  48 `  /* h.* indicates the shift array.  */'
  49   index_type hstride[GFC_MAX_DIMENSIONS - 1];
  50   index_type hstride0;
  51   const atype_name *hptr;
  52   /* b.* indicates the bound array.  */
  53   index_type bstride[GFC_MAX_DIMENSIONS - 1];
  54   index_type bstride0;
  55   const char *bptr;
  56
  57   index_type count[GFC_MAX_DIMENSIONS - 1];
  58   index_type extent[GFC_MAX_DIMENSIONS - 1];
  59   index_type dim;
  60   index_type size;
  61   index_type len;
  62   index_type n;
  63   int which;
  64   atype_name sh;
  65   atype_name delta;
  66
  67   if (pwhich)
  68     which = *pwhich - 1;
  69   else
  70     which = 0;
  71
  72   size = GFC_DESCRIPTOR_SIZE (ret);
  73
  74   extent[0] = 1;
  75   count[0] = 0;
  76   size = GFC_DESCRIPTOR_SIZE (array);
  77   n = 0;
  78   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
  79     {
  80       if (dim == which)
  81         {
  82           roffset = ret->dim[dim].stride * size;
  83           if (roffset == 0)
  84             roffset = size;
  85           soffset = array->dim[dim].stride * size;
  86           if (soffset == 0)
  87             soffset = size;
  88           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  89         }
  90       else
  91         {
  92           count[n] = 0;
  93           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  94           rstride[n] = ret->dim[dim].stride * size;
  95           sstride[n] = array->dim[dim].stride * size;
  96
  97           hstride[n] = h->dim[n].stride;
  98           if (bound)
  99             bstride[n] = bound->dim[n].stride;
 100           else
 101             bstride[n] = 0;
 102           n++;
 103         }
 104     }
 105   if (sstride[0] == 0)
 106     sstride[0] = size;
 107   if (rstride[0] == 0)
 108     rstride[0] = size;
 109   if (hstride[0] == 0)
 110     hstride[0] = 1;
 111   if (bound && bstride[0] == 0)
 112     bstride[0] = size;
 113
 114   dim = GFC_DESCRIPTOR_RANK (array);
 115   rstride0 = rstride[0];
 116   sstride0 = sstride[0];
 117   hstride0 = hstride[0];
 118   bstride0 = bstride[0];
 119   rptr = ret->data;
 120   sptr = array->data;
 121   hptr = h->data;
 122   if (bound)
 123     bptr = bound->data;
 124   else
 125     bptr = zeros;
 126
 127   while (rptr)
 128     {
 129 `      /* Do the shift for this dimension.  */'
 130       sh = *hptr;
 131       delta = (sh >= 0) ? sh: -sh;
 132       if (sh > 0)
 133         {
 134           src = &sptr[delta * soffset];
 135           dest = rptr;
 136         }
 137       else
 138         {
 139           src = sptr;
 140           dest = &rptr[delta * roffset];
 141         }
 142       for (n = 0; n < len - delta; n++)
 143         {
 144           memcpy (dest, src, size);
 145           dest += roffset;
 146           src += soffset;
 147         }
 148       if (sh < 0)
 149         dest = rptr;
 150       n = delta;
 151
 152       while (n--)
 153         {
 154           memcpy (dest, bptr, size);
 155           dest += roffset;
 156         }
 157
 158       /* Advance to the next section.  */
 159       rptr += rstride0;
 160       sptr += sstride0;
 161       hptr += hstride0;
 162       bptr += bstride0;
 163       count[0]++;
 164       n = 0;
 165       while (count[n] == extent[n])
 166         {
 167           /* When we get to the end of a dimension, reset it and increment
 168              the next dimension.  */
 169           count[n] = 0;
 170           /* We could precalculate these products, but this is a less
 171              frequently used path so proabably not worth it.  */
 172           rptr -= rstride[n] * extent[n];
 173           sptr -= sstride[n] * extent[n];
 174           hptr -= hstride[n] * extent[n];
 175           bptr -= bstride[n] * extent[n];
 176           n++;
 177           if (n >= dim - 1)
 178             {
 179               /* Break out of the loop.  */
 180               rptr = NULL;
 181               break;
 182             }
 183           else
 184             {
 185               count[n]++;
 186               rptr += rstride[n];
 187               sptr += sstride[n];
 188               hptr += hstride[n];
 189               bptr += bstride[n];
 190             }
 191         }
 192     }
 193 }
 194