libgfortran/m4/cshift0.m4

   1 `/* Helper function for cshift functions.
   2    Copyright 2008, 2009 Free Software Foundation, Inc.
   3    Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
   4
   5 This file is part of the GNU Fortran 95 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 <stdlib.h>
  28 #include <assert.h>
  29 #include <string.h>'
  30
  31 include(iparm.m4)dnl
  32
  33 `#if defined (HAVE_'rtype_name`)
  34
  35 void
  36 cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift,
  37                      int which)
  38 {
  39   /* r.* indicates the return array.  */
  40   index_type rstride[GFC_MAX_DIMENSIONS];
  41   index_type rstride0;
  42   index_type roffset;
  43   'rtype_name` *rptr;
  44
  45   /* s.* indicates the source array.  */
  46   index_type sstride[GFC_MAX_DIMENSIONS];
  47   index_type sstride0;
  48   index_type soffset;
  49   const 'rtype_name` *sptr;
  50
  51   index_type count[GFC_MAX_DIMENSIONS];
  52   index_type extent[GFC_MAX_DIMENSIONS];
  53   index_type dim;
  54   index_type len;
  55   index_type n;
  56
  57   which = which - 1;
  58   sstride[0] = 0;
  59   rstride[0] = 0;
  60
  61   extent[0] = 1;
  62   count[0] = 0;
  63   n = 0;
  64   /* Initialized for avoiding compiler warnings.  */
  65   roffset = 1;
  66   soffset = 1;
  67   len = 0;
  68
  69   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
  70     {
  71       if (dim == which)
  72         {
  73           roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
  74           if (roffset == 0)
  75             roffset = 1;
  76           soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
  77           if (soffset == 0)
  78             soffset = 1;
  79           len = GFC_DESCRIPTOR_EXTENT(array,dim);
  80         }
  81       else
  82         {
  83           count[n] = 0;
  84           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
  85           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
  86           sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
  87           n++;
  88         }
  89     }
  90   if (sstride[0] == 0)
  91     sstride[0] = 1;
  92   if (rstride[0] == 0)
  93     rstride[0] = 1;
  94
  95   dim = GFC_DESCRIPTOR_RANK (array);
  96   rstride0 = rstride[0];
  97   sstride0 = sstride[0];
  98   rptr = ret->data;
  99   sptr = array->data;
 100
 101   shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
 102   if (shift < 0)
 103     shift += len;
 104
 105   while (rptr)
 106     {
 107       /* Do the shift for this dimension.  */
 108
 109       /* If elements are contiguous, perform the operation
 110          in two block moves.  */
 111       if (soffset == 1 && roffset == 1)
 112         {
 113           size_t len1 = shift * sizeof ('rtype_name`);
 114           size_t len2 = (len - shift) * sizeof ('rtype_name`);
 115           memcpy (rptr, sptr + shift, len2);
 116           memcpy (rptr + (len - shift), sptr, len1);
 117         }
 118       else
 119         {
 120           /* Otherwise, we will have to perform the copy one element at
 121              a time.  */
 122           'rtype_name` *dest = rptr;
 123           const 'rtype_name` *src = &sptr[shift * soffset];
 124
 125           for (n = 0; n < len - shift; n++)
 126             {
 127               *dest = *src;
 128               dest += roffset;
 129               src += soffset;
 130             }
 131           for (src = sptr, n = 0; n < shift; n++)
 132             {
 133               *dest = *src;
 134               dest += roffset;
 135               src += soffset;
 136             }
 137         }
 138
 139       /* Advance to the next section.  */
 140       rptr += rstride0;
 141       sptr += sstride0;
 142       count[0]++;
 143       n = 0;
 144       while (count[n] == extent[n])
 145         {
 146           /* When we get to the end of a dimension, reset it and increment
 147              the next dimension.  */
 148           count[n] = 0;
 149           /* We could precalculate these products, but this is a less
 150              frequently used path so probably not worth it.  */
 151           rptr -= rstride[n] * extent[n];
 152           sptr -= sstride[n] * extent[n];
 153           n++;
 154           if (n >= dim - 1)
 155             {
 156               /* Break out of the loop.  */
 157               rptr = NULL;
 158               break;
 159             }
 160           else
 161             {
 162               count[n]++;
 163               rptr += rstride[n];
 164               sptr += sstride[n];
 165             }
 166         }
 167     }
 168
 169   return;
 170 }
 171
 172 #endif'