libgfortran/generated/cshift1_16.c

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