[thirdparty/gcc.git] / libgfortran / m4 / spread.m4

`/* Special implementation of the SPREAD intrinsic
   Copyright 2008, 2009 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 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>'

include(iparm.m4)dnl

`#if defined (HAVE_'rtype_name`)

void
spread_'rtype_code` ('rtype` *ret, const 'rtype` *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;
  'rtype_name` *rptr;
  'rtype_name` * restrict dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type srank;
  const 'rtype_name` *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->data == 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;
      if (rs > 0)
        ret->data = internal_malloc_size (rs * sizeof('rtype_name`));
      else
	{
	  ret->data = internal_malloc_size (1);
	  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->data;
  sptr = source->data;

  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_'rtype_code` ('rtype` *ret, const 'rtype_name` *source,
			const index_type along, const index_type pncopies)
{
  int n;
  int ncopies = pncopies;
  'rtype_name` * 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->data == NULL)
    {
      ret->data = internal_malloc_size (ncopies * sizeof ('rtype_name`));
      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->data;
  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
748086b7	2	Copyright 2008, 2009 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
	6	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	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
	27	#include "libgfortran.h"
	28	#include <stdlib.h>
	29	#include <assert.h>
	30	#include <string.h>'
	31
	32	include(iparm.m4)dnl
	33
	34	`#if defined (HAVE_'rtype_name`)
	35
	36	void
	37	spread_'rtype_code` ('rtype` ret, const 'rtype` source,
	38	const index_type along, const index_type pncopies)
	39	{
	40	/* r.* indicates the return array. */
	41	index_type rstride[GFC_MAX_DIMENSIONS];
	42	index_type rstride0;
	43	index_type rdelta = 0;
	44	index_type rrank;
	45	index_type rs;
	46	'rtype_name` *rptr;
5863aacf	47	'rtype_name` * restrict dest;
75f2543f TK	48	/* s.* indicates the source array. */
	49	index_type sstride[GFC_MAX_DIMENSIONS];
	50	index_type sstride0;
	51	index_type srank;
	52	const 'rtype_name` *sptr;
	53
	54	index_type count[GFC_MAX_DIMENSIONS];
	55	index_type extent[GFC_MAX_DIMENSIONS];
	56	index_type n;
	57	index_type dim;
	58	index_type ncopies;
	59
	60	srank = GFC_DESCRIPTOR_RANK(source);
	61
	62	rrank = srank + 1;
	63	if (rrank > GFC_MAX_DIMENSIONS)
	64	runtime_error ("return rank too large in spread()");
	65
	66	if (along > rrank)
	67	runtime_error ("dim outside of rank in spread()");
	68
	69	ncopies = pncopies;
	70
	71	if (ret->data == NULL)
	72	{
dfb55fdc TK	73
	74	size_t ub, stride;
	75
75f2543f TK	76	/* The front end has signalled that we need to populate the
	77	return array descriptor. */
	78	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rrank;
	79	dim = 0;
	80	rs = 1;
	81	for (n = 0; n < rrank; n++)
	82	{
dfb55fdc	83	stride = rs;
75f2543f TK	84	if (n == along - 1)
75f2543f TK	85	{
dfb55fdc	86	ub = ncopies - 1;
75f2543f TK	87	rdelta = rs;
	88	rs *= ncopies;
	89	}
	90	else
	91	{
	92	count[dim] = 0;
dfb55fdc TK	93	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
dfb55fdc TK	94	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
75f2543f TK	95	rstride[dim] = rs;
75f2543f TK	96
dfb55fdc	97	ub = extent[dim] - 1;
75f2543f TK	98	rs *= extent[dim];
	99	dim++;
	100	}
dfb55fdc	101	GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
75f2543f TK	102	}
	103	ret->offset = 0;
	104	if (rs > 0)
	105	ret->data = internal_malloc_size (rs * sizeof('rtype_name`));
	106	else
	107	{
	108	ret->data = internal_malloc_size (1);
	109	return;
	110	}
	111	}
	112	else
	113	{
	114	int zero_sized;
	115
	116	zero_sized = 0;
	117
	118	dim = 0;
	119	if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	120	runtime_error ("rank mismatch in spread()");
	121
9731c4a3	122	if (unlikely (compile_options.bounds_check))
75f2543f TK	123	{
	124	for (n = 0; n < rrank; n++)
	125	{
	126	index_type ret_extent;
	127
dfb55fdc	128	ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
75f2543f TK	129	if (n == along - 1)
75f2543f TK	130	{
dfb55fdc	131	rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	132
	133	if (ret_extent != ncopies)
	134	runtime_error("Incorrect extent in return value of SPREAD"
	135	" intrinsic in dimension %ld: is %ld,"
	136	" should be %ld", (long int) n+1,
	137	(long int) ret_extent, (long int) ncopies);
	138	}
	139	else
	140	{
	141	count[dim] = 0;
dfb55fdc	142	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
75f2543f TK	143	if (ret_extent != extent[dim])
	144	runtime_error("Incorrect extent in return value of SPREAD"
	145	" intrinsic in dimension %ld: is %ld,"
	146	" should be %ld", (long int) n+1,
	147	(long int) ret_extent,
	148	(long int) extent[dim]);
	149
	150	if (extent[dim] <= 0)
	151	zero_sized = 1;
dfb55fdc TK	152	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
dfb55fdc TK	153	rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	154	dim++;
	155	}
	156	}
	157	}
	158	else
	159	{
	160	for (n = 0; n < rrank; n++)
	161	{
	162	if (n == along - 1)
	163	{
dfb55fdc	164	rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	165	}
	166	else
	167	{
	168	count[dim] = 0;
dfb55fdc	169	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
75f2543f TK	170	if (extent[dim] <= 0)
75f2543f TK	171	zero_sized = 1;
dfb55fdc TK	172	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
dfb55fdc TK	173	rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
75f2543f TK	174	dim++;
	175	}
	176	}
	177	}
	178
	179	if (zero_sized)
	180	return;
	181
	182	if (sstride[0] == 0)
	183	sstride[0] = 1;
	184	}
	185	sstride0 = sstride[0];
	186	rstride0 = rstride[0];
	187	rptr = ret->data;
	188	sptr = source->data;
	189
	190	while (sptr)
	191	{
	192	/* Spread this element. */
	193	dest = rptr;
	194	for (n = 0; n < ncopies; n++)
	195	{
	196	dest = sptr;
	197	dest += rdelta;
	198	}
	199	/* Advance to the next element. */
	200	sptr += sstride0;
	201	rptr += rstride0;
	202	count[0]++;
	203	n = 0;
	204	while (count[n] == extent[n])
	205	{
	206	/* When we get to the end of a dimension, reset it and increment
	207	the next dimension. */
	208	count[n] = 0;
	209	/* We could precalculate these products, but this is a less
	210	frequently used path so probably not worth it. */
	211	sptr -= sstride[n] * extent[n];
	212	rptr -= rstride[n] * extent[n];
	213	n++;
	214	if (n >= srank)
	215	{
	216	/* Break out of the loop. */
	217	sptr = NULL;
	218	break;
	219	}
	220	else
	221	{
	222	count[n]++;
	223	sptr += sstride[n];
	224	rptr += rstride[n];
	225	}
	226	}
	227	}
	228	}
	229
	230	/* This version of spread_internal treats the special case of a scalar
	231	source. This is much simpler than the more general case above. */
	232
	233	void
	234	spread_scalar_'rtype_code` ('rtype` ret, const 'rtype_name` source,
	235	const index_type along, const index_type pncopies)
	236	{
	237	int n;
238	int ncopies = pncopies;
5863aacf	239	'rtype_name` * restrict dest;
75f2543f TK	240	index_type stride;
	241
	242	if (GFC_DESCRIPTOR_RANK (ret) != 1)
	243	runtime_error ("incorrect destination rank in spread()");
	244
	245	if (along > 1)
	246	runtime_error ("dim outside of rank in spread()");
	247
	248	if (ret->data == NULL)
	249	{
	250	ret->data = internal_malloc_size (ncopies * sizeof ('rtype_name`));
	251	ret->offset = 0;
dfb55fdc	252	GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
75f2543f TK	253	}
	254	else
	255	{
dfb55fdc TK	256	if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
dfb55fdc TK	257	/ GFC_DESCRIPTOR_STRIDE(ret,0))
75f2543f TK	258	runtime_error ("dim too large in spread()");
	259	}
	260
	261	dest = ret->data;
dfb55fdc	262	stride = GFC_DESCRIPTOR_STRIDE(ret,0);
75f2543f TK	263
	264	for (n = 0; n < ncopies; n++)
	265	{
	266	dest = source;
	267	dest += stride;
	268	}
	269	}
	270
	271	#endif
	272	'