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