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
  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       ret->dtype = array->dtype;
  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   extent[0] = 1;
 116   count[0] = 0;
 117   n = 0;
 118
 119   /* Initialized for avoiding compiler warnings.  */
 120   roffset = size;
 121   soffset = size;
 122   len = 0;
 123
 124   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 125     {
 126       if (dim == which)
 127         {
 128           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 129           if (roffset == 0)
 130             roffset = size;
 131           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 132           if (soffset == 0)
 133             soffset = size;
 134           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 135         }
 136       else
 137         {
 138           count[n] = 0;
 139           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 140           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 141           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 142
 143           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 144           n++;
 145         }
 146     }
 147   if (sstride[0] == 0)
 148     sstride[0] = size;
 149   if (rstride[0] == 0)
 150     rstride[0] = size;
 151   if (hstride[0] == 0)
 152     hstride[0] = 1;
 153
 154   dim = GFC_DESCRIPTOR_RANK (array);
 155   rstride0 = rstride[0];
 156   sstride0 = sstride[0];
 157   hstride0 = hstride[0];
 158   rptr = ret->base_addr;
 159   sptr = array->base_addr;
 160   hptr = h->base_addr;
 161
 162   while (rptr)
 163     {
 164       /* Do the shift for this dimension.  */
 165       sh = *hptr;
 166       sh = (div (sh, len)).rem;
 167       if (sh < 0)
 168         sh += len;
 169
 170       src = &sptr[sh * soffset];
 171       dest = rptr;
 172
 173       for (n = 0; n < len; n++)
 174         {
 175           memcpy (dest, src, size);
 176           dest += roffset;
 177           if (n == len - sh - 1)
 178             src = sptr;
 179           else
 180             src += soffset;
 181         }
 182
 183       /* Advance to the next section.  */
 184       rptr += rstride0;
 185       sptr += sstride0;
 186       hptr += hstride0;
 187       count[0]++;
 188       n = 0;
 189       while (count[n] == extent[n])
 190         {
 191           /* When we get to the end of a dimension, reset it and increment
 192              the next dimension.  */
 193           count[n] = 0;
 194           /* We could precalculate these products, but this is a less
 195              frequently used path so probably not worth it.  */
 196           rptr -= rstride[n] * extent[n];
 197           sptr -= sstride[n] * extent[n];
 198           hptr -= hstride[n] * extent[n];
 199           n++;
 200           if (n >= dim - 1)
 201             {
 202               /* Break out of the loop.  */
 203               rptr = NULL;
 204               break;
 205             }
 206           else
 207             {
 208               count[n]++;
 209               rptr += rstride[n];
 210               sptr += sstride[n];
 211               hptr += hstride[n];
 212             }
 213         }
 214     }
 215 }
 216
 217 void cshift1_'atype_kind` (gfc_array_char * const restrict,
 218         const gfc_array_char * const restrict,
 219         const 'atype` * const restrict,
 220         const 'atype_name` * const restrict);
 221 export_proto(cshift1_'atype_kind`);
 222
 223 void
 224 cshift1_'atype_kind` (gfc_array_char * const restrict ret,
 225         const gfc_array_char * const restrict array,
 226         const 'atype` * const restrict h,
 227         const 'atype_name` * const restrict pwhich)
 228 {
 229   cshift1 (ret, array, h, pwhich);
 230 }
 231
 232
 233 void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 234         GFC_INTEGER_4,
 235         const gfc_array_char * const restrict array,
 236         const 'atype` * const restrict h,
 237         const 'atype_name` * const restrict pwhich,
 238         GFC_INTEGER_4);
 239 export_proto(cshift1_'atype_kind`_char);
 240
 241 void
 242 cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 243         GFC_INTEGER_4 ret_length __attribute__((unused)),
 244         const gfc_array_char * const restrict array,
 245         const 'atype` * const restrict h,
 246         const 'atype_name` * const restrict pwhich,
 247         GFC_INTEGER_4 array_length __attribute__((unused)))
 248 {
 249   cshift1 (ret, array, h, pwhich);
 250 }
 251
 252
 253 void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 254         GFC_INTEGER_4,
 255         const gfc_array_char * const restrict array,
 256         const 'atype` * const restrict h,
 257         const 'atype_name` * const restrict pwhich,
 258         GFC_INTEGER_4);
 259 export_proto(cshift1_'atype_kind`_char4);
 260
 261 void
 262 cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 263         GFC_INTEGER_4 ret_length __attribute__((unused)),
 264         const gfc_array_char * const restrict array,
 265         const 'atype` * const restrict h,
 266         const 'atype_name` * const restrict pwhich,
 267         GFC_INTEGER_4 array_length __attribute__((unused)))
 268 {
 269   cshift1 (ret, array, h, pwhich);
 270 }
 271
 272 #endif'