libgfortran/m4/eoshift3.m4

   1 `/* Implementation of the EOSHIFT intrinsic
   2    Copyright (C) 2002-2019 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       ret->base_addr = xmallocarray (arraysize, size);
  90       ret->offset = 0;
  91       GFC_DTYPE_COPY(ret,array);
  92       for (index_type 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   extent[0] = 1;
 127   count[0] = 0;
 128   n = 0;
 129   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 130     {
 131       if (dim == which)
 132         {
 133           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 134           if (roffset == 0)
 135             roffset = size;
 136           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 137           if (soffset == 0)
 138             soffset = size;
 139           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 140         }
 141       else
 142         {
 143           count[n] = 0;
 144           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 145           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 146           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 147
 148           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 149           if (bound)
 150             bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
 151           else
 152             bstride[n] = 0;
 153           n++;
 154         }
 155     }
 156   if (sstride[0] == 0)
 157     sstride[0] = size;
 158   if (rstride[0] == 0)
 159     rstride[0] = size;
 160   if (hstride[0] == 0)
 161     hstride[0] = 1;
 162   if (bound && bstride[0] == 0)
 163     bstride[0] = size;
 164
 165   dim = GFC_DESCRIPTOR_RANK (array);
 166   rstride0 = rstride[0];
 167   sstride0 = sstride[0];
 168   hstride0 = hstride[0];
 169   bstride0 = bstride[0];
 170   rptr = ret->base_addr;
 171   sptr = array->base_addr;
 172   hptr = h->base_addr;
 173   if (bound)
 174     bptr = bound->base_addr;
 175   else
 176     bptr = NULL;
 177
 178   while (rptr)
 179     {
 180       /* Do the shift for this dimension.  */
 181       sh = *hptr;
 182       if (( sh >= 0 ? sh : -sh ) > len)
 183         {
 184           delta = len;
 185           sh = len;
 186         }
 187       else
 188         delta = (sh >= 0) ? sh: -sh;
 189
 190       if (sh > 0)
 191         {
 192           src = &sptr[delta * soffset];
 193           dest = rptr;
 194         }
 195       else
 196         {
 197           src = sptr;
 198           dest = &rptr[delta * roffset];
 199         }
 200
 201       /* If the elements are contiguous, perform a single block move.  */
 202       if (soffset == size && roffset == size)
 203         {
 204           size_t chunk = size * (len - delta);
 205           memcpy (dest, src, chunk);
 206           dest += chunk;
 207         }
 208       else
 209         {
 210           for (n = 0; n < len - delta; n++)
 211             {
 212               memcpy (dest, src, size);
 213               dest += roffset;
 214               src += soffset;
 215             }
 216         }
 217
 218       if (sh < 0)
 219         dest = rptr;
 220       n = delta;
 221
 222       if (bptr)
 223         while (n--)
 224           {
 225             memcpy (dest, bptr, size);
 226             dest += roffset;
 227           }
 228       else
 229         while (n--)
 230           {
 231             index_type i;
 232
 233             if (filler_len == 1)
 234               memset (dest, filler[0], size);
 235             else
 236               for (i = 0; i < size; i += filler_len)
 237                 memcpy (&dest[i], filler, filler_len);
 238
 239             dest += roffset;
 240           }
 241
 242       /* Advance to the next section.  */
 243       rptr += rstride0;
 244       sptr += sstride0;
 245       hptr += hstride0;
 246       bptr += bstride0;
 247       count[0]++;
 248       n = 0;
 249       while (count[n] == extent[n])
 250         {
 251           /* When we get to the end of a dimension, reset it and increment
 252              the next dimension.  */
 253           count[n] = 0;
 254           /* We could precalculate these products, but this is a less
 255              frequently used path so probably not worth it.  */
 256           rptr -= rstride[n] * extent[n];
 257           sptr -= sstride[n] * extent[n];
 258           hptr -= hstride[n] * extent[n];
 259           bptr -= bstride[n] * extent[n];
 260           n++;
 261           if (n >= dim - 1)
 262             {
 263               /* Break out of the loop.  */
 264               rptr = NULL;
 265               break;
 266             }
 267           else
 268             {
 269               count[n]++;
 270               rptr += rstride[n];
 271               sptr += sstride[n];
 272               hptr += hstride[n];
 273               bptr += bstride[n];
 274             }
 275         }
 276     }
 277 }
 278
 279 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
 280         const gfc_array_char * const restrict,
 281         const 'atype` * const restrict,
 282         const gfc_array_char * const restrict,
 283         const 'atype_name` *);
 284 export_proto(eoshift3_'atype_kind`);
 285
 286 void
 287 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
 288         const gfc_array_char * const restrict array,
 289         const 'atype` * const restrict h,
 290         const gfc_array_char * const restrict bound,
 291         const 'atype_name` * const restrict pwhich)
 292 {
 293   eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
 294 }
 295
 296
 297 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
 298         GFC_INTEGER_4,
 299         const gfc_array_char * const restrict,
 300         const 'atype` * const restrict,
 301         const gfc_array_char * const restrict,
 302         const 'atype_name` * const restrict,
 303         GFC_INTEGER_4, GFC_INTEGER_4);
 304 export_proto(eoshift3_'atype_kind`_char);
 305
 306 void
 307 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
 308         GFC_INTEGER_4 ret_length __attribute__((unused)),
 309         const gfc_array_char * const restrict array,
 310         const 'atype` *  const restrict h,
 311         const gfc_array_char * const restrict bound,
 312         const 'atype_name` * const restrict pwhich,
 313         GFC_INTEGER_4 array_length __attribute__((unused)),
 314         GFC_INTEGER_4 bound_length __attribute__((unused)))
 315 {
 316   eoshift3 (ret, array, h, bound, pwhich, " ", 1);
 317 }
 318
 319
 320 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
 321         GFC_INTEGER_4,
 322         const gfc_array_char * const restrict,
 323         const 'atype` * const restrict,
 324         const gfc_array_char * const restrict,
 325         const 'atype_name` * const restrict,
 326         GFC_INTEGER_4, GFC_INTEGER_4);
 327 export_proto(eoshift3_'atype_kind`_char4);
 328
 329 void
 330 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 331         GFC_INTEGER_4 ret_length __attribute__((unused)),
 332         const gfc_array_char * const restrict array,
 333         const 'atype` *  const restrict h,
 334         const gfc_array_char * const restrict bound,
 335         const 'atype_name` * const restrict pwhich,
 336         GFC_INTEGER_4 array_length __attribute__((unused)),
 337         GFC_INTEGER_4 bound_length __attribute__((unused)))
 338 {
 339   static const gfc_char4_t space = (unsigned char) ''` ''`;
 340   eoshift3 (ret, array, h, bound, pwhich,
 341             (const char *) &space, sizeof (gfc_char4_t));
 342 }
 343
 344 #endif'