libgfortran/intrinsics/cshift0.c

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