libgfortran/generated/eoshift1_4.c

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