libgfortran/m4/eoshift1.m4

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