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

/* Special implementation of the SPREAD intrinsic
   Copyright (C) 2008-2017 Free Software Foundation, Inc.
   Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
   spread_generic.c written 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>


#if defined (HAVE_GFC_COMPLEX_10)

void
spread_c10 (gfc_array_c10 *ret, const gfc_array_c10 *source,
		 const index_type along, const index_type pncopies)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rdelta = 0;
  index_type rrank;
  index_type rs;
  GFC_COMPLEX_10 *rptr;
  GFC_COMPLEX_10 * restrict dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type srank;
  const GFC_COMPLEX_10 *sptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;
  index_type ncopies;

  srank = GFC_DESCRIPTOR_RANK(source);

  rrank = srank + 1;
  if (rrank > GFC_MAX_DIMENSIONS)
    runtime_error ("return rank too large in spread()");

  if (along > rrank)
      runtime_error ("dim outside of rank in spread()");

  ncopies = pncopies;

  if (ret->base_addr == NULL)
    {

      size_t ub, stride;

      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
      dim = 0;
      rs = 1;
      for (n = 0; n < rrank; n++)
	{
	  stride = rs;
	  if (n == along - 1)
	    {
	      ub = ncopies - 1;
	      rdelta = rs;
	      rs *= ncopies;
	    }
	  else
	    {
	      count[dim] = 0;
	      extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
	      sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
	      rstride[dim] = rs;

	      ub = extent[dim] - 1;
	      rs *= extent[dim];
	      dim++;
	    }
	  GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
	}
      ret->offset = 0;

      /* xmallocarray allocates a single byte for zero size.  */
      ret->base_addr = xmallocarray (rs, sizeof(GFC_COMPLEX_10));
      if (rs <= 0)
        return;
    }
  else
    {
      int zero_sized;

      zero_sized = 0;

      dim = 0;
      if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	runtime_error ("rank mismatch in spread()");

      if (unlikely (compile_options.bounds_check))
	{
	  for (n = 0; n < rrank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
	      if (n == along - 1)
		{
		  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);

		  if (ret_extent != ncopies)
		    runtime_error("Incorrect extent in return value of SPREAD"
				  " intrinsic in dimension %ld: is %ld,"
				  " should be %ld", (long int) n+1,
				  (long int) ret_extent, (long int) ncopies);
		}
	      else
		{
		  count[dim] = 0;
		  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
		  if (ret_extent != extent[dim])
		    runtime_error("Incorrect extent in return value of SPREAD"
				  " intrinsic in dimension %ld: is %ld,"
				  " should be %ld", (long int) n+1,
				  (long int) ret_extent,
				  (long int) extent[dim]);
		    
		  if (extent[dim] <= 0)
		    zero_sized = 1;
		  sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
		  rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
		  dim++;
		}
	    }
	}
      else
	{
	  for (n = 0; n < rrank; n++)
	    {
	      if (n == along - 1)
		{
		  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
		}
	      else
		{
		  count[dim] = 0;
		  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
		  if (extent[dim] <= 0)
		    zero_sized = 1;
		  sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
		  rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
		  dim++;
		}
	    }
	}

      if (zero_sized)
	return;

      if (sstride[0] == 0)
	sstride[0] = 1;
    }
  sstride0 = sstride[0];
  rstride0 = rstride[0];
  rptr = ret->base_addr;
  sptr = source->base_addr;

  while (sptr)
    {
      /* Spread this element.  */
      dest = rptr;
      for (n = 0; n < ncopies; n++)
        {
	  *dest = *sptr;
          dest += rdelta;
        }
      /* Advance to the next element.  */
      sptr += sstride0;
      rptr += rstride0;
      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.  */
          sptr -= sstride[n] * extent[n];
          rptr -= rstride[n] * extent[n];
          n++;
          if (n >= srank)
            {
              /* Break out of the loop.  */
              sptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              sptr += sstride[n];
              rptr += rstride[n];
            }
        }
    }
}

/* This version of spread_internal treats the special case of a scalar
   source.  This is much simpler than the more general case above.  */

void
spread_scalar_c10 (gfc_array_c10 *ret, const GFC_COMPLEX_10 *source,
			const index_type along, const index_type pncopies)
{
  int n;
  int ncopies = pncopies;
  GFC_COMPLEX_10 * restrict dest;
  index_type stride;

  if (GFC_DESCRIPTOR_RANK (ret) != 1)
    runtime_error ("incorrect destination rank in spread()");

  if (along > 1)
    runtime_error ("dim outside of rank in spread()");

  if (ret->base_addr == NULL)
    {
      ret->base_addr = xmallocarray (ncopies, sizeof (GFC_COMPLEX_10));
      ret->offset = 0;
      GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
    }
  else
    {
      if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
			   / GFC_DESCRIPTOR_STRIDE(ret,0))
	runtime_error ("dim too large in spread()");
    }

  dest = ret->base_addr;
  stride = GFC_DESCRIPTOR_STRIDE(ret,0);

  for (n = 0; n < ncopies; n++)
    {
      *dest = *source;
      dest += stride;
    }
}

#endif
Commit	Line	Data
75f2543f	1	/* Special implementation of the SPREAD intrinsic
cbe34bb5	2	Copyright (C) 2008-2017 Free Software Foundation, Inc.
75f2543f TK	3	Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
	4	spread_generic.c written by Paul Brook <paul@nowt.org>
	5
21d1335b	6	This file is part of the GNU Fortran runtime library (libgfortran).
75f2543f TK	7
	8	Libgfortran is free software; you can redistribute it and/or
	9	modify it under the terms of the GNU General Public
	10	License as published by the Free Software Foundation; either
748086b7	11	version 3 of the License, or (at your option) any later version.
75f2543f TK	12
	13	Ligbfortran is distributed in the hope that it will be useful,
	14	but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	GNU General Public License for more details.
	17
748086b7 JJ	18	Under Section 7 of GPL version 3, you are granted additional
	19	permissions described in the GCC Runtime Library Exception, version
	20	3.1, as published by the Free Software Foundation.
	21
	22	You should have received a copy of the GNU General Public License and
	23	a copy of the GCC Runtime Library Exception along with this program;
	24	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	25	<http://www.gnu.org/licenses/>. */
75f2543f TK	26
75f2543f TK	27	#include "libgfortran.h"
75f2543f TK	28	#include <string.h>
	29
	30
	31	#if defined (HAVE_GFC_COMPLEX_10)
	32
	33	void
	34	spread_c10 (gfc_array_c10 ret, const gfc_array_c10 source,
	35	const index_type along, const index_type pncopies)
	36	{
	37	/* r.* indicates the return array. */
	38	index_type rstride[GFC_MAX_DIMENSIONS];
	39	index_type rstride0;
	40	index_type rdelta = 0;
	41	index_type rrank;
	42	index_type rs;
	43	GFC_COMPLEX_10 *rptr;
5863aacf	44	GFC_COMPLEX_10 * restrict dest;
75f2543f TK	45	/* s.* indicates the source array. */
	46	index_type sstride[GFC_MAX_DIMENSIONS];
	47	index_type sstride0;
	48	index_type srank;
	49	const GFC_COMPLEX_10 *sptr;
	50
	51	index_type count[GFC_MAX_DIMENSIONS];
	52	index_type extent[GFC_MAX_DIMENSIONS];
	53	index_type n;
	54	index_type dim;
	55	index_type ncopies;
	56
	57	srank = GFC_DESCRIPTOR_RANK(source);
	58
	59	rrank = srank + 1;
	60	if (rrank > GFC_MAX_DIMENSIONS)
	61	runtime_error ("return rank too large in spread()");
	62
	63	if (along > rrank)
	64	runtime_error ("dim outside of rank in spread()");
	65
	66	ncopies = pncopies;
	67
21d1335b	68	if (ret->base_addr == NULL)
75f2543f	69	{
dfb55fdc TK	70
	71	size_t ub, stride;
	72
75f2543f TK	73	/* The front end has signalled that we need to populate the
	74	return array descriptor. */
	75	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rrank;
	76	dim = 0;
	77	rs = 1;
	78	for (n = 0; n < rrank; n++)
	79	{
dfb55fdc	80	stride = rs;
75f2543f TK	81	if (n == along - 1)
75f2543f TK	82	{
dfb55fdc	83	ub = ncopies - 1;
75f2543f TK	84	rdelta = rs;
	85	rs *= ncopies;
	86	}
	87	else
	88	{
	89	count[dim] = 0;
dfb55fdc TK	90	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
dfb55fdc TK	91	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
75f2543f TK	92	rstride[dim] = rs;
75f2543f TK	93
dfb55fdc	94	ub = extent[dim] - 1;
75f2543f TK	95	rs *= extent[dim];
	96	dim++;
	97	}
dfb55fdc	98	GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
75f2543f TK	99	}
75f2543f TK	100	ret->offset = 0;
a787f6f9	101
92e6f3a4 JB	102	/* xmallocarray allocates a single byte for zero size. */
92e6f3a4 JB	103	ret->base_addr = xmallocarray (rs, sizeof(GFC_COMPLEX_10));
a787f6f9 TK	104	if (rs <= 0)
a787f6f9 TK	105	return;
75f2543f TK	106	}
	107	else
	108	{
	109	int zero_sized;
	110
	111	zero_sized = 0;
	112
	113	dim = 0;
	114	if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	115	runtime_error ("rank mismatch in spread()");
	116
9731c4a3	117	if (unlikely (compile_options.bounds_check))
75f2543f TK	118	{
	119	for (n = 0; n < rrank; n++)
	120	{
	121	index_type ret_extent;
	122
dfb55fdc	123	ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
75f2543f TK	124	if (n == along - 1)
75f2543f TK	125	{
dfb55fdc	126	rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	127
	128	if (ret_extent != ncopies)
	129	runtime_error("Incorrect extent in return value of SPREAD"
	130	" intrinsic in dimension %ld: is %ld,"
	131	" should be %ld", (long int) n+1,
	132	(long int) ret_extent, (long int) ncopies);
	133	}
	134	else
	135	{
	136	count[dim] = 0;
dfb55fdc	137	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
75f2543f TK	138	if (ret_extent != extent[dim])
	139	runtime_error("Incorrect extent in return value of SPREAD"
	140	" intrinsic in dimension %ld: is %ld,"
	141	" should be %ld", (long int) n+1,
	142	(long int) ret_extent,
	143	(long int) extent[dim]);
	144
	145	if (extent[dim] <= 0)
	146	zero_sized = 1;
dfb55fdc TK	147	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
dfb55fdc TK	148	rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	149	dim++;
	150	}
	151	}
	152	}
	153	else
	154	{
	155	for (n = 0; n < rrank; n++)
	156	{
	157	if (n == along - 1)
	158	{
dfb55fdc	159	rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	160	}
	161	else
	162	{
	163	count[dim] = 0;
dfb55fdc	164	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
75f2543f TK	165	if (extent[dim] <= 0)
75f2543f TK	166	zero_sized = 1;
dfb55fdc TK	167	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
dfb55fdc TK	168	rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	169	dim++;
	170	}
	171	}
	172	}
	173
	174	if (zero_sized)
	175	return;
	176
	177	if (sstride[0] == 0)
	178	sstride[0] = 1;
	179	}
	180	sstride0 = sstride[0];
	181	rstride0 = rstride[0];
21d1335b TB	182	rptr = ret->base_addr;
21d1335b TB	183	sptr = source->base_addr;
75f2543f TK	184
	185	while (sptr)
	186	{
	187	/* Spread this element. */
	188	dest = rptr;
	189	for (n = 0; n < ncopies; n++)
	190	{
	191	dest = sptr;
	192	dest += rdelta;
	193	}
	194	/* Advance to the next element. */
	195	sptr += sstride0;
	196	rptr += rstride0;
	197	count[0]++;
	198	n = 0;
	199	while (count[n] == extent[n])
	200	{
	201	/* When we get to the end of a dimension, reset it and increment
	202	the next dimension. */
	203	count[n] = 0;
	204	/* We could precalculate these products, but this is a less
	205	frequently used path so probably not worth it. */
	206	sptr -= sstride[n] * extent[n];
	207	rptr -= rstride[n] * extent[n];
	208	n++;
	209	if (n >= srank)
	210	{
	211	/* Break out of the loop. */
	212	sptr = NULL;
	213	break;
	214	}
	215	else
	216	{
	217	count[n]++;
	218	sptr += sstride[n];
	219	rptr += rstride[n];
	220	}
	221	}
	222	}
	223	}
	224
	225	/* This version of spread_internal treats the special case of a scalar
	226	source. This is much simpler than the more general case above. */
	227
	228	void
	229	spread_scalar_c10 (gfc_array_c10 ret, const GFC_COMPLEX_10 source,
	230	const index_type along, const index_type pncopies)
	231	{
	232	int n;
	233	int ncopies = pncopies;
5863aacf	234	GFC_COMPLEX_10 * restrict dest;
75f2543f TK	235	index_type stride;
	236
	237	if (GFC_DESCRIPTOR_RANK (ret) != 1)
	238	runtime_error ("incorrect destination rank in spread()");
	239
	240	if (along > 1)
	241	runtime_error ("dim outside of rank in spread()");
	242
21d1335b	243	if (ret->base_addr == NULL)
75f2543f	244	{
92e6f3a4	245	ret->base_addr = xmallocarray (ncopies, sizeof (GFC_COMPLEX_10));
75f2543f	246	ret->offset = 0;
dfb55fdc	247	GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
75f2543f TK	248	}
	249	else
	250	{
dfb55fdc TK	251	if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
dfb55fdc TK	252	/ GFC_DESCRIPTOR_STRIDE(ret,0))
75f2543f TK	253	runtime_error ("dim too large in spread()");
	254	}
	255
21d1335b	256	dest = ret->base_addr;
dfb55fdc	257	stride = GFC_DESCRIPTOR_STRIDE(ret,0);
75f2543f TK	258
	259	for (n = 0; n < ncopies; n++)
	260	{
	261	dest = source;
	262	dest += stride;
	263	}
	264	}
	265
	266	#endif
5863aacf	267