libgfortran/generated/eoshift1_4.c

   1 /* Implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version.
  11
  12 Libgfortran 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 General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <assert.h>
  29 #include <string.h>
  30
  31
  32 #if defined (HAVE_GFC_INTEGER_4)
  33
  34 static void
  35 eoshift1 (gfc_array_char * const restrict ret,
  36         const gfc_array_char * const restrict array,
  37         const gfc_array_i4 * const restrict h,
  38         const char * const restrict pbound,
  39         const GFC_INTEGER_4 * const restrict pwhich,
  40         const char * filler, index_type filler_len)
  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 * restrict 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
  59   index_type count[GFC_MAX_DIMENSIONS];
  60   index_type extent[GFC_MAX_DIMENSIONS];
  61   index_type dim;
  62   index_type len;
  63   index_type n;
  64   index_type size;
  65   index_type arraysize;
  66   int which;
  67   GFC_INTEGER_4 sh;
  68   GFC_INTEGER_4 delta;
  69
  70   /* The compiler cannot figure out that these are set, initialize
  71      them to avoid warnings.  */
  72   len = 0;
  73   soffset = 0;
  74   roffset = 0;
  75
  76   size = GFC_DESCRIPTOR_SIZE(array);
  77
  78   if (pwhich)
  79     which = *pwhich - 1;
  80   else
  81     which = 0;
  82
  83   extent[0] = 1;
  84   count[0] = 0;
  85
  86   arraysize = size0 ((array_t *) array);
  87   if (ret->data == NULL)
  88     {
  89       int i;
  90
  91       ret->data = internal_malloc_size (size * arraysize);
  92       ret->offset = 0;
  93       ret->dtype = array->dtype;
  94       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  95         {
  96           index_type ub, str;
  97
  98           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  99
 100           if (i == 0)
 101             str = 1;
 102           else
 103             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
 104               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
 105
 106           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 107
 108         }
 109       if (arraysize > 0)
 110         ret->data = internal_malloc_size (size * arraysize);
 111       else
 112         ret->data = internal_malloc_size (1);
 113
 114     }
 115   else if (unlikely (compile_options.bounds_check))
 116     {
 117       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 118                                  "return value", "EOSHIFT");
 119     }
 120
 121   if (unlikely (compile_options.bounds_check))
 122     {
 123       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 124                               "SHIFT argument", "EOSHIFT");
 125     }
 126
 127   if (arraysize == 0)
 128     return;
 129
 130   n = 0;
 131   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 132     {
 133       if (dim == which)
 134         {
 135           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 136           if (roffset == 0)
 137             roffset = size;
 138           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 139           if (soffset == 0)
 140             soffset = size;
 141           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 142         }
 143       else
 144         {
 145           count[n] = 0;
 146           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 147           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 148           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 149
 150           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 151           n++;
 152         }
 153     }
 154   if (sstride[0] == 0)
 155     sstride[0] = size;
 156   if (rstride[0] == 0)
 157     rstride[0] = size;
 158   if (hstride[0] == 0)
 159     hstride[0] = 1;
 160
 161   dim = GFC_DESCRIPTOR_RANK (array);
 162   rstride0 = rstride[0];
 163   sstride0 = sstride[0];
 164   hstride0 = hstride[0];
 165   rptr = ret->data;
 166   sptr = array->data;
 167   hptr = h->data;
 168
 169   while (rptr)
 170     {
 171       /* Do the shift for this dimension.  */
 172       sh = *hptr;
 173       if (( sh >= 0 ? sh : -sh ) > len)
 174         {
 175           delta = len;
 176           sh = len;
 177         }
 178       else
 179         delta = (sh >= 0) ? sh: -sh;
 180
 181       if (sh > 0)
 182         {
 183           src = &sptr[delta * soffset];
 184           dest = rptr;
 185         }
 186       else
 187         {
 188           src = sptr;
 189           dest = &rptr[delta * roffset];
 190         }
 191       for (n = 0; n < len - delta; n++)
 192         {
 193           memcpy (dest, src, size);
 194           dest += roffset;
 195           src += soffset;
 196         }
 197       if (sh < 0)
 198         dest = rptr;
 199       n = delta;
 200
 201       if (pbound)
 202         while (n--)
 203           {
 204             memcpy (dest, pbound, size);
 205             dest += roffset;
 206           }
 207       else
 208         while (n--)
 209           {
 210             index_type i;
 211
 212             if (filler_len == 1)
 213               memset (dest, filler[0], size);
 214             else
 215               for (i = 0; i < size; i += filler_len)
 216                 memcpy (&dest[i], filler, filler_len);
 217
 218             dest += roffset;
 219           }
 220
 221       /* Advance to the next section.  */
 222       rptr += rstride0;
 223       sptr += sstride0;
 224       hptr += hstride0;
 225       count[0]++;
 226       n = 0;
 227       while (count[n] == extent[n])
 228         {
 229           /* When we get to the end of a dimension, reset it and increment
 230              the next dimension.  */
 231           count[n] = 0;
 232           /* We could precalculate these products, but this is a less
 233              frequently used path so probably not worth it.  */
 234           rptr -= rstride[n] * extent[n];
 235           sptr -= sstride[n] * extent[n];
 236           hptr -= hstride[n] * extent[n];
 237           n++;
 238           if (n >= dim - 1)
 239             {
 240               /* Break out of the loop.  */
 241               rptr = NULL;
 242               break;
 243             }
 244           else
 245             {
 246               count[n]++;
 247               rptr += rstride[n];
 248               sptr += sstride[n];
 249               hptr += hstride[n];
 250             }
 251         }
 252     }
 253 }
 254
 255 void eoshift1_4 (gfc_array_char * const restrict,
 256         const gfc_array_char * const restrict,
 257         const gfc_array_i4 * const restrict, const char * const restrict,
 258         const GFC_INTEGER_4 * const restrict);
 259 export_proto(eoshift1_4);
 260
 261 void
 262 eoshift1_4 (gfc_array_char * const restrict ret,
 263         const gfc_array_char * const restrict array,
 264         const gfc_array_i4 * const restrict h,
 265         const char * const restrict pbound,
 266         const GFC_INTEGER_4 * const restrict pwhich)
 267 {
 268   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
 269 }
 270
 271
 272 void eoshift1_4_char (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_char);
 280
 281 void
 282 eoshift1_4_char (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 __attribute__((unused)),
 289         GFC_INTEGER_4 bound_length __attribute__((unused)))
 290 {
 291   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
 292 }
 293
 294
 295 void eoshift1_4_char4 (gfc_array_char * const restrict,
 296         GFC_INTEGER_4,
 297         const gfc_array_char * const restrict,
 298         const gfc_array_i4 * const restrict,
 299         const char * const restrict,
 300         const GFC_INTEGER_4 * const restrict,
 301         GFC_INTEGER_4, GFC_INTEGER_4);
 302 export_proto(eoshift1_4_char4);
 303
 304 void
 305 eoshift1_4_char4 (gfc_array_char * const restrict ret,
 306         GFC_INTEGER_4 ret_length __attribute__((unused)),
 307         const gfc_array_char * const restrict array,
 308         const gfc_array_i4 * const restrict h,
 309         const char *  const restrict pbound,
 310         const GFC_INTEGER_4 * const restrict pwhich,
 311         GFC_INTEGER_4 array_length __attribute__((unused)),
 312         GFC_INTEGER_4 bound_length __attribute__((unused)))
 313 {
 314   static const gfc_char4_t space = (unsigned char) ' ';
 315   eoshift1 (ret, array, h, pbound, pwhich,
 316             (const char *) &space, sizeof (gfc_char4_t));
 317 }
 318
 319 #endif