libgfortran/intrinsics/cshift0.c

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