libgfortran/generated/cshift1_4.c

   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
  30 #if defined (HAVE_GFC_INTEGER_4)
  31
  32 static void
  33 cshift1 (gfc_array_char * const restrict ret,
  34         const gfc_array_char * const restrict array,
  35         const gfc_array_i4 * const restrict h,
  36         const GFC_INTEGER_4 * 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_4 *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_4 sh;
  62   index_type arraysize;
  63   index_type size;
  64
  65   if (pwhich)
  66     which = *pwhich - 1;
  67   else
  68     which = 0;
  69
  70   if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
  71     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
  72
  73   size = GFC_DESCRIPTOR_SIZE(array);
  74
  75   arraysize = size0 ((array_t *)array);
  76
  77   if (ret->base_addr == NULL)
  78     {
  79       int i;
  80
  81       ret->base_addr = xmallocarray (arraysize, size);
  82       ret->offset = 0;
  83       ret->dtype = array->dtype;
  84       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  85         {
  86           index_type ub, str;
  87
  88           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  89
  90           if (i == 0)
  91             str = 1;
  92           else
  93             str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
  94               GFC_DESCRIPTOR_STRIDE(ret,i-1);
  95
  96           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
  97         }
  98     }
  99   else if (unlikely (compile_options.bounds_check))
 100     {
 101       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 102                                  "return value", "CSHIFT");
 103     }
 104
 105   if (unlikely (compile_options.bounds_check))
 106     {
 107       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 108                               "SHIFT argument", "CSHIFT");
 109     }
 110
 111   if (arraysize == 0)
 112     return;
 113
 114   extent[0] = 1;
 115   count[0] = 0;
 116   n = 0;
 117
 118   /* Initialized for avoiding compiler warnings.  */
 119   roffset = size;
 120   soffset = size;
 121   len = 0;
 122
 123   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 124     {
 125       if (dim == which)
 126         {
 127           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 128           if (roffset == 0)
 129             roffset = size;
 130           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 131           if (soffset == 0)
 132             soffset = size;
 133           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 134         }
 135       else
 136         {
 137           count[n] = 0;
 138           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 139           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 140           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 141
 142           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 143           n++;
 144         }
 145     }
 146   if (sstride[0] == 0)
 147     sstride[0] = size;
 148   if (rstride[0] == 0)
 149     rstride[0] = size;
 150   if (hstride[0] == 0)
 151     hstride[0] = 1;
 152
 153   dim = GFC_DESCRIPTOR_RANK (array);
 154   rstride0 = rstride[0];
 155   sstride0 = sstride[0];
 156   hstride0 = hstride[0];
 157   rptr = ret->base_addr;
 158   sptr = array->base_addr;
 159   hptr = h->base_addr;
 160
 161   while (rptr)
 162     {
 163       /* Do the shift for this dimension.  */
 164       sh = *hptr;
 165       sh = (div (sh, len)).rem;
 166       if (sh < 0)
 167         sh += len;
 168
 169       src = &sptr[sh * soffset];
 170       dest = rptr;
 171
 172       for (n = 0; n < len; n++)
 173         {
 174           memcpy (dest, src, size);
 175           dest += roffset;
 176           if (n == len - sh - 1)
 177             src = sptr;
 178           else
 179             src += soffset;
 180         }
 181
 182       /* Advance to the next section.  */
 183       rptr += rstride0;
 184       sptr += sstride0;
 185       hptr += hstride0;
 186       count[0]++;
 187       n = 0;
 188       while (count[n] == extent[n])
 189         {
 190           /* When we get to the end of a dimension, reset it and increment
 191              the next dimension.  */
 192           count[n] = 0;
 193           /* We could precalculate these products, but this is a less
 194              frequently used path so probably not worth it.  */
 195           rptr -= rstride[n] * extent[n];
 196           sptr -= sstride[n] * extent[n];
 197           hptr -= hstride[n] * extent[n];
 198           n++;
 199           if (n >= dim - 1)
 200             {
 201               /* Break out of the loop.  */
 202               rptr = NULL;
 203               break;
 204             }
 205           else
 206             {
 207               count[n]++;
 208               rptr += rstride[n];
 209               sptr += sstride[n];
 210               hptr += hstride[n];
 211             }
 212         }
 213     }
 214 }
 215
 216 void cshift1_4 (gfc_array_char * const restrict,
 217         const gfc_array_char * const restrict,
 218         const gfc_array_i4 * const restrict,
 219         const GFC_INTEGER_4 * const restrict);
 220 export_proto(cshift1_4);
 221
 222 void
 223 cshift1_4 (gfc_array_char * const restrict ret,
 224         const gfc_array_char * const restrict array,
 225         const gfc_array_i4 * const restrict h,
 226         const GFC_INTEGER_4 * const restrict pwhich)
 227 {
 228   cshift1 (ret, array, h, pwhich);
 229 }
 230
 231
 232 void cshift1_4_char (gfc_array_char * const restrict ret,
 233         GFC_INTEGER_4,
 234         const gfc_array_char * const restrict array,
 235         const gfc_array_i4 * const restrict h,
 236         const GFC_INTEGER_4 * const restrict pwhich,
 237         GFC_INTEGER_4);
 238 export_proto(cshift1_4_char);
 239
 240 void
 241 cshift1_4_char (gfc_array_char * const restrict ret,
 242         GFC_INTEGER_4 ret_length __attribute__((unused)),
 243         const gfc_array_char * const restrict array,
 244         const gfc_array_i4 * const restrict h,
 245         const GFC_INTEGER_4 * const restrict pwhich,
 246         GFC_INTEGER_4 array_length __attribute__((unused)))
 247 {
 248   cshift1 (ret, array, h, pwhich);
 249 }
 250
 251
 252 void cshift1_4_char4 (gfc_array_char * const restrict ret,
 253         GFC_INTEGER_4,
 254         const gfc_array_char * const restrict array,
 255         const gfc_array_i4 * const restrict h,
 256         const GFC_INTEGER_4 * const restrict pwhich,
 257         GFC_INTEGER_4);
 258 export_proto(cshift1_4_char4);
 259
 260 void
 261 cshift1_4_char4 (gfc_array_char * const restrict ret,
 262         GFC_INTEGER_4 ret_length __attribute__((unused)),
 263         const gfc_array_char * const restrict array,
 264         const gfc_array_i4 * const restrict h,
 265         const GFC_INTEGER_4 * const restrict pwhich,
 266         GFC_INTEGER_4 array_length __attribute__((unused)))
 267 {
 268   cshift1 (ret, array, h, pwhich);
 269 }
 270
 271 #endif