[thirdparty/gcc.git] / libgfortran / generated / eoshift3_8.c

/* 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.

Libgfortran 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>


#if defined (HAVE_GFC_INTEGER_8)

static void
eoshift3 (gfc_array_char * const restrict ret, 
	const gfc_array_char * const restrict array, 
	const gfc_array_i8 * const restrict h,
	const gfc_array_char * const restrict bound, 
	const GFC_INTEGER_8 * const restrict pwhich,
	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 *rptr;
  char * restrict 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 GFC_INTEGER_8 *hptr;
  /* 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 size;
  index_type arraysize;
  int which;
  GFC_INTEGER_8 sh;
  GFC_INTEGER_8 delta;

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

  arraysize = size0 ((array_t *) array);
  size = GFC_DESCRIPTOR_SIZE(array);

  if (pwhich)
    which = *pwhich - 1;
  else
    which = 0;

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

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

    }
  else if (unlikely (compile_options.bounds_check))
    {
      bounds_equal_extents ((array_t *) ret, (array_t *) array,
				 "return value", "EOSHIFT");
    }

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

  if (arraysize == 0)
    return;

  extent[0] = 1;
  count[0] = 0;
  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);

          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
          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 (hstride[0] == 0)
    hstride[0] = 1;
  if (bound && bstride[0] == 0)
    bstride[0] = size;

  dim = GFC_DESCRIPTOR_RANK (array);
  rstride0 = rstride[0];
  sstride0 = sstride[0];
  hstride0 = hstride[0];
  bstride0 = bstride[0];
  rptr = ret->base_addr;
  sptr = array->base_addr;
  hptr = h->base_addr;
  if (bound)
    bptr = bound->base_addr;
  else
    bptr = NULL;

  while (rptr)
    {
      /* Do the shift for this dimension.  */
      sh = *hptr;
      if (( sh >= 0 ? sh : -sh ) > len)
	{
	  delta = len;
	  sh = len;
	}
      else
	delta = (sh >= 0) ? sh: -sh;

      if (sh > 0)
        {
          src = &sptr[delta * soffset];
          dest = rptr;
        }
      else
        {
          src = sptr;
          dest = &rptr[delta * roffset];
        }

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

      if (sh < 0)
        dest = rptr;
      n = delta;

      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;
      hptr += hstride0;
      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];
	  hptr -= hstride[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];
	      hptr += hstride[n];
              bptr += bstride[n];
            }
        }
    }
}

extern void eoshift3_8 (gfc_array_char * const restrict, 
	const gfc_array_char * const restrict,
	const gfc_array_i8 * const restrict, 
	const gfc_array_char * const restrict,
	const GFC_INTEGER_8 *);
export_proto(eoshift3_8);

void
eoshift3_8 (gfc_array_char * const restrict ret, 
	const gfc_array_char * const restrict array,
	const gfc_array_i8 * const restrict h, 
	const gfc_array_char * const restrict bound,
	const GFC_INTEGER_8 * const restrict pwhich)
{
  eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
}


extern void eoshift3_8_char (gfc_array_char * const restrict, 
	GFC_INTEGER_4,
	const gfc_array_char * const restrict,
	const gfc_array_i8 * const restrict,
	const gfc_array_char * const restrict,
	const GFC_INTEGER_8 * const restrict, 
	GFC_INTEGER_4, GFC_INTEGER_4);
export_proto(eoshift3_8_char);

void
eoshift3_8_char (gfc_array_char * const restrict ret,
	GFC_INTEGER_4 ret_length __attribute__((unused)),
	const gfc_array_char * const restrict array, 
	const gfc_array_i8 *  const restrict h,
	const gfc_array_char * const restrict bound,
	const GFC_INTEGER_8 * const restrict pwhich,
	GFC_INTEGER_4 array_length __attribute__((unused)),
	GFC_INTEGER_4 bound_length __attribute__((unused)))
{
  eoshift3 (ret, array, h, bound, pwhich, " ", 1);
}


extern void eoshift3_8_char4 (gfc_array_char * const restrict, 
	GFC_INTEGER_4,
	const gfc_array_char * const restrict,
	const gfc_array_i8 * const restrict,
	const gfc_array_char * const restrict,
	const GFC_INTEGER_8 * const restrict, 
	GFC_INTEGER_4, GFC_INTEGER_4);
export_proto(eoshift3_8_char4);

void
eoshift3_8_char4 (gfc_array_char * const restrict ret,
	GFC_INTEGER_4 ret_length __attribute__((unused)),
	const gfc_array_char * const restrict array, 
	const gfc_array_i8 *  const restrict h,
	const gfc_array_char * const restrict bound,
	const GFC_INTEGER_8 * const restrict pwhich,
	GFC_INTEGER_4 array_length __attribute__((unused)),
	GFC_INTEGER_4 bound_length __attribute__((unused)))
{
  static const gfc_char4_t space = (unsigned char) ' ';
  eoshift3 (ret, array, h, bound, pwhich,
	    (const char *) &space, sizeof (gfc_char4_t));
}

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