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

/* Generic implementation of the EOSHIFT intrinsic
   Copyright (C) 2002-2016 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 <stdlib.h>
#include <assert.h>
#include <string.h>

/* TODO: make this work for large shifts when
   sizeof(int) < sizeof (index_type).  */

static void
eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
	  int 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;
      ret->dtype = array->dtype;

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