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