libgfortran/generated/eoshift3_4.c

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