libgfortran/m4/eoshift1.m4

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