libgfortran/m4/cshift1.m4

   1 `/* Implementation of the CSHIFT intrinsic
   2    Copyright (C) 2003-2017 Free Software Foundation, Inc.
   3    Contributed by Feng Wang <wf_cs@yahoo.com>
   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 Ligbfortran 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 cshift1 (gfc_array_char * const restrict ret,
  35         const gfc_array_char * const restrict array,
  36         const 'atype` * const restrict h,
  37         const 'atype_name` * const restrict pwhich)
  38 {
  39   /* r.* indicates the return array.  */
  40   index_type rstride[GFC_MAX_DIMENSIONS];
  41   index_type rstride0;
  42   index_type roffset;
  43   char *rptr;
  44   char *dest;
  45   /* s.* indicates the source array.  */
  46   index_type sstride[GFC_MAX_DIMENSIONS];
  47   index_type sstride0;
  48   index_type soffset;
  49   const char *sptr;
  50   const char *src;
  51   /* h.* indicates the shift array.  */
  52   index_type hstride[GFC_MAX_DIMENSIONS];
  53   index_type hstride0;
  54   const 'atype_name` *hptr;
  55
  56   index_type count[GFC_MAX_DIMENSIONS];
  57   index_type extent[GFC_MAX_DIMENSIONS];
  58   index_type dim;
  59   index_type len;
  60   index_type n;
  61   int which;
  62   'atype_name` sh;
  63   index_type arraysize;
  64   index_type size;
  65   index_type type_size;
  66
  67   if (pwhich)
  68     which = *pwhich - 1;
  69   else
  70     which = 0;
  71
  72   if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
  73     runtime_error ("Argument ''`DIM''` is out of range in call to ''`CSHIFT''`");
  74
  75   size = GFC_DESCRIPTOR_SIZE(array);
  76
  77   arraysize = size0 ((array_t *)array);
  78
  79   if (ret->base_addr == NULL)
  80     {
  81       int i;
  82
  83       ret->base_addr = xmallocarray (arraysize, size);
  84       ret->offset = 0;
  85       ret->dtype = array->dtype;
  86       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  87         {
  88           index_type ub, str;
  89
  90           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  91
  92           if (i == 0)
  93             str = 1;
  94           else
  95             str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
  96               GFC_DESCRIPTOR_STRIDE(ret,i-1);
  97
  98           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
  99         }
 100     }
 101   else if (unlikely (compile_options.bounds_check))
 102     {
 103       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 104                                  "return value", "CSHIFT");
 105     }
 106
 107   if (unlikely (compile_options.bounds_check))
 108     {
 109       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 110                               "SHIFT argument", "CSHIFT");
 111     }
 112
 113   if (arraysize == 0)
 114     return;
 115
 116   /* See if we should dispatch to a helper function.  */
 117
 118   type_size = GFC_DTYPE_TYPE_SIZE (array);
 119
 120   switch (type_size)
 121   {
 122     case GFC_DTYPE_LOGICAL_1:
 123     case GFC_DTYPE_INTEGER_1:
 124     case GFC_DTYPE_DERIVED_1:
 125       cshift1_'atype_kind`_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array,
 126                         h, pwhich);
 127       return;
 128
 129     case GFC_DTYPE_LOGICAL_2:
 130     case GFC_DTYPE_INTEGER_2:
 131       cshift1_'atype_kind`_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array,
 132                         h, pwhich);
 133       return;
 134
 135     case GFC_DTYPE_LOGICAL_4:
 136     case GFC_DTYPE_INTEGER_4:
 137       cshift1_'atype_kind`_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array,
 138                         h, pwhich);
 139       return;
 140
 141     case GFC_DTYPE_LOGICAL_8:
 142     case GFC_DTYPE_INTEGER_8:
 143       cshift1_'atype_kind`_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array,
 144                         h, pwhich);
 145       return;
 146
 147 #if defined (HAVE_INTEGER_16)
 148     case GFC_DTYPE_LOGICAL_16:
 149     case GFC_DTYPE_INTEGER_16:
 150       cshift1_'atype_kind`_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array,
 151                         h, pwhich);
 152       return;
 153 #endif
 154
 155     case GFC_DTYPE_REAL_4:
 156       cshift1_'atype_kind`_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array,
 157                         h, pwhich);
 158       return;
 159
 160     case GFC_DTYPE_REAL_8:
 161       cshift1_'atype_kind`_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array,
 162                         h, pwhich);
 163       return;
 164
 165 #if defined (HAVE_REAL_10)
 166     case GFC_DTYPE_REAL_10:
 167       cshift1_'atype_kind`_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array,
 168                         h, pwhich);
 169       return;
 170 #endif
 171
 172 #if defined (HAVE_REAL_16)
 173     case GFC_DTYPE_REAL_16:
 174       cshift1_'atype_kind`_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array,
 175                         h, pwhich);
 176       return;
 177 #endif
 178
 179     case GFC_DTYPE_COMPLEX_4:
 180       cshift1_'atype_kind`_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array,
 181                         h, pwhich);
 182       return;
 183
 184     case GFC_DTYPE_COMPLEX_8:
 185       cshift1_'atype_kind`_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array,
 186                         h, pwhich);
 187       return;
 188
 189 #if defined (HAVE_COMPLEX_10)
 190     case GFC_DTYPE_COMPLEX_10:
 191       cshift1_'atype_kind`_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array,
 192                         h, pwhich);
 193       return;
 194 #endif
 195
 196 #if defined (HAVE_COMPLEX_16)
 197     case GFC_DTYPE_COMPLEX_16:
 198       cshift1_'atype_kind`_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array,
 199                         h, pwhich);
 200       return;
 201 #endif
 202
 203     default:
 204       break;
 205
 206   }
 207
 208   extent[0] = 1;
 209   count[0] = 0;
 210   n = 0;
 211
 212   /* Initialized for avoiding compiler warnings.  */
 213   roffset = size;
 214   soffset = size;
 215   len = 0;
 216
 217   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 218     {
 219       if (dim == which)
 220         {
 221           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 222           if (roffset == 0)
 223             roffset = size;
 224           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 225           if (soffset == 0)
 226             soffset = size;
 227           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 228         }
 229       else
 230         {
 231           count[n] = 0;
 232           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 233           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 234           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 235
 236           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 237           n++;
 238         }
 239     }
 240   if (sstride[0] == 0)
 241     sstride[0] = size;
 242   if (rstride[0] == 0)
 243     rstride[0] = size;
 244   if (hstride[0] == 0)
 245     hstride[0] = 1;
 246
 247   dim = GFC_DESCRIPTOR_RANK (array);
 248   rstride0 = rstride[0];
 249   sstride0 = sstride[0];
 250   hstride0 = hstride[0];
 251   rptr = ret->base_addr;
 252   sptr = array->base_addr;
 253   hptr = h->base_addr;
 254
 255   while (rptr)
 256     {
 257       /* Do the shift for this dimension.  */
 258       sh = *hptr;
 259       /* Normal case should be -len < sh < len; try to
 260          avoid the expensive remainder operation if possible.  */
 261       if (sh < 0)
 262         sh += len;
 263       if (unlikely (sh >= len || sh < 0))
 264         {
 265           sh = sh % len;
 266           if (sh < 0)
 267             sh += len;
 268         }
 269
 270       src = &sptr[sh * soffset];
 271       dest = rptr;
 272       if (soffset == size && roffset == size)
 273       {
 274         size_t len1 = sh * size;
 275         size_t len2 = (len - sh) * size;
 276         memcpy (rptr, sptr + len1, len2);
 277         memcpy (rptr + len2, sptr, len1);
 278       }
 279       else
 280         {
 281           for (n = 0; n < len - sh; n++)
 282             {
 283               memcpy (dest, src, size);
 284               dest += roffset;
 285               src += soffset;
 286             }
 287             for (src = sptr, n = 0; n < sh; n++)
 288               {
 289                 memcpy (dest, src, size);
 290                 dest += roffset;
 291                 src += soffset;
 292               }
 293           }
 294
 295       /* Advance to the next section.  */
 296       rptr += rstride0;
 297       sptr += sstride0;
 298       hptr += hstride0;
 299       count[0]++;
 300       n = 0;
 301       while (count[n] == extent[n])
 302         {
 303           /* When we get to the end of a dimension, reset it and increment
 304              the next dimension.  */
 305           count[n] = 0;
 306           /* We could precalculate these products, but this is a less
 307              frequently used path so probably not worth it.  */
 308           rptr -= rstride[n] * extent[n];
 309           sptr -= sstride[n] * extent[n];
 310           hptr -= hstride[n] * extent[n];
 311           n++;
 312           if (n >= dim - 1)
 313             {
 314               /* Break out of the loop.  */
 315               rptr = NULL;
 316               break;
 317             }
 318           else
 319             {
 320               count[n]++;
 321               rptr += rstride[n];
 322               sptr += sstride[n];
 323               hptr += hstride[n];
 324             }
 325         }
 326     }
 327 }
 328
 329 void cshift1_'atype_kind` (gfc_array_char * const restrict,
 330         const gfc_array_char * const restrict,
 331         const 'atype` * const restrict,
 332         const 'atype_name` * const restrict);
 333 export_proto(cshift1_'atype_kind`);
 334
 335 void
 336 cshift1_'atype_kind` (gfc_array_char * const restrict ret,
 337         const gfc_array_char * const restrict array,
 338         const 'atype` * const restrict h,
 339         const 'atype_name` * const restrict pwhich)
 340 {
 341   cshift1 (ret, array, h, pwhich);
 342 }
 343
 344
 345 void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 346         GFC_INTEGER_4,
 347         const gfc_array_char * const restrict array,
 348         const 'atype` * const restrict h,
 349         const 'atype_name` * const restrict pwhich,
 350         GFC_INTEGER_4);
 351 export_proto(cshift1_'atype_kind`_char);
 352
 353 void
 354 cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 355         GFC_INTEGER_4 ret_length __attribute__((unused)),
 356         const gfc_array_char * const restrict array,
 357         const 'atype` * const restrict h,
 358         const 'atype_name` * const restrict pwhich,
 359         GFC_INTEGER_4 array_length __attribute__((unused)))
 360 {
 361   cshift1 (ret, array, h, pwhich);
 362 }
 363
 364
 365 void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 366         GFC_INTEGER_4,
 367         const gfc_array_char * const restrict array,
 368         const 'atype` * const restrict h,
 369         const 'atype_name` * const restrict pwhich,
 370         GFC_INTEGER_4);
 371 export_proto(cshift1_'atype_kind`_char4);
 372
 373 void
 374 cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 375         GFC_INTEGER_4 ret_length __attribute__((unused)),
 376         const gfc_array_char * const restrict array,
 377         const 'atype` * const restrict h,
 378         const 'atype_name` * const restrict pwhich,
 379         GFC_INTEGER_4 array_length __attribute__((unused)))
 380 {
 381   cshift1 (ret, array, h, pwhich);
 382 }
 383
 384 #endif'