[thirdparty/gcc.git] / libgfortran / intrinsics / cshift0.c

/* Generic implementation of the CSHIFT intrinsic
   Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc.
   Contributed by Feng Wang <wf_cs@yahoo.com>

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
#include <string.h>

static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
	 ssize_t shift, int which, index_type size)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  char *rptr;

  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type soffset;
  const char *sptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dim;
  index_type len;
  index_type n;
  index_type arraysize;

  index_type type_size;

  if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
    runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");

  arraysize = size0 ((array_t *) array);

  if (ret->data == NULL)
    {
      int i;

      ret->offset = 0;
      ret->dtype = array->dtype;
      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
        {
	  index_type ub, str;

          ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;

          if (i == 0)
            str = 1;
          else
            str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
	      GFC_DESCRIPTOR_STRIDE(ret,i-1);

	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
        }

      if (arraysize > 0)
	ret->data = internal_malloc_size (size * arraysize);
      else
	ret->data = internal_malloc_size (1);
    }
  else if (unlikely (compile_options.bounds_check))
    {
      bounds_equal_extents ((array_t *) ret, (array_t *) array,
				 "return value", "CSHIFT");
    }

  if (arraysize == 0)
    return;

  type_size = GFC_DTYPE_TYPE_SIZE (array);

  switch(type_size)
    {
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_DERIVED_1:
      cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
		   which);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
      return;

    case GFC_DTYPE_REAL_8:
      cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
      return;

#ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
		   which);
      return;
#endif

#ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
		   which);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
      return;

    case GFC_DTYPE_COMPLEX_8:
      cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
      return;

#ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
		   which);
      return;
#endif

#ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
		   which);
      return;
#endif

    default:
      break;
    }

  switch (size)
    {
      /* Let's check the actual alignment of the data pointers.  If they
	 are suitably aligned, we can safely call the unpack functions.  */

    case sizeof (GFC_INTEGER_1):
      cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
		  which);
      break;

    case sizeof (GFC_INTEGER_2):
      if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data))
	break;
      else
	{
	  cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
		      which);
	  return;
	}

    case sizeof (GFC_INTEGER_4):
      if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data))
	break;
      else
	{
	  cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
		      which);
	  return;
	}

    case sizeof (GFC_INTEGER_8):
      if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data))
	{
	  /* Let's try to use the complex routines.  First, a sanity
	     check that the sizes match; this should be optimized to
	     a no-op.  */
	  if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
	    break;

	  if (GFC_UNALIGNED_C4(ret->data) || GFC_UNALIGNED_C4(array->data))
	    break;

	  cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
		      which);
	      return;
	}
      else
	{
	  cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
		      which);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case sizeof (GFC_INTEGER_16):
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data))
	{
	  /* Let's try to use the complex routines.  First, a sanity
	     check that the sizes match; this should be optimized to
	     a no-op.  */
	  if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
	    break;

	  if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data))
	    break;

	  cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
		      which);
	      return;
	}
      else
	{
	  cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
		       shift, which);
	  return;
	}
#else
    case sizeof (GFC_COMPLEX_8):

      if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data))
	break;
      else
	{
	  cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
		      which);
	  return;
	}
#endif

    default:
      break;
    }


  which = which - 1;
  sstride[0] = 0;
  rstride[0] = 0;

  extent[0] = 1;
  count[0] = 0;
  n = 0;
  /* Initialized for avoiding compiler warnings.  */
  roffset = size;
  soffset = size;
  len = 0;

  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
    {
      if (dim == which)
        {
          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
          if (roffset == 0)
            roffset = size;
          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
          if (soffset == 0)
            soffset = size;
          len = GFC_DESCRIPTOR_EXTENT(array,dim);
        }
      else
        {
          count[n] = 0;
          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
          n++;
        }
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (rstride[0] == 0)
    rstride[0] = size;

  dim = GFC_DESCRIPTOR_RANK (array);
  rstride0 = rstride[0];
  sstride0 = sstride[0];
  rptr = ret->data;
  sptr = array->data;

  shift = len == 0 ? 0 : shift % (ssize_t)len;
  if (shift < 0)
    shift += len;

  while (rptr)
    {
      /* Do the shift for this dimension.  */

      /* If elements are contiguous, perform the operation
	 in two block moves.  */
      if (soffset == size && roffset == size)
	{
	  size_t len1 = shift * size;
	  size_t len2 = (len - shift) * size;
	  memcpy (rptr, sptr + len1, len2);
	  memcpy (rptr + len2, sptr, len1);
	}
      else
	{
	  /* Otherwise, we'll have to perform the copy one element at
	     a time.  */
	  char *dest = rptr;
	  const char *src = &sptr[shift * soffset];

	  for (n = 0; n < len - shift; n++)
	    {
	      memcpy (dest, src, size);
	      dest += roffset;
	      src += soffset;
	    }
	  for (src = sptr, n = 0; n < shift; n++)
	    {
	      memcpy (dest, src, size);
	      dest += roffset;
	      src += soffset;
	    }
	}

      /* Advance to the next section.  */
      rptr += rstride0;
      sptr += sstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          rptr -= rstride[n] * extent[n];
          sptr -= sstride[n] * extent[n];
          n++;
          if (n >= dim - 1)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              sptr += sstride[n];
            }
        }
    }
}

#define DEFINE_CSHIFT(N)						      \
  extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,	      \
			   const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
  export_proto(cshift0_##N);						      \
									      \
  void									      \
  cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,	      \
	       const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
  {									      \
    cshift0 (ret, array, *pshift, pdim ? *pdim : 1,			      \
	     GFC_DESCRIPTOR_SIZE (array));				      \
  }									      \
									      \
  extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,	      \
				  const gfc_array_char *,		      \
				  const GFC_INTEGER_##N *,		      \
				  const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
  export_proto(cshift0_##N##_char);					      \
									      \
  void									      \
  cshift0_##N##_char (gfc_array_char *ret,				      \
		      GFC_INTEGER_4 ret_length __attribute__((unused)),	      \
		      const gfc_array_char *array,			      \
		      const GFC_INTEGER_##N *pshift,			      \
		      const GFC_INTEGER_##N *pdim,			      \
		      GFC_INTEGER_4 array_length)			      \
  {									      \
    cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);	      \
  }									      \
									      \
  extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,	      \
				   const gfc_array_char *,		      \
				   const GFC_INTEGER_##N *,		      \
				   const GFC_INTEGER_##N *, GFC_INTEGER_4);   \
  export_proto(cshift0_##N##_char4);					      \
									      \
  void									      \
  cshift0_##N##_char4 (gfc_array_char *ret,				      \
		       GFC_INTEGER_4 ret_length __attribute__((unused)),      \
		       const gfc_array_char *array,			      \
		       const GFC_INTEGER_##N *pshift,			      \
		       const GFC_INTEGER_##N *pdim,			      \
		       GFC_INTEGER_4 array_length)			      \
  {									      \
    cshift0 (ret, array, *pshift, pdim ? *pdim : 1,			      \
	     array_length * sizeof (gfc_char4_t));			      \
  }

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