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 static void
  37 cshift0 (gfc_array_char * ret, const gfc_array_char * array,
  38          ssize_t shift, int which, index_type size)
  39 {
  40   /* r.* indicates the return array.  */
  41   index_type rstride[GFC_MAX_DIMENSIONS];
  42   index_type rstride0;
  43   index_type roffset;
  44   char *rptr;
  45
  46   /* s.* indicates the source array.  */
  47   index_type sstride[GFC_MAX_DIMENSIONS];
  48   index_type sstride0;
  49   index_type soffset;
  50   const char *sptr;
  51
  52   index_type count[GFC_MAX_DIMENSIONS];
  53   index_type extent[GFC_MAX_DIMENSIONS];
  54   index_type dim;
  55   index_type len;
  56   index_type n;
  57   index_type arraysize;
  58
  59   index_type type_size;
  60
  61   if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
  62     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
  63
  64   arraysize = size0 ((array_t *) array);
  65
  66   if (ret->data == NULL)
  67     {
  68       int i;
  69
  70       ret->offset = 0;
  71       ret->dtype = array->dtype;
  72       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  73         {
  74           ret->dim[i].lbound = 0;
  75           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
  76
  77           if (i == 0)
  78             ret->dim[i].stride = 1;
  79           else
  80             ret->dim[i].stride = (ret->dim[i-1].ubound + 1)
  81                                  * ret->dim[i-1].stride;
  82         }
  83
  84       if (arraysize > 0)
  85         ret->data = internal_malloc_size (size * arraysize);
  86       else
  87         {
  88           ret->data = internal_malloc_size (1);
  89           return;
  90         }
  91     }
  92
  93   if (arraysize == 0)
  94     return;
  95   type_size = GFC_DTYPE_TYPE_SIZE (array);
  96
  97   switch(type_size)
  98     {
  99     case GFC_DTYPE_LOGICAL_1:
 100     case GFC_DTYPE_INTEGER_1:
 101     case GFC_DTYPE_DERIVED_1:
 102       cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
 103       return;
 104
 105     case GFC_DTYPE_LOGICAL_2:
 106     case GFC_DTYPE_INTEGER_2:
 107       cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
 108       return;
 109
 110     case GFC_DTYPE_LOGICAL_4:
 111     case GFC_DTYPE_INTEGER_4:
 112       cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
 113       return;
 114
 115     case GFC_DTYPE_LOGICAL_8:
 116     case GFC_DTYPE_INTEGER_8:
 117       cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
 118       return;
 119
 120 #ifdef HAVE_GFC_INTEGER_16
 121     case GFC_DTYPE_LOGICAL_16:
 122     case GFC_DTYPE_INTEGER_16:
 123       cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
 124                    which);
 125       return;
 126 #endif
 127
 128     case GFC_DTYPE_REAL_4:
 129       cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
 130       return;
 131
 132     case GFC_DTYPE_REAL_8:
 133       cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
 134       return;
 135
 136 #ifdef HAVE_GFC_REAL_10
 137     case GFC_DTYPE_REAL_10:
 138       cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
 139                    which);
 140       return;
 141 #endif
 142
 143 #ifdef HAVE_GFC_REAL_16
 144     case GFC_DTYPE_REAL_16:
 145       cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
 146                    which);
 147       return;
 148 #endif
 149
 150     case GFC_DTYPE_COMPLEX_4:
 151       cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
 152       return;
 153
 154     case GFC_DTYPE_COMPLEX_8:
 155       cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
 156       return;
 157
 158 #ifdef HAVE_GFC_COMPLEX_10
 159     case GFC_DTYPE_COMPLEX_10:
 160       cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
 161                    which);
 162       return;
 163 #endif
 164
 165 #ifdef HAVE_GFC_COMPLEX_16
 166     case GFC_DTYPE_COMPLEX_16:
 167       cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
 168                    which);
 169       return;
 170 #endif
 171
 172     default:
 173       break;
 174     }
 175
 176   switch (size)
 177     {
 178       /* Let's check the actual alignment of the data pointers.  If they
 179          are suitably aligned, we can safely call the unpack functions.  */
 180
 181     case sizeof (GFC_INTEGER_1):
 182       cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
 183                   which);
 184       break;
 185
 186     case sizeof (GFC_INTEGER_2):
 187       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data))
 188         break;
 189       else
 190         {
 191           cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
 192                       which);
 193           return;
 194         }
 195
 196     case sizeof (GFC_INTEGER_4):
 197       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data))
 198         break;
 199       else
 200         {
 201           cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
 202                       which);
 203           return;
 204         }
 205
 206     case sizeof (GFC_INTEGER_8):
 207       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data))
 208         {
 209           /* Let's try to use the complex routines.  First, a sanity
 210              check that the sizes match; this should be optimized to
 211              a no-op.  */
 212           if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
 213             break;
 214
 215           if (GFC_UNALIGNED_C4(ret->data) || GFC_UNALIGNED_C4(array->data))
 216             break;
 217
 218           cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
 219                       which);
 220               return;
 221         }
 222       else
 223         {
 224           cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
 225                       which);
 226           return;
 227         }
 228
 229 #ifdef HAVE_GFC_INTEGER_16
 230     case sizeof (GFC_INTEGER_16):
 231       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data))
 232         {
 233           /* Let's try to use the complex routines.  First, a sanity
 234              check that the sizes match; this should be optimized to
 235              a no-op.  */
 236           if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
 237             break;
 238
 239           if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data))
 240             break;
 241
 242           cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
 243                       which);
 244               return;
 245         }
 246       else
 247         {
 248           cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
 249                        shift, which);
 250           return;
 251         }
 252 #else
 253     case sizeof (GFC_COMPLEX_8):
 254
 255       if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data))
 256         break;
 257       else
 258         {
 259           cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
 260                       which);
 261           return;
 262         }
 263 #endif
 264
 265     default:
 266       break;
 267     }
 268
 269
 270   which = which - 1;
 271   sstride[0] = 0;
 272   rstride[0] = 0;
 273
 274   extent[0] = 1;
 275   count[0] = 0;
 276   n = 0;
 277   /* Initialized for avoiding compiler warnings.  */
 278   roffset = size;
 279   soffset = size;
 280   len = 0;
 281
 282   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 283     {
 284       if (dim == which)
 285         {
 286           roffset = ret->dim[dim].stride * size;
 287           if (roffset == 0)
 288             roffset = size;
 289           soffset = array->dim[dim].stride * size;
 290           if (soffset == 0)
 291             soffset = size;
 292           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 293         }
 294       else
 295         {
 296           count[n] = 0;
 297           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 298           rstride[n] = ret->dim[dim].stride * size;
 299           sstride[n] = array->dim[dim].stride * size;
 300           n++;
 301         }
 302     }
 303   if (sstride[0] == 0)
 304     sstride[0] = size;
 305   if (rstride[0] == 0)
 306     rstride[0] = size;
 307
 308   dim = GFC_DESCRIPTOR_RANK (array);
 309   rstride0 = rstride[0];
 310   sstride0 = sstride[0];
 311   rptr = ret->data;
 312   sptr = array->data;
 313
 314   shift = len == 0 ? 0 : shift % (ssize_t)len;
 315   if (shift < 0)
 316     shift += len;
 317
 318   while (rptr)
 319     {
 320       /* Do the shift for this dimension.  */
 321
 322       /* If elements are contiguous, perform the operation
 323          in two block moves.  */
 324       if (soffset == size && roffset == size)
 325         {
 326           size_t len1 = shift * size;
 327           size_t len2 = (len - shift) * size;
 328           memcpy (rptr, sptr + len1, len2);
 329           memcpy (rptr + len2, sptr, len1);
 330         }
 331       else
 332         {
 333           /* Otherwise, we'll have to perform the copy one element at
 334              a time.  */
 335           char *dest = rptr;
 336           const char *src = &sptr[shift * soffset];
 337
 338           for (n = 0; n < len - shift; n++)
 339             {
 340               memcpy (dest, src, size);
 341               dest += roffset;
 342               src += soffset;
 343             }
 344           for (src = sptr, n = 0; n < shift; n++)
 345             {
 346               memcpy (dest, src, size);
 347               dest += roffset;
 348               src += soffset;
 349             }
 350         }
 351
 352       /* Advance to the next section.  */
 353       rptr += rstride0;
 354       sptr += sstride0;
 355       count[0]++;
 356       n = 0;
 357       while (count[n] == extent[n])
 358         {
 359           /* When we get to the end of a dimension, reset it and increment
 360              the next dimension.  */
 361           count[n] = 0;
 362           /* We could precalculate these products, but this is a less
 363              frequently used path so probably not worth it.  */
 364           rptr -= rstride[n] * extent[n];
 365           sptr -= sstride[n] * extent[n];
 366           n++;
 367           if (n >= dim - 1)
 368             {
 369               /* Break out of the loop.  */
 370               rptr = NULL;
 371               break;
 372             }
 373           else
 374             {
 375               count[n]++;
 376               rptr += rstride[n];
 377               sptr += sstride[n];
 378             }
 379         }
 380     }
 381 }
 382
 383 #define DEFINE_CSHIFT(N)                                                      \
 384   extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,          \
 385                            const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
 386   export_proto(cshift0_##N);                                                  \
 387                                                                               \
 388   void                                                                        \
 389   cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,              \
 390                const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
 391   {                                                                           \
 392     cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
 393              GFC_DESCRIPTOR_SIZE (array));                                    \
 394   }                                                                           \
 395                                                                               \
 396   extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,            \
 397                                   const gfc_array_char *,                     \
 398                                   const GFC_INTEGER_##N *,                    \
 399                                   const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
 400   export_proto(cshift0_##N##_char);                                           \
 401                                                                               \
 402   void                                                                        \
 403   cshift0_##N##_char (gfc_array_char *ret,                                    \
 404                       GFC_INTEGER_4 ret_length __attribute__((unused)),       \
 405                       const gfc_array_char *array,                            \
 406                       const GFC_INTEGER_##N *pshift,                          \
 407                       const GFC_INTEGER_##N *pdim,                            \
 408                       GFC_INTEGER_4 array_length)                             \
 409   {                                                                           \
 410     cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);            \
 411   }                                                                           \
 412                                                                               \
 413   extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,           \
 414                                    const gfc_array_char *,                    \
 415                                    const GFC_INTEGER_##N *,                   \
 416                                    const GFC_INTEGER_##N *, GFC_INTEGER_4);   \
 417   export_proto(cshift0_##N##_char4);                                          \
 418                                                                               \
 419   void                                                                        \
 420   cshift0_##N##_char4 (gfc_array_char *ret,                                   \
 421                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 422                        const gfc_array_char *array,                           \
 423                        const GFC_INTEGER_##N *pshift,                         \
 424                        const GFC_INTEGER_##N *pdim,                           \
 425                        GFC_INTEGER_4 array_length)                            \
 426   {                                                                           \
 427     cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
 428              array_length * sizeof (gfc_char4_t));                            \
 429   }
 430
 431 DEFINE_CSHIFT (1);
 432 DEFINE_CSHIFT (2);
 433 DEFINE_CSHIFT (4);
 434 DEFINE_CSHIFT (8);
 435 #ifdef HAVE_GFC_INTEGER_16
 436 DEFINE_CSHIFT (16);
 437 #endif