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

/* Generic implementation of the EOSHIFT intrinsic
   Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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 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->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", "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->data;
  sptr = array->data;

  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->data;
  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
883c9d4d	1	/* Generic implementation of the EOSHIFT intrinsic
748086b7	2	Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	4
57dea9f6	5	This file is part of the GNU Fortran 95 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 DN	27	#include <stdlib.h>
	28	#include <assert.h>
	29	#include <string.h>
6de9cd9a	30
6de9cd9a DN	31	/* TODO: make this work for large shifts when
	32	sizeof(int) < sizeof (index_type). */
	33
	34	static void
7f68c75f	35	eoshift2 (gfc_array_char ret, const gfc_array_char array,
7823229b	36	int shift, const gfc_array_char *bound, int which,
dfb55fdc	37	const char *filler, index_type filler_len)
6de9cd9a DN	38	{
6de9cd9a DN	39	/* r.* indicates the return array. */
e33e218b	40	index_type rstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	41	index_type rstride0;
6de9cd9a DN	42	index_type roffset;
5863aacf	43	char * restrict rptr;
6de9cd9a DN	44	char *dest;
6de9cd9a DN	45	/* s.* indicates the source array. */
e33e218b	46	index_type sstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	47	index_type sstride0;
	48	index_type soffset;
	49	const char *sptr;
	50	const char *src;
	51	/* b.* indicates the bound array. */
e33e218b	52	index_type bstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	53	index_type bstride0;
	54	const char *bptr;
	55
e33e218b TK	56	index_type count[GFC_MAX_DIMENSIONS];
e33e218b TK	57	index_type extent[GFC_MAX_DIMENSIONS];
6de9cd9a	58	index_type dim;
6de9cd9a DN	59	index_type len;
6de9cd9a DN	60	index_type n;
c44109aa	61	index_type arraysize;
dfb55fdc	62	index_type size;
6de9cd9a	63
7672ae20 AJ	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
dfb55fdc TK	70	size = GFC_DESCRIPTOR_SIZE (array);
dfb55fdc TK	71
c44109aa TK	72	arraysize = size0 ((array_t *) array);
c44109aa TK	73
883c9d4d VL	74	if (ret->data == NULL)
	75	{
	76	int i;
	77
efd4dc1a	78	ret->offset = 0;
883c9d4d VL	79	ret->dtype = array->dtype;
	80	for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
	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);
	93
16bff921 TK	94	if (arraysize > 0)
	95	ret->data = internal_malloc_size (size * arraysize);
	96	else
	97	ret->data = internal_malloc_size (1);
	98
883c9d4d VL	99	}
883c9d4d VL	100	}
16bff921	101	else if (unlikely (compile_options.bounds_check))
c44109aa	102	{
16bff921 TK	103	bounds_equal_extents ((array_t ) ret, (array_t ) array,
16bff921 TK	104	"return value", "EOSHIFT");
c44109aa TK	105	}
c44109aa TK	106
16bff921	107	if (arraysize == 0)
c44109aa	108	return;
883c9d4d	109
6de9cd9a DN	110	which = which - 1;
	111
	112	extent[0] = 1;
	113	count[0] = 0;
1f801ab7 TB	114	sstride[0] = -1;
	115	rstride[0] = -1;
	116	bstride[0] = -1;
6de9cd9a DN	117	n = 0;
	118	for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
	119	{
	120	if (dim == which)
	121	{
dfb55fdc	122	roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
6de9cd9a DN	123	if (roffset == 0)
6de9cd9a DN	124	roffset = size;
dfb55fdc	125	soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
6de9cd9a DN	126	if (soffset == 0)
6de9cd9a DN	127	soffset = size;
dfb55fdc	128	len = GFC_DESCRIPTOR_EXTENT(array,dim);
6de9cd9a DN	129	}
	130	else
	131	{
	132	count[n] = 0;
dfb55fdc TK	133	extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
	134	rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
	135	sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
6de9cd9a	136	if (bound)
dfb55fdc	137	bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
6de9cd9a DN	138	else
	139	bstride[n] = 0;
	140	n++;
	141	}
	142	}
	143	if (sstride[0] == 0)
	144	sstride[0] = size;
	145	if (rstride[0] == 0)
	146	rstride[0] = size;
	147	if (bound && bstride[0] == 0)
	148	bstride[0] = size;
	149
	150	dim = GFC_DESCRIPTOR_RANK (array);
	151	rstride0 = rstride[0];
	152	sstride0 = sstride[0];
	153	bstride0 = bstride[0];
	154	rptr = ret->data;
	155	sptr = array->data;
47b3a403 TK	156
	157	if ((shift >= 0 ? shift : -shift ) > len)
	158	{
	159	shift = len;
	160	len = 0;
	161	}
	162	else
	163	{
	164	if (shift > 0)
	165	len = len - shift;
	166	else
	167	len = len + shift;
	168	}
	169
6de9cd9a DN	170	if (bound)
	171	bptr = bound->data;
	172	else
7823229b	173	bptr = NULL;
6de9cd9a	174
6de9cd9a DN	175	while (rptr)
	176	{
	177	/* Do the shift for this dimension. */
	178	if (shift > 0)
	179	{
	180	src = &sptr[shift * soffset];
	181	dest = rptr;
	182	}
	183	else
	184	{
	185	src = sptr;
	186	dest = &rptr[-shift * roffset];
	187	}
	188	for (n = 0; n < len; n++)
	189	{
	190	memcpy (dest, src, size);
	191	dest += roffset;
	192	src += soffset;
	193	}
	194	if (shift >= 0)
	195	{
	196	n = shift;
	197	}
	198	else
	199	{
	200	dest = rptr;
	201	n = -shift;
	202	}
	203
7823229b RS	204	if (bptr)
	205	while (n--)
	206	{
	207	memcpy (dest, bptr, size);
	208	dest += roffset;
	209	}
	210	else
	211	while (n--)
	212	{
691da334 FXC	213	index_type i;
	214
	215	if (filler_len == 1)
	216	memset (dest, filler[0], size);
	217	else
	218	for (i = 0; i < size ; i += filler_len)
	219	memcpy (&dest[i], filler, filler_len);
	220
7823229b RS	221	dest += roffset;
7823229b RS	222	}
6de9cd9a DN	223
	224	/* Advance to the next section. */
	225	rptr += rstride0;
	226	sptr += sstride0;
	227	bptr += bstride0;
	228	count[0]++;
	229	n = 0;
	230	while (count[n] == extent[n])
	231	{
	232	/* When we get to the end of a dimension, reset it and increment
	233	the next dimension. */
	234	count[n] = 0;
	235	/* We could precalculate these products, but this is a less
8b6dba81	236	frequently used path so probably not worth it. */
6de9cd9a DN	237	rptr -= rstride[n] * extent[n];
	238	sptr -= sstride[n] * extent[n];
	239	bptr -= bstride[n] * extent[n];
	240	n++;
	241	if (n >= dim - 1)
	242	{
	243	/* Break out of the loop. */
	244	rptr = NULL;
	245	break;
	246	}
	247	else
	248	{
	249	count[n]++;
	250	rptr += rstride[n];
	251	sptr += sstride[n];
	252	bptr += bstride[n];
	253	}
	254	}
	255	}
	256	}
	257
985791f6	258
7823229b RS	259	#define DEFINE_EOSHIFT(N) \
	260	extern void eoshift2_##N (gfc_array_char , const gfc_array_char , \
	261	const GFC_INTEGER_##N , const gfc_array_char , \
	262	const GFC_INTEGER_##N *); \
	263	export_proto(eoshift2_##N); \
	264	\
	265	void \
	266	eoshift2_##N (gfc_array_char ret, const gfc_array_char array, \
	267	const GFC_INTEGER_##N pshift, const gfc_array_char pbound, \
	268	const GFC_INTEGER_##N *pdim) \
	269	{ \
	270	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
dfb55fdc	271	"\0", 1); \
7823229b RS	272	} \
	273	\
	274	extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
	275	const gfc_array_char *, \
	276	const GFC_INTEGER_##N *, \
	277	const gfc_array_char *, \
	278	const GFC_INTEGER_##N *, \
	279	GFC_INTEGER_4, GFC_INTEGER_4); \
	280	export_proto(eoshift2_##N##_char); \
	281	\
	282	void \
	283	eoshift2_##N##_char (gfc_array_char *ret, \
	284	GFC_INTEGER_4 ret_length __attribute__((unused)), \
	285	const gfc_array_char *array, \
	286	const GFC_INTEGER_##N *pshift, \
	287	const gfc_array_char *pbound, \
	288	const GFC_INTEGER_##N *pdim, \
dfb55fdc	289	GFC_INTEGER_4 array_length __attribute__((unused)), \
7823229b RS	290	GFC_INTEGER_4 bound_length __attribute__((unused))) \
	291	{ \
	292	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
dfb55fdc	293	" ", 1); \
691da334 FXC	294	} \
	295	\
	296	extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
	297	const gfc_array_char *, \
	298	const GFC_INTEGER_##N *, \
	299	const gfc_array_char *, \
	300	const GFC_INTEGER_##N *, \
	301	GFC_INTEGER_4, GFC_INTEGER_4); \
	302	export_proto(eoshift2_##N##_char4); \
	303	\
	304	void \
	305	eoshift2_##N##_char4 (gfc_array_char *ret, \
	306	GFC_INTEGER_4 ret_length __attribute__((unused)), \
	307	const gfc_array_char *array, \
	308	const GFC_INTEGER_##N *pshift, \
	309	const gfc_array_char *pbound, \
	310	const GFC_INTEGER_##N *pdim, \
dfb55fdc	311	GFC_INTEGER_4 array_length __attribute__((unused)), \
691da334 FXC	312	GFC_INTEGER_4 bound_length __attribute__((unused))) \
	313	{ \
	314	static const gfc_char4_t space = (unsigned char) ' '; \
	315	eoshift2 (ret, array, pshift, pbound, pdim ? pdim : 1, \
dfb55fdc	316	(const char *) &space, \
691da334	317	sizeof (gfc_char4_t)); \
7823229b RS	318	}
	319
	320	DEFINE_EOSHIFT (1);
	321	DEFINE_EOSHIFT (2);
	322	DEFINE_EOSHIFT (4);
	323	DEFINE_EOSHIFT (8);
143350a8 TK	324	#ifdef HAVE_GFC_INTEGER_16
	325	DEFINE_EOSHIFT (16);
	326	#endif