libgfortran/m4/eoshift1.m4

   1 `/* 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 Libgfortran 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., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35 #include "libgfortran.h"'
  36 include(iparm.m4)dnl
  37
  38 `#if defined (HAVE_'atype_name`)'
  39
  40 static void
  41 eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const atype *h,
  42           const char *pbound, const atype_name *pwhich, index_type size,
  43           char filler)
  44 {
  45   /* r.* indicates the return array.  */
  46   index_type rstride[GFC_MAX_DIMENSIONS];
  47   index_type rstride0;
  48   index_type roffset;
  49   char *rptr;
  50   char *dest;
  51   /* s.* indicates the source array.  */
  52   index_type sstride[GFC_MAX_DIMENSIONS];
  53   index_type sstride0;
  54   index_type soffset;
  55   const char *sptr;
  56   const char *src;
  57 `  /* h.* indicates the shift array.  */'
  58   index_type hstride[GFC_MAX_DIMENSIONS];
  59   index_type hstride0;
  60   const atype_name *hptr;
  61
  62   index_type count[GFC_MAX_DIMENSIONS];
  63   index_type extent[GFC_MAX_DIMENSIONS];
  64   index_type dim;
  65   index_type len;
  66   index_type n;
  67   int which;
  68   atype_name sh;
  69   atype_name delta;
  70
  71   /* The compiler cannot figure out that these are set, initialize
  72      them to avoid warnings.  */
  73   len = 0;
  74   soffset = 0;
  75   roffset = 0;
  76
  77   if (pwhich)
  78     which = *pwhich - 1;
  79   else
  80     which = 0;
  81
  82   extent[0] = 1;
  83   count[0] = 0;
  84
  85   if (ret->data == NULL)
  86     {
  87       int i;
  88
  89       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  90       ret->offset = 0;
  91       ret->dtype = array->dtype;
  92       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  93         {
  94           ret->dim[i].lbound = 0;
  95           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  96
  97           if (i == 0)
  98             ret->dim[i].stride = 1;
  99           else
 100             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
 101         }
 102     }
 103
 104   n = 0;
 105   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 106     {
 107       if (dim == which)
 108         {
 109           roffset = ret->dim[dim].stride * size;
 110           if (roffset == 0)
 111             roffset = size;
 112           soffset = array->dim[dim].stride * size;
 113           if (soffset == 0)
 114             soffset = size;
 115           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 116         }
 117       else
 118         {
 119           count[n] = 0;
 120           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 121           rstride[n] = ret->dim[dim].stride * size;
 122           sstride[n] = array->dim[dim].stride * size;
 123
 124           hstride[n] = h->dim[n].stride;
 125           n++;
 126         }
 127     }
 128   if (sstride[0] == 0)
 129     sstride[0] = size;
 130   if (rstride[0] == 0)
 131     rstride[0] = size;
 132   if (hstride[0] == 0)
 133     hstride[0] = 1;
 134
 135   dim = GFC_DESCRIPTOR_RANK (array);
 136   rstride0 = rstride[0];
 137   sstride0 = sstride[0];
 138   hstride0 = hstride[0];
 139   rptr = ret->data;
 140   sptr = array->data;
 141   hptr = h->data;
 142
 143   while (rptr)
 144     {
 145 `      /* Do the shift for this dimension.  */'
 146       sh = *hptr;
 147       if (( sh >= 0 ? sh : -sh ) > len)
 148         {
 149           delta = len;
 150           sh = len;
 151         }
 152       else
 153         delta = (sh >= 0) ? sh: -sh;
 154
 155       if (sh > 0)
 156         {
 157           src = &sptr[delta * soffset];
 158           dest = rptr;
 159         }
 160       else
 161         {
 162           src = sptr;
 163           dest = &rptr[delta * roffset];
 164         }
 165       for (n = 0; n < len - delta; n++)
 166         {
 167           memcpy (dest, src, size);
 168           dest += roffset;
 169           src += soffset;
 170         }
 171       if (sh < 0)
 172         dest = rptr;
 173       n = delta;
 174
 175       if (pbound)
 176         while (n--)
 177           {
 178             memcpy (dest, pbound, size);
 179             dest += roffset;
 180           }
 181       else
 182         while (n--)
 183           {
 184             memset (dest, filler, size);
 185             dest += roffset;
 186           }
 187
 188       /* Advance to the next section.  */
 189       rptr += rstride0;
 190       sptr += sstride0;
 191       hptr += hstride0;
 192       count[0]++;
 193       n = 0;
 194       while (count[n] == extent[n])
 195         {
 196           /* When we get to the end of a dimension, reset it and increment
 197              the next dimension.  */
 198           count[n] = 0;
 199           /* We could precalculate these products, but this is a less
 200              frequently used path so proabably not worth it.  */
 201           rptr -= rstride[n] * extent[n];
 202           sptr -= sstride[n] * extent[n];
 203           hptr -= hstride[n] * extent[n];
 204           n++;
 205           if (n >= dim - 1)
 206             {
 207               /* Break out of the loop.  */
 208               rptr = NULL;
 209               break;
 210             }
 211           else
 212             {
 213               count[n]++;
 214               rptr += rstride[n];
 215               sptr += sstride[n];
 216               hptr += hstride[n];
 217             }
 218         }
 219     }
 220 }
 221
 222 void eoshift1_`'atype_kind (gfc_array_char *, const gfc_array_char *,
 223                             const atype *, const char *, const atype_name *);
 224 export_proto(eoshift1_`'atype_kind);
 225
 226 void
 227 eoshift1_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array,
 228                        const atype *h, const char *pbound,
 229                        const atype_name *pwhich)
 230 {
 231   eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
 232 }
 233
 234 void eoshift1_`'atype_kind`'_char (gfc_array_char *, GFC_INTEGER_4,
 235                                    const gfc_array_char *, const atype *,
 236                                    const char *, const atype_name *,
 237                                    GFC_INTEGER_4, GFC_INTEGER_4);
 238 export_proto(eoshift1_`'atype_kind`'_char);
 239
 240 void
 241 eoshift1_`'atype_kind`'_char (gfc_array_char *ret,
 242                               GFC_INTEGER_4 ret_length __attribute__((unused)),
 243                               const gfc_array_char *array, const atype *h,
 244                               const char *pbound, const atype_name *pwhich,
 245                               GFC_INTEGER_4 array_length,
 246                               GFC_INTEGER_4 bound_length
 247                                 __attribute__((unused)))
 248 {
 249   eoshift1 (ret, array, h, pbound, pwhich, array_length, ' ');
 250 }
 251
 252 #endif