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

/* Generic implementation of the EOSHIFT intrinsic
   Copyright (C) 2002-2019 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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>


static void
eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
	  index_type shift, const gfc_array_char *bound, int which,
	  const char *filler, index_type filler_len)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  char * restrict 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;
  /* b.* indicates the bound array.  */
  index_type bstride[GFC_MAX_DIMENSIONS];
  index_type bstride0;
  const char *bptr;

  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 size;

  /* The compiler cannot figure out that these are set, initialize
     them to avoid warnings.  */
  len = 0;
  soffset = 0;
  roffset = 0;

  size = GFC_DESCRIPTOR_SIZE (array);

  arraysize = size0 ((array_t *) array);

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

      ret->offset = 0;
      GFC_DTYPE_COPY(ret,array);

      /* xmallocarray allocates a single byte for zero size.  */
      ret->base_addr = xmallocarray (arraysize, size);

      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);
        }
    }
  else if (unlikely (compile_options.bounds_check))
    {
      bounds_equal_extents ((array_t *) ret, (array_t *) array,
				 "return value", "EOSHIFT");
    }

  if (arraysize == 0)
    return;

  which = which - 1;

  extent[0] = 1;
  count[0] = 0;
  sstride[0] = -1;
  rstride[0] = -1;
  bstride[0] = -1;
  n = 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);
          if (bound)
            bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
          else
            bstride[n] = 0;
          n++;
        }
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (rstride[0] == 0)
    rstride[0] = size;
  if (bound && bstride[0] == 0)
    bstride[0] = size;

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

  if ((shift >= 0 ? shift : -shift ) > len)
    {
      shift = len;
      len = 0;
    }
  else
    {
      if (shift > 0)
	len = len - shift;
      else
	len = len + shift;
    }
  
  if (bound)
    bptr = bound->base_addr;
  else
    bptr = NULL;

  while (rptr)
    {
      /* Do the shift for this dimension.  */
      if (shift > 0)
        {
          src = &sptr[shift * soffset];
          dest = rptr;
        }
      else
        {
          src = sptr;
          dest = &rptr[-shift * roffset];
        }

      /* If the elements are contiguous, perform a single block move.  */
      if (soffset == size && roffset == size)
	{
	  size_t chunk = size * len;
	  memcpy (dest, src, chunk);
	  dest += chunk;
	}
      else
	{
	  for (n = 0; n < len; n++)
	    {
	      memcpy (dest, src, size);
	      dest += roffset;
	      src += soffset;
	    }
	}
      if (shift >= 0)
        {
          n = shift;
        }
      else
        {
          dest = rptr;
          n = -shift;
        }

      if (bptr)
	while (n--)
	  {
	    memcpy (dest, bptr, size);
	    dest += roffset;
	  }
      else
	while (n--)
	  {
	    index_type i;

	    if (filler_len == 1)
	      memset (dest, filler[0], size);
	    else
	      for (i = 0; i < size ; i += filler_len)
		memcpy (&dest[i], filler, filler_len);

	    dest += roffset;
	  }

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


#define DEFINE_EOSHIFT(N)						      \
  extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *,	      \
			    const GFC_INTEGER_##N *, const gfc_array_char *,  \
			    const GFC_INTEGER_##N *);			      \
  export_proto(eoshift2_##N);						      \
									      \
  void									      \
  eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array,	      \
		const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound,  \
		const GFC_INTEGER_##N *pdim)				      \
  {									      \
    eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,		      \
	      "\0", 1);			      \
  }									      \
									      \
  extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4,	      \
				   const gfc_array_char *,		      \
				   const GFC_INTEGER_##N *,		      \
				   const gfc_array_char *,		      \
				   const GFC_INTEGER_##N *,		      \
				   GFC_INTEGER_4, GFC_INTEGER_4);	      \
  export_proto(eoshift2_##N##_char);					      \
									      \
  void									      \
  eoshift2_##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_array_char *pbound,			      \
		       const GFC_INTEGER_##N *pdim,			      \
		       GFC_INTEGER_4 array_length __attribute__((unused)),    \
		       GFC_INTEGER_4 bound_length __attribute__((unused)))    \
  {									      \
    eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,		      \
	      " ", 1);							      \
  }									      \
									      \
  extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,	      \
				    const gfc_array_char *,		      \
				    const GFC_INTEGER_##N *,		      \
				    const gfc_array_char *,		      \
				    const GFC_INTEGER_##N *,		      \
				    GFC_INTEGER_4, GFC_INTEGER_4);	      \
  export_proto(eoshift2_##N##_char4);					      \
									      \
  void									      \
  eoshift2_##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_array_char *pbound,			      \
			const GFC_INTEGER_##N *pdim,			      \
			GFC_INTEGER_4 array_length __attribute__((unused)),   \
			GFC_INTEGER_4 bound_length __attribute__((unused)))   \
  {									      \
    static const gfc_char4_t space = (unsigned char) ' ';		      \
    eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1,		      \
	      (const char *) &space,					      \
	      sizeof (gfc_char4_t));					      \
  }

DEFINE_EOSHIFT (1);
DEFINE_EOSHIFT (2);
DEFINE_EOSHIFT (4);
DEFINE_EOSHIFT (8);
#ifdef HAVE_GFC_INTEGER_16
DEFINE_EOSHIFT (16);
#endif
Commit	Line	Data
4a43abf4	1	/* Generic implementation of the EOSHIFT intrinsic
fbd26352	2	Copyright (C) 2002-2019 Free Software Foundation, Inc.
4ee9c684	3	Contributed by Paul Brook <paul@nowt.org>
4ee9c684	4
553877d9	5	This file is part of the GNU Fortran runtime library (libgfortran).
4ee9c684	6
b417ea8c	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"
4ee9c684	27	#include <string.h>
4ee9c684	28
4ee9c684	29
4ee9c684	30	static void
820b4fbd	31	eoshift2 (gfc_array_char ret, const gfc_array_char array,
36fec693	32	index_type shift, const gfc_array_char *bound, int which,
827aef63	33	const char *filler, index_type filler_len)
4ee9c684	34	{
4ee9c684	35	/* r.* indicates the return array. */
9130521e	36	index_type rstride[GFC_MAX_DIMENSIONS];
4ee9c684	37	index_type rstride0;
4ee9c684	38	index_type roffset;
9d259edf	39	char * restrict rptr;
4ee9c684	40	char *dest;
4ee9c684	41	/* s.* indicates the source array. */
9130521e	42	index_type sstride[GFC_MAX_DIMENSIONS];
4ee9c684	43	index_type sstride0;
	44	index_type soffset;
	45	const char *sptr;
	46	const char *src;
	47	/* b.* indicates the bound array. */
9130521e	48	index_type bstride[GFC_MAX_DIMENSIONS];
4ee9c684	49	index_type bstride0;
	50	const char *bptr;
	51
9130521e	52	index_type count[GFC_MAX_DIMENSIONS];
9130521e	53	index_type extent[GFC_MAX_DIMENSIONS];
4ee9c684	54	index_type dim;
4ee9c684	55	index_type len;
4ee9c684	56	index_type n;
74a175c1	57	index_type arraysize;
827aef63	58	index_type size;
4ee9c684	59
7b49b59f	60	/* The compiler cannot figure out that these are set, initialize
	61	them to avoid warnings. */
	62	len = 0;
	63	soffset = 0;
	64	roffset = 0;
	65
827aef63	66	size = GFC_DESCRIPTOR_SIZE (array);
827aef63	67
74a175c1	68	arraysize = size0 ((array_t *) array);
74a175c1	69
553877d9	70	if (ret->base_addr == NULL)
4a43abf4	71	{
	72	int i;
	73
93830de1	74	ret->offset = 0;
da8dff89	75	GFC_DTYPE_COPY(ret,array);
79f3fcdb	76
af1e9051	77	/* xmallocarray allocates a single byte for zero size. */
af1e9051	78	ret->base_addr = xmallocarray (arraysize, size);
79f3fcdb	79
4a43abf4	80	for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
4a43abf4	81	{
827aef63	82	index_type ub, str;
	83
	84	ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
4a43abf4	85
4a43abf4	86	if (i == 0)
827aef63	87	str = 1;
4a43abf4	88	else
827aef63	89	str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
	90	* GFC_DESCRIPTOR_STRIDE(ret,i-1);
	91
	92	GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
4a43abf4	93	}
4a43abf4	94	}
5d04d450	95	else if (unlikely (compile_options.bounds_check))
74a175c1	96	{
5d04d450	97	bounds_equal_extents ((array_t ) ret, (array_t ) array,
5d04d450	98	"return value", "EOSHIFT");
74a175c1	99	}
74a175c1	100
5d04d450	101	if (arraysize == 0)
74a175c1	102	return;
4a43abf4	103
4ee9c684	104	which = which - 1;
	105
	106	extent[0] = 1;
	107	count[0] = 0;
1ac88dca	108	sstride[0] = -1;
	109	rstride[0] = -1;
	110	bstride[0] = -1;
4ee9c684	111	n = 0;
	112	for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
	113	{
	114	if (dim == which)
	115	{
827aef63	116	roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
4ee9c684	117	if (roffset == 0)
4ee9c684	118	roffset = size;
827aef63	119	soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
4ee9c684	120	if (soffset == 0)
4ee9c684	121	soffset = size;
827aef63	122	len = GFC_DESCRIPTOR_EXTENT(array,dim);
4ee9c684	123	}
	124	else
	125	{
	126	count[n] = 0;
827aef63	127	extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
	128	rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
	129	sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
4ee9c684	130	if (bound)
827aef63	131	bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
4ee9c684	132	else
	133	bstride[n] = 0;
	134	n++;
	135	}
	136	}
	137	if (sstride[0] == 0)
	138	sstride[0] = size;
	139	if (rstride[0] == 0)
	140	rstride[0] = size;
	141	if (bound && bstride[0] == 0)
	142	bstride[0] = size;
	143
	144	dim = GFC_DESCRIPTOR_RANK (array);
	145	rstride0 = rstride[0];
	146	sstride0 = sstride[0];
	147	bstride0 = bstride[0];
553877d9	148	rptr = ret->base_addr;
553877d9	149	sptr = array->base_addr;
4eef4aad	150
	151	if ((shift >= 0 ? shift : -shift ) > len)
	152	{
	153	shift = len;
	154	len = 0;
	155	}
	156	else
	157	{
	158	if (shift > 0)
	159	len = len - shift;
	160	else
	161	len = len + shift;
	162	}
	163
4ee9c684	164	if (bound)
553877d9	165	bptr = bound->base_addr;
4ee9c684	166	else
1a9a4a12	167	bptr = NULL;
4ee9c684	168
4ee9c684	169	while (rptr)
	170	{
	171	/* Do the shift for this dimension. */
	172	if (shift > 0)
	173	{
	174	src = &sptr[shift * soffset];
	175	dest = rptr;
	176	}
	177	else
	178	{
	179	src = sptr;
	180	dest = &rptr[-shift * roffset];
	181	}
829231a6	182
	183	/* If the elements are contiguous, perform a single block move. */
	184	if (soffset == size && roffset == size)
	185	{
	186	size_t chunk = size * len;
	187	memcpy (dest, src, chunk);
	188	dest += chunk;
	189	}
	190	else
	191	{
	192	for (n = 0; n < len; n++)
	193	{
	194	memcpy (dest, src, size);
	195	dest += roffset;
	196	src += soffset;
	197	}
	198	}
4ee9c684	199	if (shift >= 0)
	200	{
	201	n = shift;
	202	}
	203	else
	204	{
	205	dest = rptr;
	206	n = -shift;
	207	}
	208
1a9a4a12	209	if (bptr)
	210	while (n--)
	211	{
	212	memcpy (dest, bptr, size);
	213	dest += roffset;
	214	}
	215	else
	216	while (n--)
	217	{
329f13ad	218	index_type i;
	219
	220	if (filler_len == 1)
	221	memset (dest, filler[0], size);
	222	else
	223	for (i = 0; i < size ; i += filler_len)
	224	memcpy (&dest[i], filler, filler_len);
	225
1a9a4a12	226	dest += roffset;
1a9a4a12	227	}
4ee9c684	228
	229	/* Advance to the next section. */
	230	rptr += rstride0;
	231	sptr += sstride0;
	232	bptr += bstride0;
	233	count[0]++;
	234	n = 0;
	235	while (count[n] == extent[n])
	236	{
	237	/* When we get to the end of a dimension, reset it and increment
	238	the next dimension. */
	239	count[n] = 0;
	240	/* We could precalculate these products, but this is a less
a2ffc2c4	241	frequently used path so probably not worth it. */
4ee9c684	242	rptr -= rstride[n] * extent[n];
	243	sptr -= sstride[n] * extent[n];
	244	bptr -= bstride[n] * extent[n];
	245	n++;
	246	if (n >= dim - 1)
	247	{
	248	/* Break out of the loop. */
	249	rptr = NULL;
	250	break;
	251	}
	252	else
	253	{
	254	count[n]++;
	255	rptr += rstride[n];
	256	sptr += sstride[n];
	257	bptr += bstride[n];
	258	}
	259	}
	260	}
	261	}
	262
800c028f	263
1a9a4a12	264	#define DEFINE_EOSHIFT(N) \
	265	extern void eoshift2_##N (gfc_array_char , const gfc_array_char , \
	266	const GFC_INTEGER_##N , const gfc_array_char , \
	267	const GFC_INTEGER_##N *); \
	268	export_proto(eoshift2_##N); \
	269	\
	270	void \
	271	eoshift2_##N (gfc_array_char ret, const gfc_array_char array, \
	272	const GFC_INTEGER_##N pshift, const gfc_array_char pbound, \
	273	const GFC_INTEGER_##N *pdim) \
	274	{ \
	275	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
827aef63	276	"\0", 1); \
1a9a4a12	277	} \
	278	\
	279	extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
	280	const gfc_array_char *, \
	281	const GFC_INTEGER_##N *, \
	282	const gfc_array_char *, \
	283	const GFC_INTEGER_##N *, \
	284	GFC_INTEGER_4, GFC_INTEGER_4); \
	285	export_proto(eoshift2_##N##_char); \
	286	\
	287	void \
	288	eoshift2_##N##_char (gfc_array_char *ret, \
	289	GFC_INTEGER_4 ret_length __attribute__((unused)), \
	290	const gfc_array_char *array, \
	291	const GFC_INTEGER_##N *pshift, \
	292	const gfc_array_char *pbound, \
	293	const GFC_INTEGER_##N *pdim, \
827aef63	294	GFC_INTEGER_4 array_length __attribute__((unused)), \
1a9a4a12	295	GFC_INTEGER_4 bound_length __attribute__((unused))) \
	296	{ \
	297	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
827aef63	298	" ", 1); \
329f13ad	299	} \
	300	\
	301	extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
	302	const gfc_array_char *, \
	303	const GFC_INTEGER_##N *, \
	304	const gfc_array_char *, \
	305	const GFC_INTEGER_##N *, \
	306	GFC_INTEGER_4, GFC_INTEGER_4); \
	307	export_proto(eoshift2_##N##_char4); \
	308	\
	309	void \
	310	eoshift2_##N##_char4 (gfc_array_char *ret, \
	311	GFC_INTEGER_4 ret_length __attribute__((unused)), \
	312	const gfc_array_char *array, \
	313	const GFC_INTEGER_##N *pshift, \
	314	const gfc_array_char *pbound, \
	315	const GFC_INTEGER_##N *pdim, \
827aef63	316	GFC_INTEGER_4 array_length __attribute__((unused)), \
329f13ad	317	GFC_INTEGER_4 bound_length __attribute__((unused))) \
	318	{ \
	319	static const gfc_char4_t space = (unsigned char) ' '; \
	320	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
827aef63	321	(const char *) &space, \
329f13ad	322	sizeof (gfc_char4_t)); \
1a9a4a12	323	}
	324
	325	DEFINE_EOSHIFT (1);
	326	DEFINE_EOSHIFT (2);
	327	DEFINE_EOSHIFT (4);
	328	DEFINE_EOSHIFT (8);
914c6756	329	#ifdef HAVE_GFC_INTEGER_16
	330	DEFINE_EOSHIFT (16);
	331	#endif