libgfortran/intrinsics/eoshift0.c

   1 /* Generic implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005, 2007 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 "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35
  36 /* TODO: make this work for large shifts when
  37    sizeof(int) < sizeof (index_type).  */
  38
  39 static void
  40 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
  41           int shift, const char * pbound, int which, index_type size,
  42           const char *filler, index_type filler_len)
  43 {
  44   /* r.* indicates the return array.  */
  45   index_type rstride[GFC_MAX_DIMENSIONS];
  46   index_type rstride0;
  47   index_type roffset;
  48   char * restrict rptr;
  49   char *dest;
  50   /* s.* indicates the source array.  */
  51   index_type sstride[GFC_MAX_DIMENSIONS];
  52   index_type sstride0;
  53   index_type soffset;
  54   const char *sptr;
  55   const char *src;
  56
  57   index_type count[GFC_MAX_DIMENSIONS];
  58   index_type extent[GFC_MAX_DIMENSIONS];
  59   index_type dim;
  60   index_type len;
  61   index_type n;
  62
  63   /* The compiler cannot figure out that these are set, initialize
  64      them to avoid warnings.  */
  65   len = 0;
  66   soffset = 0;
  67   roffset = 0;
  68
  69   if (ret->data == NULL)
  70     {
  71       int i;
  72
  73       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  74       ret->offset = 0;
  75       ret->dtype = array->dtype;
  76       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  77         {
  78           ret->dim[i].lbound = 0;
  79           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  80
  81           if (i == 0)
  82             ret->dim[i].stride = 1;
  83           else
  84             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
  85         }
  86     }
  87   else
  88     {
  89       if (size0 ((array_t *) ret) == 0)
  90         return;
  91     }
  92
  93   which = which - 1;
  94
  95   extent[0] = 1;
  96   count[0] = 0;
  97   sstride[0] = -1;
  98   rstride[0] = -1;
  99   n = 0;
 100   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 101     {
 102       if (dim == which)
 103         {
 104           roffset = ret->dim[dim].stride * size;
 105           if (roffset == 0)
 106             roffset = size;
 107           soffset = array->dim[dim].stride * size;
 108           if (soffset == 0)
 109             soffset = size;
 110           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 111         }
 112       else
 113         {
 114           count[n] = 0;
 115           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 116           rstride[n] = ret->dim[dim].stride * size;
 117           sstride[n] = array->dim[dim].stride * size;
 118           n++;
 119         }
 120     }
 121   if (sstride[0] == 0)
 122     sstride[0] = size;
 123   if (rstride[0] == 0)
 124     rstride[0] = size;
 125
 126   dim = GFC_DESCRIPTOR_RANK (array);
 127   rstride0 = rstride[0];
 128   sstride0 = sstride[0];
 129   rptr = ret->data;
 130   sptr = array->data;
 131
 132   if ((shift >= 0 ? shift : -shift) > len)
 133     {
 134       shift = len;
 135       len = 0;
 136     }
 137   else
 138     {
 139       if (shift > 0)
 140         len = len - shift;
 141       else
 142         len = len + shift;
 143     }
 144
 145   while (rptr)
 146     {
 147       /* Do the shift for this dimension.  */
 148       if (shift > 0)
 149         {
 150           src = &sptr[shift * soffset];
 151           dest = rptr;
 152         }
 153       else
 154         {
 155           src = sptr;
 156           dest = &rptr[-shift * roffset];
 157         }
 158       for (n = 0; n < len; n++)
 159         {
 160           memcpy (dest, src, size);
 161           dest += roffset;
 162           src += soffset;
 163         }
 164       if (shift >= 0)
 165         {
 166           n = shift;
 167         }
 168       else
 169         {
 170           dest = rptr;
 171           n = -shift;
 172         }
 173
 174       if (pbound)
 175         while (n--)
 176           {
 177             memcpy (dest, pbound, size);
 178             dest += roffset;
 179           }
 180       else
 181         while (n--)
 182           {
 183             index_type i;
 184
 185             if (filler_len == 1)
 186               memset (dest, filler[0], size);
 187             else
 188               for (i = 0; i < size ; i += filler_len)
 189                 memcpy (&dest[i], filler, filler_len);
 190
 191             dest += roffset;
 192           }
 193
 194       /* Advance to the next section.  */
 195       rptr += rstride0;
 196       sptr += sstride0;
 197       count[0]++;
 198       n = 0;
 199       while (count[n] == extent[n])
 200         {
 201           /* When we get to the end of a dimension, reset it and increment
 202              the next dimension.  */
 203           count[n] = 0;
 204           /* We could precalculate these products, but this is a less
 205              frequently used path so probably not worth it.  */
 206           rptr -= rstride[n] * extent[n];
 207           sptr -= sstride[n] * extent[n];
 208           n++;
 209           if (n >= dim - 1)
 210             {
 211               /* Break out of the loop.  */
 212               rptr = NULL;
 213               break;
 214             }
 215           else
 216             {
 217               count[n]++;
 218               rptr += rstride[n];
 219               sptr += sstride[n];
 220             }
 221         }
 222     }
 223 }
 224
 225
 226 #define DEFINE_EOSHIFT(N)                                                     \
 227   extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *,         \
 228                             const GFC_INTEGER_##N *, const char *,            \
 229                             const GFC_INTEGER_##N *);                         \
 230   export_proto(eoshift0_##N);                                                 \
 231                                                                               \
 232   void                                                                        \
 233   eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 234                 const GFC_INTEGER_##N *pshift, const char *pbound,            \
 235                 const GFC_INTEGER_##N *pdim)                                  \
 236   {                                                                           \
 237     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 238               GFC_DESCRIPTOR_SIZE (array), "\0", 1);                          \
 239   }                                                                           \
 240                                                                               \
 241   extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 242                                    const gfc_array_char *,                    \
 243                                    const GFC_INTEGER_##N *, const char *,     \
 244                                    const GFC_INTEGER_##N *, GFC_INTEGER_4,    \
 245                                    GFC_INTEGER_4);                            \
 246   export_proto(eoshift0_##N##_char);                                          \
 247                                                                               \
 248   void                                                                        \
 249   eoshift0_##N##_char (gfc_array_char *ret,                                   \
 250                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 251                        const gfc_array_char *array,                           \
 252                        const GFC_INTEGER_##N *pshift,                         \
 253                        const char *pbound,                                    \
 254                        const GFC_INTEGER_##N *pdim,                           \
 255                        GFC_INTEGER_4 array_length,                            \
 256                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 257   {                                                                           \
 258     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 259               array_length, " ", 1);                                          \
 260   }                                                                           \
 261                                                                               \
 262   extern void eoshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,          \
 263                                     const gfc_array_char *,                   \
 264                                     const GFC_INTEGER_##N *, const char *,    \
 265                                     const GFC_INTEGER_##N *, GFC_INTEGER_4,   \
 266                                     GFC_INTEGER_4);                           \
 267   export_proto(eoshift0_##N##_char4);                                         \
 268                                                                               \
 269   void                                                                        \
 270   eoshift0_##N##_char4 (gfc_array_char *ret,                                  \
 271                         GFC_INTEGER_4 ret_length __attribute__((unused)),     \
 272                         const gfc_array_char *array,                          \
 273                         const GFC_INTEGER_##N *pshift,                        \
 274                         const char *pbound,                                   \
 275                         const GFC_INTEGER_##N *pdim,                          \
 276                         GFC_INTEGER_4 array_length,                           \
 277                         GFC_INTEGER_4 bound_length __attribute__((unused)))   \
 278   {                                                                           \
 279     static const gfc_char4_t space = (unsigned char) ' ';                     \
 280     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 281               array_length * sizeof (gfc_char4_t), (const char *) &space,     \
 282               sizeof (gfc_char4_t));                                          \
 283   }
 284
 285 DEFINE_EOSHIFT (1);
 286 DEFINE_EOSHIFT (2);
 287 DEFINE_EOSHIFT (4);
 288 DEFINE_EOSHIFT (8);
 289 #ifdef HAVE_GFC_INTEGER_16
 290 DEFINE_EOSHIFT (16);
 291 #endif