libgfortran/generated/cshift1_8.c

   1 /* Implementation of the CSHIFT intrinsic
   2    Copyright 2003, 2007 Free Software Foundation, Inc.
   3    Contributed by Feng Wang <wf_cs@yahoo.com>
   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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Ligbfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35
  36
  37 #if defined (HAVE_GFC_INTEGER_8)
  38
  39 static void
  40 cshift1 (gfc_array_char * const restrict ret,
  41         const gfc_array_char * const restrict array,
  42         const gfc_array_i8 * const restrict h,
  43         const GFC_INTEGER_8 * const restrict pwhich,
  44         index_type size)
  45 {
  46   /* r.* indicates the return array.  */
  47   index_type rstride[GFC_MAX_DIMENSIONS];
  48   index_type rstride0;
  49   index_type roffset;
  50   char *rptr;
  51   char *dest;
  52   /* s.* indicates the source array.  */
  53   index_type sstride[GFC_MAX_DIMENSIONS];
  54   index_type sstride0;
  55   index_type soffset;
  56   const char *sptr;
  57   const char *src;
  58   /* h.* indicates the shift array.  */
  59   index_type hstride[GFC_MAX_DIMENSIONS];
  60   index_type hstride0;
  61   const GFC_INTEGER_8 *hptr;
  62
  63   index_type count[GFC_MAX_DIMENSIONS];
  64   index_type extent[GFC_MAX_DIMENSIONS];
  65   index_type dim;
  66   index_type len;
  67   index_type n;
  68   int which;
  69   GFC_INTEGER_8 sh;
  70
  71   if (pwhich)
  72     which = *pwhich - 1;
  73   else
  74     which = 0;
  75
  76   if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
  77     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
  78
  79   if (ret->data == NULL)
  80     {
  81       int i;
  82
  83       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  84       ret->offset = 0;
  85       ret->dtype = array->dtype;
  86       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  87         {
  88           ret->dim[i].lbound = 0;
  89           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  90
  91           if (i == 0)
  92             ret->dim[i].stride = 1;
  93           else
  94             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  95         }
  96     }
  97
  98   extent[0] = 1;
  99   count[0] = 0;
 100   n = 0;
 101
 102   /* Initialized for avoiding compiler warnings.  */
 103   roffset = size;
 104   soffset = size;
 105   len = 0;
 106
 107   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 108     {
 109       if (dim == which)
 110         {
 111           roffset = ret->dim[dim].stride * size;
 112           if (roffset == 0)
 113             roffset = size;
 114           soffset = array->dim[dim].stride * size;
 115           if (soffset == 0)
 116             soffset = size;
 117           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 118         }
 119       else
 120         {
 121           count[n] = 0;
 122           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 123           rstride[n] = ret->dim[dim].stride * size;
 124           sstride[n] = array->dim[dim].stride * size;
 125
 126           hstride[n] = h->dim[n].stride;
 127           n++;
 128         }
 129     }
 130   if (sstride[0] == 0)
 131     sstride[0] = size;
 132   if (rstride[0] == 0)
 133     rstride[0] = size;
 134   if (hstride[0] == 0)
 135     hstride[0] = 1;
 136
 137   dim = GFC_DESCRIPTOR_RANK (array);
 138   rstride0 = rstride[0];
 139   sstride0 = sstride[0];
 140   hstride0 = hstride[0];
 141   rptr = ret->data;
 142   sptr = array->data;
 143   hptr = h->data;
 144
 145   while (rptr)
 146     {
 147       /* Do the shift for this dimension.  */
 148       sh = *hptr;
 149       sh = (div (sh, len)).rem;
 150       if (sh < 0)
 151         sh += len;
 152
 153       src = &sptr[sh * soffset];
 154       dest = rptr;
 155
 156       for (n = 0; n < len; n++)
 157         {
 158           memcpy (dest, src, size);
 159           dest += roffset;
 160           if (n == len - sh - 1)
 161             src = sptr;
 162           else
 163             src += soffset;
 164         }
 165
 166       /* Advance to the next section.  */
 167       rptr += rstride0;
 168       sptr += sstride0;
 169       hptr += hstride0;
 170       count[0]++;
 171       n = 0;
 172       while (count[n] == extent[n])
 173         {
 174           /* When we get to the end of a dimension, reset it and increment
 175              the next dimension.  */
 176           count[n] = 0;
 177           /* We could precalculate these products, but this is a less
 178              frequently used path so probably not worth it.  */
 179           rptr -= rstride[n] * extent[n];
 180           sptr -= sstride[n] * extent[n];
 181           hptr -= hstride[n] * extent[n];
 182           n++;
 183           if (n >= dim - 1)
 184             {
 185               /* Break out of the loop.  */
 186               rptr = NULL;
 187               break;
 188             }
 189           else
 190             {
 191               count[n]++;
 192               rptr += rstride[n];
 193               sptr += sstride[n];
 194               hptr += hstride[n];
 195             }
 196         }
 197     }
 198 }
 199
 200 void cshift1_8 (gfc_array_char * const restrict,
 201         const gfc_array_char * const restrict,
 202         const gfc_array_i8 * const restrict,
 203         const GFC_INTEGER_8 * const restrict);
 204 export_proto(cshift1_8);
 205
 206 void
 207 cshift1_8 (gfc_array_char * const restrict ret,
 208         const gfc_array_char * const restrict array,
 209         const gfc_array_i8 * const restrict h,
 210         const GFC_INTEGER_8 * const restrict pwhich)
 211 {
 212   cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array));
 213 }
 214
 215
 216 void cshift1_8_char (gfc_array_char * const restrict ret,
 217         GFC_INTEGER_4,
 218         const gfc_array_char * const restrict array,
 219         const gfc_array_i8 * const restrict h,
 220         const GFC_INTEGER_8 * const restrict pwhich,
 221         GFC_INTEGER_4);
 222 export_proto(cshift1_8_char);
 223
 224 void
 225 cshift1_8_char (gfc_array_char * const restrict ret,
 226         GFC_INTEGER_4 ret_length __attribute__((unused)),
 227         const gfc_array_char * const restrict array,
 228         const gfc_array_i8 * const restrict h,
 229         const GFC_INTEGER_8 * const restrict pwhich,
 230         GFC_INTEGER_4 array_length)
 231 {
 232   cshift1 (ret, array, h, pwhich, array_length);
 233 }
 234
 235
 236 void cshift1_8_char4 (gfc_array_char * const restrict ret,
 237         GFC_INTEGER_4,
 238         const gfc_array_char * const restrict array,
 239         const gfc_array_i8 * const restrict h,
 240         const GFC_INTEGER_8 * const restrict pwhich,
 241         GFC_INTEGER_4);
 242 export_proto(cshift1_8_char4);
 243
 244 void
 245 cshift1_8_char4 (gfc_array_char * const restrict ret,
 246         GFC_INTEGER_4 ret_length __attribute__((unused)),
 247         const gfc_array_char * const restrict array,
 248         const gfc_array_i8 * const restrict h,
 249         const GFC_INTEGER_8 * const restrict pwhich,
 250         GFC_INTEGER_4 array_length)
 251 {
 252   cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t));
 253 }
 254
 255 #endif