libgfortran/intrinsics/cshift0.c

   1 /* Generic implementation of the CSHIFT intrinsic
   2    Copyright 2003, 2005, 2006 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       index_type arraysize = size0 ((array_t *)array);
 148
 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)
 160                                  * ret->dim[i-1].stride;
 161         }
 162
 163       if (arraysize > 0)
 164         ret->data = internal_malloc_size (size * arraysize);
 165       else
 166         {
 167           ret->data = internal_malloc_size (1);
 168           return;
 169         }
 170     }
 171
 172   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 173     {
 174       if (dim == which)
 175         {
 176           roffset = ret->dim[dim].stride * size;
 177           if (roffset == 0)
 178             roffset = size;
 179           soffset = array->dim[dim].stride * size;
 180           if (soffset == 0)
 181             soffset = size;
 182           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 183         }
 184       else
 185         {
 186           count[n] = 0;
 187           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 188           rstride[n] = ret->dim[dim].stride * size;
 189           sstride[n] = array->dim[dim].stride * size;
 190           n++;
 191         }
 192     }
 193   if (sstride[0] == 0)
 194     sstride[0] = size;
 195   if (rstride[0] == 0)
 196     rstride[0] = size;
 197
 198   dim = GFC_DESCRIPTOR_RANK (array);
 199   rstride0 = rstride[0];
 200   sstride0 = sstride[0];
 201   rptr = ret->data;
 202   sptr = array->data;
 203
 204   shift = shift % (ssize_t)len;
 205   if (shift < 0)
 206     shift += len;
 207
 208   while (rptr)
 209     {
 210       /* Do the shift for this dimension.  */
 211
 212       /* If elements are contiguous, perform the operation
 213          in two block moves.  */
 214       if (soffset == size && roffset == size)
 215         {
 216           size_t len1 = shift * size;
 217           size_t len2 = (len - shift) * size;
 218           memcpy (rptr, sptr + len1, len2);
 219           memcpy (rptr + len2, sptr, len1);
 220         }
 221       else
 222         {
 223           /* Otherwise, we'll have to perform the copy one element at
 224              a time.  We can speed this up a tad for common cases of
 225              fundamental types.  */
 226           switch (whichloop)
 227             {
 228             case 0:
 229               {
 230                 char *dest = rptr;
 231                 const char *src = &sptr[shift * soffset];
 232
 233                 for (n = 0; n < len - shift; n++)
 234                   {
 235                     memcpy (dest, src, size);
 236                     dest += roffset;
 237                     src += soffset;
 238                   }
 239                 for (src = sptr, n = 0; n < shift; n++)
 240                   {
 241                     memcpy (dest, src, size);
 242                     dest += roffset;
 243                     src += soffset;
 244                   }
 245               }
 246               break;
 247
 248             case 1:
 249               copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
 250               break;
 251
 252             case 2:
 253               copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
 254               break;
 255
 256             case 3:
 257               copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
 258               break;
 259
 260             case 4:
 261               copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
 262               break;
 263
 264             case 5:
 265               copy_loop_cfloat (rptr, sptr, roffset, soffset, len, shift);
 266               break;
 267
 268             case 6:
 269               copy_loop_cdouble (rptr, sptr, roffset, soffset, len, shift);
 270               break;
 271
 272             default:
 273               abort ();
 274             }
 275         }
 276
 277       /* Advance to the next section.  */
 278       rptr += rstride0;
 279       sptr += sstride0;
 280       count[0]++;
 281       n = 0;
 282       while (count[n] == extent[n])
 283         {
 284           /* When we get to the end of a dimension, reset it and increment
 285              the next dimension.  */
 286           count[n] = 0;
 287           /* We could precalculate these products, but this is a less
 288              frequently used path so probably not worth it.  */
 289           rptr -= rstride[n] * extent[n];
 290           sptr -= sstride[n] * extent[n];
 291           n++;
 292           if (n >= dim - 1)
 293             {
 294               /* Break out of the loop.  */
 295               rptr = NULL;
 296               break;
 297             }
 298           else
 299             {
 300               count[n]++;
 301               rptr += rstride[n];
 302               sptr += sstride[n];
 303             }
 304         }
 305     }
 306 }
 307
 308 #define DEFINE_CSHIFT(N)                                                      \
 309   extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,          \
 310                            const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
 311   export_proto(cshift0_##N);                                                  \
 312                                                                               \
 313   void                                                                        \
 314   cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,              \
 315                const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
 316   {                                                                           \
 317     cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
 318              GFC_DESCRIPTOR_SIZE (array));                                    \
 319   }                                                                           \
 320                                                                               \
 321   extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,            \
 322                                   const gfc_array_char *,                     \
 323                                   const GFC_INTEGER_##N *,                    \
 324                                   const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
 325   export_proto(cshift0_##N##_char);                                           \
 326                                                                               \
 327   void                                                                        \
 328   cshift0_##N##_char (gfc_array_char *ret,                                    \
 329                       GFC_INTEGER_4 ret_length __attribute__((unused)),       \
 330                       const gfc_array_char *array,                            \
 331                       const GFC_INTEGER_##N *pshift,                          \
 332                       const GFC_INTEGER_##N *pdim,                            \
 333                       GFC_INTEGER_4 array_length)                             \
 334   {                                                                           \
 335     cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);            \
 336   }
 337
 338 DEFINE_CSHIFT (1);
 339 DEFINE_CSHIFT (2);
 340 DEFINE_CSHIFT (4);
 341 DEFINE_CSHIFT (8);