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