libgfortran/m4/eoshift3.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 eoshift3 (gfc_array_char * const restrict ret,
  35         const gfc_array_char * const restrict array,
  36         const 'atype` * const restrict h,
  37         const gfc_array_char * const restrict bound,
  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   /* b.* indicates the bound array.  */
  58   index_type bstride[GFC_MAX_DIMENSIONS];
  59   index_type bstride0;
  60   const char *bptr;
  61
  62   index_type count[GFC_MAX_DIMENSIONS];
  63   index_type extent[GFC_MAX_DIMENSIONS];
  64   index_type dim;
  65   index_type len;
  66   index_type n;
  67   index_type size;
  68   index_type arraysize;
  69   int which;
  70   'atype_name` sh;
  71   'atype_name` 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   arraysize = size0 ((array_t *) array);
  80   size = GFC_DESCRIPTOR_SIZE(array);
  81
  82   if (pwhich)
  83     which = *pwhich - 1;
  84   else
  85     which = 0;
  86
  87   if (ret->base_addr == NULL)
  88     {
  89       int i;
  90
  91       ret->base_addr = xmallocarray (arraysize, size);
  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       /* xmallocarray allocates a single byte for zero size.  */
 110       ret->base_addr = xmallocarray (arraysize, size);
 111
 112     }
 113   else if (unlikely (compile_options.bounds_check))
 114     {
 115       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 116                                  "return value", "EOSHIFT");
 117     }
 118
 119   if (unlikely (compile_options.bounds_check))
 120     {
 121       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 122                               "SHIFT argument", "EOSHIFT");
 123     }
 124
 125   if (arraysize == 0)
 126     return;
 127
 128   extent[0] = 1;
 129   count[0] = 0;
 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           if (bound)
 152             bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
 153           else
 154             bstride[n] = 0;
 155           n++;
 156         }
 157     }
 158   if (sstride[0] == 0)
 159     sstride[0] = size;
 160   if (rstride[0] == 0)
 161     rstride[0] = size;
 162   if (hstride[0] == 0)
 163     hstride[0] = 1;
 164   if (bound && bstride[0] == 0)
 165     bstride[0] = size;
 166
 167   dim = GFC_DESCRIPTOR_RANK (array);
 168   rstride0 = rstride[0];
 169   sstride0 = sstride[0];
 170   hstride0 = hstride[0];
 171   bstride0 = bstride[0];
 172   rptr = ret->base_addr;
 173   sptr = array->base_addr;
 174   hptr = h->base_addr;
 175   if (bound)
 176     bptr = bound->base_addr;
 177   else
 178     bptr = NULL;
 179
 180   while (rptr)
 181     {
 182       /* Do the shift for this dimension.  */
 183       sh = *hptr;
 184       if (( sh >= 0 ? sh : -sh ) > len)
 185         {
 186           delta = len;
 187           sh = len;
 188         }
 189       else
 190         delta = (sh >= 0) ? sh: -sh;
 191
 192       if (sh > 0)
 193         {
 194           src = &sptr[delta * soffset];
 195           dest = rptr;
 196         }
 197       else
 198         {
 199           src = sptr;
 200           dest = &rptr[delta * roffset];
 201         }
 202
 203       /* If the elements are contiguous, perform a single block move.  */
 204       if (soffset == size && roffset == size)
 205         {
 206           size_t chunk = size * (len - delta);
 207           memcpy (dest, src, chunk);
 208           dest += chunk;
 209         }
 210       else
 211         {
 212           for (n = 0; n < len - delta; n++)
 213             {
 214               memcpy (dest, src, size);
 215               dest += roffset;
 216               src += soffset;
 217             }
 218         }
 219
 220       if (sh < 0)
 221         dest = rptr;
 222       n = delta;
 223
 224       if (bptr)
 225         while (n--)
 226           {
 227             memcpy (dest, bptr, size);
 228             dest += roffset;
 229           }
 230       else
 231         while (n--)
 232           {
 233             index_type i;
 234
 235             if (filler_len == 1)
 236               memset (dest, filler[0], size);
 237             else
 238               for (i = 0; i < size; i += filler_len)
 239                 memcpy (&dest[i], filler, filler_len);
 240
 241             dest += roffset;
 242           }
 243
 244       /* Advance to the next section.  */
 245       rptr += rstride0;
 246       sptr += sstride0;
 247       hptr += hstride0;
 248       bptr += bstride0;
 249       count[0]++;
 250       n = 0;
 251       while (count[n] == extent[n])
 252         {
 253           /* When we get to the end of a dimension, reset it and increment
 254              the next dimension.  */
 255           count[n] = 0;
 256           /* We could precalculate these products, but this is a less
 257              frequently used path so probably not worth it.  */
 258           rptr -= rstride[n] * extent[n];
 259           sptr -= sstride[n] * extent[n];
 260           hptr -= hstride[n] * extent[n];
 261           bptr -= bstride[n] * extent[n];
 262           n++;
 263           if (n >= dim - 1)
 264             {
 265               /* Break out of the loop.  */
 266               rptr = NULL;
 267               break;
 268             }
 269           else
 270             {
 271               count[n]++;
 272               rptr += rstride[n];
 273               sptr += sstride[n];
 274               hptr += hstride[n];
 275               bptr += bstride[n];
 276             }
 277         }
 278     }
 279 }
 280
 281 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
 282         const gfc_array_char * const restrict,
 283         const 'atype` * const restrict,
 284         const gfc_array_char * const restrict,
 285         const 'atype_name` *);
 286 export_proto(eoshift3_'atype_kind`);
 287
 288 void
 289 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
 290         const gfc_array_char * const restrict array,
 291         const 'atype` * const restrict h,
 292         const gfc_array_char * const restrict bound,
 293         const 'atype_name` * const restrict pwhich)
 294 {
 295   eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
 296 }
 297
 298
 299 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
 300         GFC_INTEGER_4,
 301         const gfc_array_char * const restrict,
 302         const 'atype` * const restrict,
 303         const gfc_array_char * const restrict,
 304         const 'atype_name` * const restrict,
 305         GFC_INTEGER_4, GFC_INTEGER_4);
 306 export_proto(eoshift3_'atype_kind`_char);
 307
 308 void
 309 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
 310         GFC_INTEGER_4 ret_length __attribute__((unused)),
 311         const gfc_array_char * const restrict array,
 312         const 'atype` *  const restrict h,
 313         const gfc_array_char * const restrict bound,
 314         const 'atype_name` * const restrict pwhich,
 315         GFC_INTEGER_4 array_length __attribute__((unused)),
 316         GFC_INTEGER_4 bound_length __attribute__((unused)))
 317 {
 318   eoshift3 (ret, array, h, bound, pwhich, " ", 1);
 319 }
 320
 321
 322 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
 323         GFC_INTEGER_4,
 324         const gfc_array_char * const restrict,
 325         const 'atype` * const restrict,
 326         const gfc_array_char * const restrict,
 327         const 'atype_name` * const restrict,
 328         GFC_INTEGER_4, GFC_INTEGER_4);
 329 export_proto(eoshift3_'atype_kind`_char4);
 330
 331 void
 332 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 333         GFC_INTEGER_4 ret_length __attribute__((unused)),
 334         const gfc_array_char * const restrict array,
 335         const 'atype` *  const restrict h,
 336         const gfc_array_char * const restrict bound,
 337         const 'atype_name` * const restrict pwhich,
 338         GFC_INTEGER_4 array_length __attribute__((unused)),
 339         GFC_INTEGER_4 bound_length __attribute__((unused)))
 340 {
 341   static const gfc_char4_t space = (unsigned char) ''` ''`;
 342   eoshift3 (ret, array, h, bound, pwhich,
 343             (const char *) &space, sizeof (gfc_char4_t));
 344 }
 345
 346 #endif'