libgfortran/intrinsics/cshift0.c

   1 /* Generic implementation of the CSHIFT intrinsic
   2    Copyright 2003, 2005, 2006, 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 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
  37 /* "Templatized" helper function for the inner shift loop.  */
  38
  39 #define DEF_COPY_LOOP(NAME, TYPE)                                       \
  40 static inline void                                                      \
  41 copy_loop_##NAME (void *xdest, const void *xsrc,                        \
  42                   size_t roff, size_t soff,                             \
  43                   index_type len, index_type shift)                     \
  44 {                                                                       \
  45   TYPE *dest = xdest;                                                   \
  46   const TYPE *src;                                                      \
  47   index_type i;                                                         \
  48                                                                         \
  49   roff /= sizeof (TYPE);                                                \
  50   soff /= sizeof (TYPE);                                                \
  51                                                                         \
  52   src = xsrc;                                                           \
  53   src += shift * soff;                                                  \
  54   for (i = 0; i < len - shift; ++i)                                     \
  55     {                                                                   \
  56       *dest = *src;                                                     \
  57       dest += roff;                                                     \
  58       src += soff;                                                      \
  59     }                                                                   \
  60                                                                         \
  61   src = xsrc;                                                           \
  62   for (i = 0; i < shift; ++i)                                           \
  63     {                                                                   \
  64       *dest = *src;                                                     \
  65       dest += roff;                                                     \
  66       src += soff;                                                      \
  67     }                                                                   \
  68 }
  69
  70 DEF_COPY_LOOP(int, int)
  71 DEF_COPY_LOOP(long, long)
  72 DEF_COPY_LOOP(double, double)
  73 DEF_COPY_LOOP(ldouble, long double)
  74 DEF_COPY_LOOP(cfloat, _Complex float)
  75 DEF_COPY_LOOP(cdouble, _Complex double)
  76
  77
  78 static void
  79 cshift0 (gfc_array_char * ret, const gfc_array_char * array,
  80          ssize_t shift, int which, index_type size)
  81 {
  82   /* r.* indicates the return array.  */
  83   index_type rstride[GFC_MAX_DIMENSIONS];
  84   index_type rstride0;
  85   index_type roffset;
  86   char *rptr;
  87
  88   /* s.* indicates the source array.  */
  89   index_type sstride[GFC_MAX_DIMENSIONS];
  90   index_type sstride0;
  91   index_type soffset;
  92   const char *sptr;
  93
  94   index_type count[GFC_MAX_DIMENSIONS];
  95   index_type extent[GFC_MAX_DIMENSIONS];
  96   index_type dim;
  97   index_type len;
  98   index_type n;
  99   int whichloop;
 100
 101   if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
 102     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
 103
 104   which = which - 1;
 105   sstride[0] = 0;
 106   rstride[0] = 0;
 107
 108   extent[0] = 1;
 109   count[0] = 0;
 110   n = 0;
 111
 112   /* The values assigned here must match the cases in the inner loop.  */
 113   whichloop = 0;
 114   switch (GFC_DESCRIPTOR_TYPE (array))
 115     {
 116     case GFC_DTYPE_LOGICAL:
 117     case GFC_DTYPE_INTEGER:
 118     case GFC_DTYPE_REAL:
 119       if (size == sizeof (int))
 120         whichloop = 1;
 121       else if (size == sizeof (long))
 122         whichloop = 2;
 123       else if (size == sizeof (double))
 124         whichloop = 3;
 125       else if (size == sizeof (long double))
 126         whichloop = 4;
 127       break;
 128
 129     case GFC_DTYPE_COMPLEX:
 130       if (size == sizeof (_Complex float))
 131         whichloop = 5;
 132       else if (size == sizeof (_Complex double))
 133         whichloop = 6;
 134       break;
 135
 136     default:
 137       break;
 138     }
 139
 140   /* Initialized for avoiding compiler warnings.  */
 141   roffset = size;
 142   soffset = size;
 143   len = 0;
 144
 145   if (ret->data == NULL)
 146     {
 147       int i;
 148       index_type arraysize = size0 ((array_t *)array);
 149
 150       ret->offset = 0;
 151       ret->dtype = array->dtype;
 152       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
 153         {
 154           ret->dim[i].lbound = 0;
 155           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
 156
 157           if (i == 0)
 158             ret->dim[i].stride = 1;
 159           else
 160             ret->dim[i].stride = (ret->dim[i-1].ubound + 1)
 161                                  * ret->dim[i-1].stride;
 162         }
 163
 164       if (arraysize > 0)
 165         ret->data = internal_malloc_size (size * arraysize);
 166       else
 167         {
 168           ret->data = internal_malloc_size (1);
 169           return;
 170         }
 171     }
 172
 173   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 174     {
 175       if (dim == which)
 176         {
 177           roffset = ret->dim[dim].stride * size;
 178           if (roffset == 0)
 179             roffset = size;
 180           soffset = array->dim[dim].stride * size;
 181           if (soffset == 0)
 182             soffset = size;
 183           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 184         }
 185       else
 186         {
 187           count[n] = 0;
 188           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 189           rstride[n] = ret->dim[dim].stride * size;
 190           sstride[n] = array->dim[dim].stride * size;
 191           n++;
 192         }
 193     }
 194   if (sstride[0] == 0)
 195     sstride[0] = size;
 196   if (rstride[0] == 0)
 197     rstride[0] = size;
 198
 199   dim = GFC_DESCRIPTOR_RANK (array);
 200   rstride0 = rstride[0];
 201   sstride0 = sstride[0];
 202   rptr = ret->data;
 203   sptr = array->data;
 204
 205   shift = shift % (ssize_t)len;
 206   if (shift < 0)
 207     shift += len;
 208
 209   while (rptr)
 210     {
 211       /* Do the shift for this dimension.  */
 212
 213       /* If elements are contiguous, perform the operation
 214          in two block moves.  */
 215       if (soffset == size && roffset == size)
 216         {
 217           size_t len1 = shift * size;
 218           size_t len2 = (len - shift) * size;
 219           memcpy (rptr, sptr + len1, len2);
 220           memcpy (rptr + len2, sptr, len1);
 221         }
 222       else
 223         {
 224           /* Otherwise, we'll have to perform the copy one element at
 225              a time.  We can speed this up a tad for common cases of
 226              fundamental types.  */
 227           switch (whichloop)
 228             {
 229             case 0:
 230               {
 231                 char *dest = rptr;
 232                 const char *src = &sptr[shift * soffset];
 233
 234                 for (n = 0; n < len - shift; n++)
 235                   {
 236                     memcpy (dest, src, size);
 237                     dest += roffset;
 238                     src += soffset;
 239                   }
 240                 for (src = sptr, n = 0; n < shift; n++)
 241                   {
 242                     memcpy (dest, src, size);
 243                     dest += roffset;
 244                     src += soffset;
 245                   }
 246               }
 247               break;
 248
 249             case 1:
 250               copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
 251               break;
 252
 253             case 2:
 254               copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
 255               break;
 256
 257             case 3:
 258               copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
 259               break;
 260
 261             case 4:
 262               copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
 263               break;
 264
 265             case 5:
 266               copy_loop_cfloat (rptr, sptr, roffset, soffset, len, shift);
 267               break;
 268
 269             case 6:
 270               copy_loop_cdouble (rptr, sptr, roffset, soffset, len, shift);
 271               break;
 272
 273             default:
 274               abort ();
 275             }
 276         }
 277
 278       /* Advance to the next section.  */
 279       rptr += rstride0;
 280       sptr += sstride0;
 281       count[0]++;
 282       n = 0;
 283       while (count[n] == extent[n])
 284         {
 285           /* When we get to the end of a dimension, reset it and increment
 286              the next dimension.  */
 287           count[n] = 0;
 288           /* We could precalculate these products, but this is a less
 289              frequently used path so probably not worth it.  */
 290           rptr -= rstride[n] * extent[n];
 291           sptr -= sstride[n] * extent[n];
 292           n++;
 293           if (n >= dim - 1)
 294             {
 295               /* Break out of the loop.  */
 296               rptr = NULL;
 297               break;
 298             }
 299           else
 300             {
 301               count[n]++;
 302               rptr += rstride[n];
 303               sptr += sstride[n];
 304             }
 305         }
 306     }
 307 }
 308
 309 #define DEFINE_CSHIFT(N)                                                      \
 310   extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,          \
 311                            const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
 312   export_proto(cshift0_##N);                                                  \
 313                                                                               \
 314   void                                                                        \
 315   cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,              \
 316                const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
 317   {                                                                           \
 318     cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
 319              GFC_DESCRIPTOR_SIZE (array));                                    \
 320   }                                                                           \
 321                                                                               \
 322   extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,            \
 323                                   const gfc_array_char *,                     \
 324                                   const GFC_INTEGER_##N *,                    \
 325                                   const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
 326   export_proto(cshift0_##N##_char);                                           \
 327                                                                               \
 328   void                                                                        \
 329   cshift0_##N##_char (gfc_array_char *ret,                                    \
 330                       GFC_INTEGER_4 ret_length __attribute__((unused)),       \
 331                       const gfc_array_char *array,                            \
 332                       const GFC_INTEGER_##N *pshift,                          \
 333                       const GFC_INTEGER_##N *pdim,                            \
 334                       GFC_INTEGER_4 array_length)                             \
 335   {                                                                           \
 336     cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);            \
 337   }
 338
 339 DEFINE_CSHIFT (1);
 340 DEFINE_CSHIFT (2);
 341 DEFINE_CSHIFT (4);
 342 DEFINE_CSHIFT (8);