libgfortran/m4/eoshift1.m4

   1 `/* Implementation of the EOSHIFT intrinsic
   2    Copyright (C) 2002-2018 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
 188       /* If the elements are contiguous, perform a single block move.  */
 189       if (soffset == size && roffset == size)
 190         {
 191           size_t chunk = size * (len - delta);
 192           memcpy (dest, src, chunk);
 193           dest += chunk;
 194         }
 195       else
 196         {
 197           for (n = 0; n < len - delta; n++)
 198             {
 199               memcpy (dest, src, size);
 200               dest += roffset;
 201               src += soffset;
 202             }
 203         }
 204       if (sh < 0)
 205         dest = rptr;
 206       n = delta;
 207
 208       if (pbound)
 209         while (n--)
 210           {
 211             memcpy (dest, pbound, size);
 212             dest += roffset;
 213           }
 214       else
 215         while (n--)
 216           {
 217             index_type i;
 218
 219             if (filler_len == 1)
 220               memset (dest, filler[0], size);
 221             else
 222               for (i = 0; i < size; i += filler_len)
 223                 memcpy (&dest[i], filler, filler_len);
 224
 225             dest += roffset;
 226           }
 227
 228       /* Advance to the next section.  */
 229       rptr += rstride0;
 230       sptr += sstride0;
 231       hptr += hstride0;
 232       count[0]++;
 233       n = 0;
 234       while (count[n] == extent[n])
 235         {
 236           /* When we get to the end of a dimension, reset it and increment
 237              the next dimension.  */
 238           count[n] = 0;
 239           /* We could precalculate these products, but this is a less
 240              frequently used path so probably not worth it.  */
 241           rptr -= rstride[n] * extent[n];
 242           sptr -= sstride[n] * extent[n];
 243           hptr -= hstride[n] * extent[n];
 244           n++;
 245           if (n >= dim - 1)
 246             {
 247               /* Break out of the loop.  */
 248               rptr = NULL;
 249               break;
 250             }
 251           else
 252             {
 253               count[n]++;
 254               rptr += rstride[n];
 255               sptr += sstride[n];
 256               hptr += hstride[n];
 257             }
 258         }
 259     }
 260 }
 261
 262 void eoshift1_'atype_kind` (gfc_array_char * const restrict,
 263         const gfc_array_char * const restrict,
 264         const 'atype` * const restrict, const char * const restrict,
 265         const 'atype_name` * const restrict);
 266 export_proto(eoshift1_'atype_kind`);
 267
 268 void
 269 eoshift1_'atype_kind` (gfc_array_char * const restrict ret,
 270         const gfc_array_char * const restrict array,
 271         const 'atype` * const restrict h,
 272         const char * const restrict pbound,
 273         const 'atype_name` * const restrict pwhich)
 274 {
 275   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
 276 }
 277
 278
 279 void eoshift1_'atype_kind`_char (gfc_array_char * const restrict,
 280         GFC_INTEGER_4,
 281         const gfc_array_char * const restrict,
 282         const 'atype` * const restrict,
 283         const char * const restrict,
 284         const 'atype_name` * const restrict,
 285         GFC_INTEGER_4, GFC_INTEGER_4);
 286 export_proto(eoshift1_'atype_kind`_char);
 287
 288 void
 289 eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 290         GFC_INTEGER_4 ret_length __attribute__((unused)),
 291         const gfc_array_char * const restrict array,
 292         const 'atype` * const restrict h,
 293         const char *  const restrict pbound,
 294         const 'atype_name` * const restrict pwhich,
 295         GFC_INTEGER_4 array_length __attribute__((unused)),
 296         GFC_INTEGER_4 bound_length __attribute__((unused)))
 297 {
 298   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
 299 }
 300
 301
 302 void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict,
 303         GFC_INTEGER_4,
 304         const gfc_array_char * const restrict,
 305         const 'atype` * const restrict,
 306         const char * const restrict,
 307         const 'atype_name` * const restrict,
 308         GFC_INTEGER_4, GFC_INTEGER_4);
 309 export_proto(eoshift1_'atype_kind`_char4);
 310
 311 void
 312 eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 313         GFC_INTEGER_4 ret_length __attribute__((unused)),
 314         const gfc_array_char * const restrict array,
 315         const 'atype` * const restrict h,
 316         const char *  const restrict pbound,
 317         const 'atype_name` * const restrict pwhich,
 318         GFC_INTEGER_4 array_length __attribute__((unused)),
 319         GFC_INTEGER_4 bound_length __attribute__((unused)))
 320 {
 321   static const gfc_char4_t space = (unsigned char) ''` ''`;
 322   eoshift1 (ret, array, h, pbound, pwhich,
 323             (const char *) &space, sizeof (gfc_char4_t));
 324 }
 325
 326 #endif'