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

/* Generic implementation of the EOSHIFT intrinsic
   Copyright (C) 2002-2020 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
883c9d4d	1	/* Generic implementation of the EOSHIFT intrinsic
8d9254fc	2	Copyright (C) 2002-2020 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	4
21d1335b	5	This file is part of the GNU Fortran runtime library (libgfortran).
6de9cd9a	6
57dea9f6 TM	7	Libgfortran is free software; you can redistribute it and/or
57dea9f6 TM	8	modify it under the terms of the GNU General Public
6de9cd9a	9	License as published by the Free Software Foundation; either
748086b7	10	version 3 of the License, or (at your option) any later version.
57dea9f6 TM	11
57dea9f6 TM	12	Ligbfortran is distributed in the hope that it will be useful,
6de9cd9a DN	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
6de9cd9a DN	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
57dea9f6	15	GNU General Public License for more details.
6de9cd9a	16
748086b7 JJ	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/>. */
6de9cd9a	25
36ae8a61	26	#include "libgfortran.h"
6de9cd9a	27	#include <string.h>
6de9cd9a	28
6de9cd9a DN	29
6de9cd9a DN	30	static void
7f68c75f	31	eoshift2 (gfc_array_char ret, const gfc_array_char array,
a97ae559	32	index_type shift, const gfc_array_char *bound, int which,
dfb55fdc	33	const char *filler, index_type filler_len)
6de9cd9a DN	34	{
6de9cd9a DN	35	/* r.* indicates the return array. */
e33e218b	36	index_type rstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	37	index_type rstride0;
6de9cd9a DN	38	index_type roffset;
5863aacf	39	char * restrict rptr;
6de9cd9a DN	40	char *dest;
6de9cd9a DN	41	/* s.* indicates the source array. */
e33e218b	42	index_type sstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	43	index_type sstride0;
	44	index_type soffset;
	45	const char *sptr;
	46	const char *src;
	47	/* b.* indicates the bound array. */
e33e218b	48	index_type bstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	49	index_type bstride0;
	50	const char *bptr;
	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;
dfb55fdc	58	index_type size;
6de9cd9a	59
7672ae20 AJ	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
dfb55fdc TK	66	size = GFC_DESCRIPTOR_SIZE (array);
dfb55fdc TK	67
c44109aa TK	68	arraysize = size0 ((array_t *) array);
c44109aa TK	69
21d1335b	70	if (ret->base_addr == NULL)
883c9d4d VL	71	{
	72	int i;
	73
efd4dc1a	74	ret->offset = 0;
fa3c4d47	75	GFC_DTYPE_COPY(ret,array);
5450a88f	76
92e6f3a4 JB	77	/* xmallocarray allocates a single byte for zero size. */
92e6f3a4 JB	78	ret->base_addr = xmallocarray (arraysize, size);
5450a88f	79
883c9d4d VL	80	for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
883c9d4d VL	81	{
dfb55fdc TK	82	index_type ub, str;
	83
	84	ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
883c9d4d VL	85
883c9d4d VL	86	if (i == 0)
dfb55fdc	87	str = 1;
883c9d4d	88	else
dfb55fdc TK	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);
883c9d4d VL	93	}
883c9d4d VL	94	}
16bff921	95	else if (unlikely (compile_options.bounds_check))
c44109aa	96	{
16bff921 TK	97	bounds_equal_extents ((array_t ) ret, (array_t ) array,
16bff921 TK	98	"return value", "EOSHIFT");
c44109aa TK	99	}
c44109aa TK	100
16bff921	101	if (arraysize == 0)
c44109aa	102	return;
883c9d4d	103
6de9cd9a DN	104	which = which - 1;
	105
	106	extent[0] = 1;
	107	count[0] = 0;
1f801ab7 TB	108	sstride[0] = -1;
	109	rstride[0] = -1;
	110	bstride[0] = -1;
6de9cd9a DN	111	n = 0;
	112	for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
	113	{
	114	if (dim == which)
	115	{
dfb55fdc	116	roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
6de9cd9a DN	117	if (roffset == 0)
6de9cd9a DN	118	roffset = size;
dfb55fdc	119	soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
6de9cd9a DN	120	if (soffset == 0)
6de9cd9a DN	121	soffset = size;
dfb55fdc	122	len = GFC_DESCRIPTOR_EXTENT(array,dim);
6de9cd9a DN	123	}
	124	else
	125	{
	126	count[n] = 0;
dfb55fdc TK	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);
6de9cd9a	130	if (bound)
dfb55fdc	131	bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
6de9cd9a DN	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];
21d1335b TB	148	rptr = ret->base_addr;
21d1335b TB	149	sptr = array->base_addr;
47b3a403 TK	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
6de9cd9a	164	if (bound)
21d1335b	165	bptr = bound->base_addr;
6de9cd9a	166	else
7823229b	167	bptr = NULL;
6de9cd9a	168
6de9cd9a DN	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	}
ba71a2a6 TK	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	}
6de9cd9a DN	199	if (shift >= 0)
	200	{
	201	n = shift;
	202	}
	203	else
	204	{
	205	dest = rptr;
	206	n = -shift;
	207	}
	208
7823229b RS	209	if (bptr)
	210	while (n--)
	211	{
	212	memcpy (dest, bptr, size);
	213	dest += roffset;
	214	}
	215	else
	216	while (n--)
	217	{
691da334 FXC	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
7823229b RS	226	dest += roffset;
7823229b RS	227	}
6de9cd9a DN	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
8b6dba81	241	frequently used path so probably not worth it. */
6de9cd9a DN	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
985791f6	263
7823229b RS	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, \
dfb55fdc	276	"\0", 1); \
7823229b RS	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, \
dfb55fdc	294	GFC_INTEGER_4 array_length __attribute__((unused)), \
7823229b RS	295	GFC_INTEGER_4 bound_length __attribute__((unused))) \
	296	{ \
	297	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
dfb55fdc	298	" ", 1); \
691da334 FXC	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, \
dfb55fdc	316	GFC_INTEGER_4 array_length __attribute__((unused)), \
691da334 FXC	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, \
dfb55fdc	321	(const char *) &space, \
691da334	322	sizeof (gfc_char4_t)); \
7823229b RS	323	}
	324
	325	DEFINE_EOSHIFT (1);
	326	DEFINE_EOSHIFT (2);
	327	DEFINE_EOSHIFT (4);
	328	DEFINE_EOSHIFT (8);
143350a8 TK	329	#ifdef HAVE_GFC_INTEGER_16
	330	DEFINE_EOSHIFT (16);
	331	#endif