libgfortran/m4/eoshift3.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 eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const atype *h,
  42           const gfc_array_char *bound, const atype_name *pwhich,
  43           index_type size, 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   /* b.* indicates the bound array.  */
  62   index_type bstride[GFC_MAX_DIMENSIONS];
  63   index_type bstride0;
  64   const char *bptr;
  65
  66   index_type count[GFC_MAX_DIMENSIONS];
  67   index_type extent[GFC_MAX_DIMENSIONS];
  68   index_type dim;
  69   index_type len;
  70   index_type n;
  71   int which;
  72   atype_name sh;
  73   atype_name delta;
  74
  75   /* The compiler cannot figure out that these are set, initialize
  76      them to avoid warnings.  */
  77   len = 0;
  78   soffset = 0;
  79   roffset = 0;
  80
  81   if (pwhich)
  82     which = *pwhich - 1;
  83   else
  84     which = 0;
  85
  86   if (ret->data == NULL)
  87     {
  88       int i;
  89
  90       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  91       ret->offset = 0;
  92       ret->dtype = array->dtype;
  93       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  94         {
  95           ret->dim[i].lbound = 0;
  96           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  97
  98           if (i == 0)
  99             ret->dim[i].stride = 1;
 100           else
 101             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
 102         }
 103     }
 104
 105
 106   extent[0] = 1;
 107   count[0] = 0;
 108   n = 0;
 109   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 110     {
 111       if (dim == which)
 112         {
 113           roffset = ret->dim[dim].stride * size;
 114           if (roffset == 0)
 115             roffset = size;
 116           soffset = array->dim[dim].stride * size;
 117           if (soffset == 0)
 118             soffset = size;
 119           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 120         }
 121       else
 122         {
 123           count[n] = 0;
 124           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 125           rstride[n] = ret->dim[dim].stride * size;
 126           sstride[n] = array->dim[dim].stride * size;
 127
 128           hstride[n] = h->dim[n].stride;
 129           if (bound)
 130             bstride[n] = bound->dim[n].stride * size;
 131           else
 132             bstride[n] = 0;
 133           n++;
 134         }
 135     }
 136   if (sstride[0] == 0)
 137     sstride[0] = size;
 138   if (rstride[0] == 0)
 139     rstride[0] = size;
 140   if (hstride[0] == 0)
 141     hstride[0] = 1;
 142   if (bound && bstride[0] == 0)
 143     bstride[0] = size;
 144
 145   dim = GFC_DESCRIPTOR_RANK (array);
 146   rstride0 = rstride[0];
 147   sstride0 = sstride[0];
 148   hstride0 = hstride[0];
 149   bstride0 = bstride[0];
 150   rptr = ret->data;
 151   sptr = array->data;
 152   hptr = h->data;
 153   if (bound)
 154     bptr = bound->data;
 155   else
 156     bptr = NULL;
 157
 158   while (rptr)
 159     {
 160 `      /* Do the shift for this dimension.  */'
 161       sh = *hptr;
 162       if (( sh >= 0 ? sh : -sh ) > len)
 163         {
 164           delta = len;
 165           sh = len;
 166         }
 167       else
 168         delta = (sh >= 0) ? sh: -sh;
 169
 170       if (sh > 0)
 171         {
 172           src = &sptr[delta * soffset];
 173           dest = rptr;
 174         }
 175       else
 176         {
 177           src = sptr;
 178           dest = &rptr[delta * roffset];
 179         }
 180       for (n = 0; n < len - delta; n++)
 181         {
 182           memcpy (dest, src, size);
 183           dest += roffset;
 184           src += soffset;
 185         }
 186       if (sh < 0)
 187         dest = rptr;
 188       n = delta;
 189
 190       if (bptr)
 191         while (n--)
 192           {
 193             memcpy (dest, bptr, size);
 194             dest += roffset;
 195           }
 196       else
 197         while (n--)
 198           {
 199             memset (dest, filler, size);
 200             dest += roffset;
 201           }
 202
 203       /* Advance to the next section.  */
 204       rptr += rstride0;
 205       sptr += sstride0;
 206       hptr += hstride0;
 207       bptr += bstride0;
 208       count[0]++;
 209       n = 0;
 210       while (count[n] == extent[n])
 211         {
 212           /* When we get to the end of a dimension, reset it and increment
 213              the next dimension.  */
 214           count[n] = 0;
 215           /* We could precalculate these products, but this is a less
 216              frequently used path so proabably not worth it.  */
 217           rptr -= rstride[n] * extent[n];
 218           sptr -= sstride[n] * extent[n];
 219           hptr -= hstride[n] * extent[n];
 220           bptr -= bstride[n] * extent[n];
 221           n++;
 222           if (n >= dim - 1)
 223             {
 224               /* Break out of the loop.  */
 225               rptr = NULL;
 226               break;
 227             }
 228           else
 229             {
 230               count[n]++;
 231               rptr += rstride[n];
 232               sptr += sstride[n];
 233               hptr += hstride[n];
 234               bptr += bstride[n];
 235             }
 236         }
 237     }
 238 }
 239
 240 extern void eoshift3_`'atype_kind (gfc_array_char *, const gfc_array_char *,
 241                                    const atype *, const gfc_array_char *,
 242                                    const atype_name *);
 243 export_proto(eoshift3_`'atype_kind);
 244
 245 void
 246 eoshift3_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array,
 247                        const atype *h, const gfc_array_char *bound,
 248                        const atype_name *pwhich)
 249 {
 250   eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
 251 }
 252
 253 extern void eoshift3_`'atype_kind`'_char (gfc_array_char *, GFC_INTEGER_4,
 254                                           const gfc_array_char *,
 255                                           const atype *,
 256                                           const gfc_array_char *,
 257                                           const atype_name *, GFC_INTEGER_4,
 258                                           GFC_INTEGER_4);
 259 export_proto(eoshift3_`'atype_kind`'_char);
 260
 261 void
 262 eoshift3_`'atype_kind`'_char (gfc_array_char *ret,
 263                               GFC_INTEGER_4 ret_length __attribute__((unused)),
 264                               const gfc_array_char *array, const atype *h,
 265                               const gfc_array_char *bound,
 266                               const atype_name *pwhich,
 267                               GFC_INTEGER_4 array_length,
 268                               GFC_INTEGER_4 bound_length
 269                                 __attribute__((unused)))
 270 {
 271   eoshift3 (ret, array, h, bound, pwhich, array_length, ' ');
 272 }
 273
 274 #endif