[thirdparty/gcc.git] / libgfortran / m4 / cshift1.m4

`/* Implementation of the CSHIFT intrinsic
   Copyright (C) 2003-2019 Free Software Foundation, Inc.
   Contributed by Feng Wang <wf_cs@yahoo.com>

This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version.

Ligbfortran 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.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

#include "libgfortran.h"
#include <string.h>'

include(iparm.m4)dnl

`#if defined (HAVE_'atype_name`)

static void
cshift1 (gfc_array_char * const restrict ret, 
	const gfc_array_char * const restrict array,
	const 'atype` * const restrict h, 
	const 'atype_name` * const restrict pwhich)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  char *rptr;
  char *dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type soffset;
  const char *sptr;
  const char *src;
  /* h.* indicates the shift array.  */
  index_type hstride[GFC_MAX_DIMENSIONS];
  index_type hstride0;
  const 'atype_name` *hptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dim;
  index_type len;
  index_type n;
  int which;
  'atype_name` sh;
  index_type arraysize;
  index_type size;
  index_type type_size;
  
  if (pwhich)
    which = *pwhich - 1;
  else
    which = 0;
 
  if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
    runtime_error ("Argument ''`DIM''` is out of range in call to ''`CSHIFT''`");

  size = GFC_DESCRIPTOR_SIZE(array);

  arraysize = size0 ((array_t *)array);

  if (ret->base_addr == NULL)
    {
      ret->base_addr = xmallocarray (arraysize, size);
      ret->offset = 0;
      GFC_DTYPE_COPY(ret,array);
      for (index_type 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);
        }
    }
  else if (unlikely (compile_options.bounds_check))
    {
      bounds_equal_extents ((array_t *) ret, (array_t *) array,
				 "return value", "CSHIFT");
    }

  if (unlikely (compile_options.bounds_check))
    {
      bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
      			      "SHIFT argument", "CSHIFT");
    }

  if (arraysize == 0)
    return;

  /* See if we should dispatch to a helper function.  */

  type_size = GFC_DTYPE_TYPE_SIZE (array);

  switch (type_size)
  {
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
      cshift1_'atype_kind`_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array,
      			h, pwhich);
      return;
 
    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      cshift1_'atype_kind`_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array,
      			h, pwhich);
      return;
 
    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      cshift1_'atype_kind`_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array,
      			h, pwhich);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      cshift1_'atype_kind`_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array,
      			h, pwhich);
      return;

#if defined (HAVE_INTEGER_16)
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      cshift1_'atype_kind`_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array,
      			h, pwhich);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      cshift1_'atype_kind`_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array,
      			h, pwhich);
      return;

    case GFC_DTYPE_REAL_8:
      cshift1_'atype_kind`_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array,
      			h, pwhich);
      return;

#if defined (HAVE_REAL_10)
    case GFC_DTYPE_REAL_10:
      cshift1_'atype_kind`_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array,
      			h, pwhich);
      return;
#endif

#if defined (HAVE_REAL_16)
    case GFC_DTYPE_REAL_16:
      cshift1_'atype_kind`_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array,
      			h, pwhich);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      cshift1_'atype_kind`_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array,
      			h, pwhich);
      return;

    case GFC_DTYPE_COMPLEX_8:
      cshift1_'atype_kind`_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array,
      			h, pwhich);
      return;

#if defined (HAVE_COMPLEX_10)
    case GFC_DTYPE_COMPLEX_10:
      cshift1_'atype_kind`_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array,
      			h, pwhich);
      return;
#endif

#if defined (HAVE_COMPLEX_16)
    case GFC_DTYPE_COMPLEX_16:
      cshift1_'atype_kind`_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array,
      			h, pwhich);
      return;
#endif

    default:
      break;
    
  }
  
  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);

          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
          n++;
        }
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (rstride[0] == 0)
    rstride[0] = size;
  if (hstride[0] == 0)
    hstride[0] = 1;

  dim = GFC_DESCRIPTOR_RANK (array);
  rstride0 = rstride[0];
  sstride0 = sstride[0];
  hstride0 = hstride[0];
  rptr = ret->base_addr;
  sptr = array->base_addr;
  hptr = h->base_addr;

  while (rptr)
    {
      /* Do the shift for this dimension.  */
      sh = *hptr;
      /* Normal case should be -len < sh < len; try to
         avoid the expensive remainder operation if possible.  */
      if (sh < 0)
        sh += len;
      if (unlikely (sh >= len || sh < 0))
        {
	  sh = sh % len;
	  if (sh < 0)
	    sh += len;
	}

      src = &sptr[sh * soffset];
      dest = rptr;
      if (soffset == size && roffset == size)
      {
        size_t len1 = sh * size;
	size_t len2 = (len - sh) * size;
	memcpy (rptr, sptr + len1, len2);
	memcpy (rptr + len2, sptr, len1);
      }
      else
        {
	  for (n = 0; n < len - sh; n++)
            {
	      memcpy (dest, src, size);
	      dest += roffset;
	      src += soffset;
	    }
	    for (src = sptr, n = 0; n < sh; n++)
	      {
		memcpy (dest, src, size);
		dest += roffset;
		src += soffset;
	      }
	  }

      /* Advance to the next section.  */
      rptr += rstride0;
      sptr += sstride0;
      hptr += hstride0;
      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];
	  hptr -= hstride[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];
	      hptr += hstride[n];
            }
        }
    }
}

void cshift1_'atype_kind` (gfc_array_char * const restrict, 
	const gfc_array_char * const restrict,
	const 'atype` * const restrict, 
	const 'atype_name` * const restrict);
export_proto(cshift1_'atype_kind`);

void
cshift1_'atype_kind` (gfc_array_char * const restrict ret,
	const gfc_array_char * const restrict array,
	const 'atype` * const restrict h, 
	const 'atype_name` * const restrict pwhich)
{
  cshift1 (ret, array, h, pwhich);
}


void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, 
	GFC_INTEGER_4,
	const gfc_array_char * const restrict array,
	const 'atype` * const restrict h, 
	const 'atype_name` * const restrict pwhich,
	GFC_INTEGER_4);
export_proto(cshift1_'atype_kind`_char);

void
cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
	GFC_INTEGER_4 ret_length __attribute__((unused)),
	const gfc_array_char * const restrict array,
	const 'atype` * const restrict h, 
	const 'atype_name` * const restrict pwhich,
	GFC_INTEGER_4 array_length __attribute__((unused)))
{
  cshift1 (ret, array, h, pwhich);
}


void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, 
	GFC_INTEGER_4,
	const gfc_array_char * const restrict array,
	const 'atype` * const restrict h, 
	const 'atype_name` * const restrict pwhich,
	GFC_INTEGER_4);
export_proto(cshift1_'atype_kind`_char4);

void
cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
	GFC_INTEGER_4 ret_length __attribute__((unused)),
	const gfc_array_char * const restrict array,
	const 'atype` * const restrict h, 
	const 'atype_name` * const restrict pwhich,
	GFC_INTEGER_4 array_length __attribute__((unused)))
{
  cshift1 (ret, array, h, pwhich);
}

#endif'
Commit	Line	Data
4ee9c684	1	`/* Implementation of the CSHIFT intrinsic
fbd26352	2	Copyright (C) 2003-2019 Free Software Foundation, Inc.
4ee9c684	3	Contributed by Feng Wang <wf_cs@yahoo.com>
4ee9c684	4
553877d9	5	This file is part of the GNU Fortran runtime library (libgfortran).
4ee9c684	6
4ee9c684	7	Libgfortran is free software; you can redistribute it and/or
b417ea8c	8	modify it under the terms of the GNU General Public
4ee9c684	9	License as published by the Free Software Foundation; either
6bc9506f	10	version 3 of the License, or (at your option) any later version.
b417ea8c	11
b417ea8c	12	Ligbfortran is distributed in the hope that it will be useful,
4ee9c684	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
4ee9c684	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
b417ea8c	15	GNU General Public License for more details.
4ee9c684	16
6bc9506f	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/>. */
4ee9c684	25
41f2d5e8	26	#include "libgfortran.h"
41f2d5e8	27	#include <string.h>'
41f2d5e8	28
cdafa1f6	29	include(iparm.m4)dnl
4ee9c684	30
0a6b5f6b	31	`#if defined (HAVE_'atype_name`)
920e54ef	32
1a9a4a12	33	static void
b4cafd67	34	cshift1 (gfc_array_char * const restrict ret,
b4cafd67	35	const gfc_array_char * const restrict array,
0a6b5f6b	36	const 'atype` * const restrict h,
827aef63	37	const 'atype_name` * const restrict pwhich)
4ee9c684	38	{
4ee9c684	39	/* r.* indicates the return array. */
9130521e	40	index_type rstride[GFC_MAX_DIMENSIONS];
4ee9c684	41	index_type rstride0;
	42	index_type roffset;
	43	char *rptr;
	44	char *dest;
	45	/* s.* indicates the source array. */
9130521e	46	index_type sstride[GFC_MAX_DIMENSIONS];
4ee9c684	47	index_type sstride0;
	48	index_type soffset;
	49	const char *sptr;
	50	const char *src;
7b6cb5bd	51	/* h.* indicates the shift array. */
9130521e	52	index_type hstride[GFC_MAX_DIMENSIONS];
4ee9c684	53	index_type hstride0;
0a6b5f6b	54	const 'atype_name` *hptr;
4ee9c684	55
9130521e	56	index_type count[GFC_MAX_DIMENSIONS];
9130521e	57	index_type extent[GFC_MAX_DIMENSIONS];
4ee9c684	58	index_type dim;
4ee9c684	59	index_type len;
	60	index_type n;
	61	int which;
0a6b5f6b	62	'atype_name` sh;
74a175c1	63	index_type arraysize;
827aef63	64	index_type size;
3d3c32f2	65	index_type type_size;
3d3c32f2	66
4ee9c684	67	if (pwhich)
	68	which = *pwhich - 1;
	69	else
	70	which = 0;
3d3c32f2	71
4ee9c684	72	if (which < 0 \|\| (which + 1) > GFC_DESCRIPTOR_RANK (array))
0a6b5f6b	73	runtime_error ("Argument ''`DIM''` is out of range in call to ''`CSHIFT''`");
4ee9c684	74
827aef63	75	size = GFC_DESCRIPTOR_SIZE(array);
827aef63	76
74a175c1	77	arraysize = size0 ((array_t *)array);
74a175c1	78
553877d9	79	if (ret->base_addr == NULL)
71a8a4b3	80	{
af1e9051	81	ret->base_addr = xmallocarray (arraysize, size);
93830de1	82	ret->offset = 0;
da8dff89	83	GFC_DTYPE_COPY(ret,array);
df52c9a4	84	for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
71a8a4b3	85	{
827aef63	86	index_type ub, str;
	87
	88	ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
71a8a4b3	89
71a8a4b3	90	if (i == 0)
827aef63	91	str = 1;
71a8a4b3	92	else
827aef63	93	str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
	94	GFC_DESCRIPTOR_STRIDE(ret,i-1);
	95
	96	GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
71a8a4b3	97	}
71a8a4b3	98	}
5d04d450	99	else if (unlikely (compile_options.bounds_check))
	100	{
	101	bounds_equal_extents ((array_t ) ret, (array_t ) array,
	102	"return value", "CSHIFT");
	103	}
	104
	105	if (unlikely (compile_options.bounds_check))
	106	{
	107	bounds_reduced_extents ((array_t ) h, (array_t ) array, which,
	108	"SHIFT argument", "CSHIFT");
	109	}
71a8a4b3	110
74a175c1	111	if (arraysize == 0)
	112	return;
	113
3d3c32f2	114	/* See if we should dispatch to a helper function. */
	115
	116	type_size = GFC_DTYPE_TYPE_SIZE (array);
	117
	118	switch (type_size)
	119	{
	120	case GFC_DTYPE_LOGICAL_1:
	121	case GFC_DTYPE_INTEGER_1:
3d3c32f2	122	cshift1_'atype_kind`_i1 ((gfc_array_i1 )ret, (gfc_array_i1 ) array,
	123	h, pwhich);
	124	return;
	125
	126	case GFC_DTYPE_LOGICAL_2:
	127	case GFC_DTYPE_INTEGER_2:
	128	cshift1_'atype_kind`_i2 ((gfc_array_i2 )ret, (gfc_array_i2 ) array,
	129	h, pwhich);
	130	return;
	131
	132	case GFC_DTYPE_LOGICAL_4:
	133	case GFC_DTYPE_INTEGER_4:
	134	cshift1_'atype_kind`_i4 ((gfc_array_i4 )ret, (gfc_array_i4 ) array,
	135	h, pwhich);
	136	return;
	137
	138	case GFC_DTYPE_LOGICAL_8:
	139	case GFC_DTYPE_INTEGER_8:
	140	cshift1_'atype_kind`_i8 ((gfc_array_i8 )ret, (gfc_array_i8 ) array,
	141	h, pwhich);
	142	return;
	143
	144	#if defined (HAVE_INTEGER_16)
	145	case GFC_DTYPE_LOGICAL_16:
	146	case GFC_DTYPE_INTEGER_16:
	147	cshift1_'atype_kind`_i16 ((gfc_array_i16 )ret, (gfc_array_i16 ) array,
	148	h, pwhich);
	149	return;
	150	#endif
	151
	152	case GFC_DTYPE_REAL_4:
	153	cshift1_'atype_kind`_r4 ((gfc_array_r4 )ret, (gfc_array_r4 ) array,
	154	h, pwhich);
	155	return;
	156
	157	case GFC_DTYPE_REAL_8:
	158	cshift1_'atype_kind`_r8 ((gfc_array_r8 )ret, (gfc_array_r8 ) array,
	159	h, pwhich);
	160	return;
	161
	162	#if defined (HAVE_REAL_10)
	163	case GFC_DTYPE_REAL_10:
	164	cshift1_'atype_kind`_r10 ((gfc_array_r10 )ret, (gfc_array_r10 ) array,
	165	h, pwhich);
	166	return;
	167	#endif
	168
	169	#if defined (HAVE_REAL_16)
	170	case GFC_DTYPE_REAL_16:
	171	cshift1_'atype_kind`_r16 ((gfc_array_r16 )ret, (gfc_array_r16 ) array,
	172	h, pwhich);
	173	return;
	174	#endif
	175
	176	case GFC_DTYPE_COMPLEX_4:
	177	cshift1_'atype_kind`_c4 ((gfc_array_c4 )ret, (gfc_array_c4 ) array,
	178	h, pwhich);
	179	return;
	180
	181	case GFC_DTYPE_COMPLEX_8:
	182	cshift1_'atype_kind`_c8 ((gfc_array_c8 )ret, (gfc_array_c8 ) array,
	183	h, pwhich);
	184	return;
	185
186	#if defined (HAVE_COMPLEX_10)
187	case GFC_DTYPE_COMPLEX_10:
188	cshift1_'atype_kind`_c10 ((gfc_array_c10 )ret, (gfc_array_c10 ) array,
189	h, pwhich);
190	return;
191	#endif
192
193	#if defined (HAVE_COMPLEX_16)
194	case GFC_DTYPE_COMPLEX_16:
195	cshift1_'atype_kind`_c16 ((gfc_array_c16 )ret, (gfc_array_c16 ) array,
196	h, pwhich);
197	return;
198	#endif
199
200	default:
201	break;
202
203	}
204
4ee9c684	205	extent[0] = 1;
4ee9c684	206	count[0] = 0;
4ee9c684	207	n = 0;
4ee9c684	208
7b6cb5bd	209	/* Initialized for avoiding compiler warnings. */
4ee9c684	210	roffset = size;
	211	soffset = size;
	212	len = 0;
	213
	214	for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
	215	{
	216	if (dim == which)
	217	{
827aef63	218	roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
4ee9c684	219	if (roffset == 0)
4ee9c684	220	roffset = size;
827aef63	221	soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
4ee9c684	222	if (soffset == 0)
4ee9c684	223	soffset = size;
827aef63	224	len = GFC_DESCRIPTOR_EXTENT(array,dim);
4ee9c684	225	}
	226	else
	227	{
	228	count[n] = 0;
827aef63	229	extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
	230	rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
	231	sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
4ee9c684	232
827aef63	233	hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
4ee9c684	234	n++;
	235	}
	236	}
	237	if (sstride[0] == 0)
	238	sstride[0] = size;
	239	if (rstride[0] == 0)
	240	rstride[0] = size;
	241	if (hstride[0] == 0)
	242	hstride[0] = 1;
	243
	244	dim = GFC_DESCRIPTOR_RANK (array);
	245	rstride0 = rstride[0];
	246	sstride0 = sstride[0];
	247	hstride0 = hstride[0];
553877d9	248	rptr = ret->base_addr;
	249	sptr = array->base_addr;
	250	hptr = h->base_addr;
4ee9c684	251
	252	while (rptr)
	253	{
7b6cb5bd	254	/* Do the shift for this dimension. */
4ee9c684	255	sh = *hptr;
3d3c32f2	256	/* Normal case should be -len < sh < len; try to
3d3c32f2	257	avoid the expensive remainder operation if possible. */
4ee9c684	258	if (sh < 0)
4ee9c684	259	sh += len;
3d3c32f2	260	if (unlikely (sh >= len \|\| sh < 0))
	261	{
	262	sh = sh % len;
	263	if (sh < 0)
	264	sh += len;
	265	}
4ee9c684	266
	267	src = &sptr[sh * soffset];
	268	dest = rptr;
3d3c32f2	269	if (soffset == size && roffset == size)
	270	{
	271	size_t len1 = sh * size;
	272	size_t len2 = (len - sh) * size;
	273	memcpy (rptr, sptr + len1, len2);
	274	memcpy (rptr + len2, sptr, len1);
	275	}
	276	else
4ee9c684	277	{
3d3c32f2	278	for (n = 0; n < len - sh; n++)
	279	{
	280	memcpy (dest, src, size);
	281	dest += roffset;
	282	src += soffset;
	283	}
	284	for (src = sptr, n = 0; n < sh; n++)
	285	{
	286	memcpy (dest, src, size);
	287	dest += roffset;
	288	src += soffset;
	289	}
	290	}
4ee9c684	291
	292	/* Advance to the next section. */
	293	rptr += rstride0;
	294	sptr += sstride0;
	295	hptr += hstride0;
	296	count[0]++;
	297	n = 0;
	298	while (count[n] == extent[n])
	299	{
	300	/* When we get to the end of a dimension, reset it and increment
	301	the next dimension. */
	302	count[n] = 0;
	303	/* We could precalculate these products, but this is a less
a2ffc2c4	304	frequently used path so probably not worth it. */
4ee9c684	305	rptr -= rstride[n] * extent[n];
	306	sptr -= sstride[n] * extent[n];
	307	hptr -= hstride[n] * extent[n];
	308	n++;
	309	if (n >= dim - 1)
	310	{
	311	/* Break out of the loop. */
	312	rptr = NULL;
	313	break;
	314	}
	315	else
	316	{
	317	count[n]++;
	318	rptr += rstride[n];
	319	sptr += sstride[n];
	320	hptr += hstride[n];
	321	}
	322	}
	323	}
	324	}
1a9a4a12	325
0a6b5f6b	326	void cshift1_'atype_kind` (gfc_array_char * const restrict,
b4cafd67	327	const gfc_array_char * const restrict,
0a6b5f6b	328	const 'atype` * const restrict,
	329	const 'atype_name` * const restrict);
	330	export_proto(cshift1_'atype_kind`);
1a9a4a12	331
1a9a4a12	332	void
0a6b5f6b	333	cshift1_'atype_kind` (gfc_array_char * const restrict ret,
b4cafd67	334	const gfc_array_char * const restrict array,
0a6b5f6b	335	const 'atype` * const restrict h,
0a6b5f6b	336	const 'atype_name` * const restrict pwhich)
1a9a4a12	337	{
827aef63	338	cshift1 (ret, array, h, pwhich);
1a9a4a12	339	}
1a9a4a12	340
329f13ad	341
0a6b5f6b	342	void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
b4cafd67	343	GFC_INTEGER_4,
b4cafd67	344	const gfc_array_char * const restrict array,
0a6b5f6b	345	const 'atype` * const restrict h,
0a6b5f6b	346	const 'atype_name` * const restrict pwhich,
b4cafd67	347	GFC_INTEGER_4);
0a6b5f6b	348	export_proto(cshift1_'atype_kind`_char);
1a9a4a12	349
1a9a4a12	350	void
0a6b5f6b	351	cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
b4cafd67	352	GFC_INTEGER_4 ret_length __attribute__((unused)),
b4cafd67	353	const gfc_array_char * const restrict array,
0a6b5f6b	354	const 'atype` * const restrict h,
0a6b5f6b	355	const 'atype_name` * const restrict pwhich,
827aef63	356	GFC_INTEGER_4 array_length __attribute__((unused)))
1a9a4a12	357	{
827aef63	358	cshift1 (ret, array, h, pwhich);
1a9a4a12	359	}
920e54ef	360
329f13ad	361
	362	void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
	363	GFC_INTEGER_4,
	364	const gfc_array_char * const restrict array,
	365	const 'atype` * const restrict h,
	366	const 'atype_name` * const restrict pwhich,
	367	GFC_INTEGER_4);
	368	export_proto(cshift1_'atype_kind`_char4);
	369
	370	void
	371	cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
	372	GFC_INTEGER_4 ret_length __attribute__((unused)),
	373	const gfc_array_char * const restrict array,
	374	const 'atype` * const restrict h,
	375	const 'atype_name` * const restrict pwhich,
827aef63	376	GFC_INTEGER_4 array_length __attribute__((unused)))
329f13ad	377	{
827aef63	378	cshift1 (ret, array, h, pwhich);
329f13ad	379	}
329f13ad	380
0a6b5f6b	381	#endif'