libgfortran/generated/eoshift1_8.c

   1 /* Implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.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 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 Libgfortran 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 "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35 #include "libgfortran.h"
  36
  37 #if defined (HAVE_GFC_INTEGER_8)
  38
  39 static void
  40 eoshift1 (gfc_array_char * const restrict ret,
  41         const gfc_array_char * const restrict array,
  42         const gfc_array_i8 * const restrict h,
  43         const char * const restrict pbound,
  44         const GFC_INTEGER_8 * const restrict pwhich,
  45         index_type size, char filler)
  46 {
  47   /* r.* indicates the return array.  */
  48   index_type rstride[GFC_MAX_DIMENSIONS];
  49   index_type rstride0;
  50   index_type roffset;
  51   char *rptr;
  52   char *dest;
  53   /* s.* indicates the source array.  */
  54   index_type sstride[GFC_MAX_DIMENSIONS];
  55   index_type sstride0;
  56   index_type soffset;
  57   const char *sptr;
  58   const char *src;
  59   /* h.* indicates the shift array.  */
  60   index_type hstride[GFC_MAX_DIMENSIONS];
  61   index_type hstride0;
  62   const GFC_INTEGER_8 *hptr;
  63
  64   index_type count[GFC_MAX_DIMENSIONS];
  65   index_type extent[GFC_MAX_DIMENSIONS];
  66   index_type dim;
  67   index_type len;
  68   index_type n;
  69   int which;
  70   GFC_INTEGER_8 sh;
  71   GFC_INTEGER_8 delta;
  72
  73   /* The compiler cannot figure out that these are set, initialize
  74      them to avoid warnings.  */
  75   len = 0;
  76   soffset = 0;
  77   roffset = 0;
  78
  79   if (pwhich)
  80     which = *pwhich - 1;
  81   else
  82     which = 0;
  83
  84   extent[0] = 1;
  85   count[0] = 0;
  86
  87   if (ret->data == NULL)
  88     {
  89       int i;
  90
  91       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  92       ret->offset = 0;
  93       ret->dtype = array->dtype;
  94       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  95         {
  96           ret->dim[i].lbound = 0;
  97           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  98
  99           if (i == 0)
 100             ret->dim[i].stride = 1;
 101           else
 102             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
 103         }
 104     }
 105
 106   n = 0;
 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       if (( sh >= 0 ? sh : -sh ) > len)
 150         {
 151           delta = len;
 152           sh = len;
 153         }
 154       else
 155         delta = (sh >= 0) ? sh: -sh;
 156
 157       if (sh > 0)
 158         {
 159           src = &sptr[delta * soffset];
 160           dest = rptr;
 161         }
 162       else
 163         {
 164           src = sptr;
 165           dest = &rptr[delta * roffset];
 166         }
 167       for (n = 0; n < len - delta; n++)
 168         {
 169           memcpy (dest, src, size);
 170           dest += roffset;
 171           src += soffset;
 172         }
 173       if (sh < 0)
 174         dest = rptr;
 175       n = delta;
 176
 177       if (pbound)
 178         while (n--)
 179           {
 180             memcpy (dest, pbound, size);
 181             dest += roffset;
 182           }
 183       else
 184         while (n--)
 185           {
 186             memset (dest, filler, size);
 187             dest += roffset;
 188           }
 189
 190       /* Advance to the next section.  */
 191       rptr += rstride0;
 192       sptr += sstride0;
 193       hptr += hstride0;
 194       count[0]++;
 195       n = 0;
 196       while (count[n] == extent[n])
 197         {
 198           /* When we get to the end of a dimension, reset it and increment
 199              the next dimension.  */
 200           count[n] = 0;
 201           /* We could precalculate these products, but this is a less
 202              frequently used path so proabably not worth it.  */
 203           rptr -= rstride[n] * extent[n];
 204           sptr -= sstride[n] * extent[n];
 205           hptr -= hstride[n] * extent[n];
 206           n++;
 207           if (n >= dim - 1)
 208             {
 209               /* Break out of the loop.  */
 210               rptr = NULL;
 211               break;
 212             }
 213           else
 214             {
 215               count[n]++;
 216               rptr += rstride[n];
 217               sptr += sstride[n];
 218               hptr += hstride[n];
 219             }
 220         }
 221     }
 222 }
 223
 224 void eoshift1_8 (gfc_array_char * const restrict,
 225         const gfc_array_char * const restrict,
 226         const gfc_array_i8 * const restrict, const char * const restrict,
 227         const GFC_INTEGER_8 * const restrict);
 228 export_proto(eoshift1_8);
 229
 230 void
 231 eoshift1_8 (gfc_array_char * const restrict ret,
 232         const gfc_array_char * const restrict array,
 233         const gfc_array_i8 * const restrict h,
 234         const char * const restrict pbound,
 235         const GFC_INTEGER_8 * const restrict pwhich)
 236 {
 237   eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
 238 }
 239
 240 void eoshift1_8_char (gfc_array_char * const restrict,
 241         GFC_INTEGER_4,
 242         const gfc_array_char * const restrict,
 243         const gfc_array_i8 * const restrict,
 244         const char * const restrict,
 245         const GFC_INTEGER_8 * const restrict,
 246         GFC_INTEGER_4, GFC_INTEGER_4);
 247 export_proto(eoshift1_8_char);
 248
 249 void
 250 eoshift1_8_char (gfc_array_char * const restrict ret,
 251         GFC_INTEGER_4 ret_length __attribute__((unused)),
 252         const gfc_array_char * const restrict array,
 253         const gfc_array_i8 * const restrict h,
 254         const char *  const restrict pbound,
 255         const GFC_INTEGER_8 * const restrict pwhich,
 256         GFC_INTEGER_4 array_length,
 257         GFC_INTEGER_4 bound_length __attribute__((unused)))
 258 {
 259   eoshift1 (ret, array, h, pbound, pwhich, array_length, ' ');
 260 }
 261
 262 #endif