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

      /* internal_malloc_size allocates a single byte for zero size.  */
      ret->data = internal_malloc_size (rs * sizeof('rtype_name`));
      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->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
b74d1e69	1	`/* Special implementation of the SPREAD intrinsic
6bc9506f	2	Copyright 2008, 2009 Free Software Foundation, Inc.
b74d1e69	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
6bc9506f	11	version 3 of the License, or (at your option) any later version.
b74d1e69	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
6bc9506f	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/>. */
b74d1e69	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;
9d259edf	47	'rtype_name` * restrict dest;
b74d1e69	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	{
827aef63	73
	74	size_t ub, stride;
	75
b74d1e69	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	{
827aef63	83	stride = rs;
b74d1e69	84	if (n == along - 1)
b74d1e69	85	{
827aef63	86	ub = ncopies - 1;
b74d1e69	87	rdelta = rs;
	88	rs *= ncopies;
	89	}
	90	else
	91	{
	92	count[dim] = 0;
827aef63	93	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
827aef63	94	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
b74d1e69	95	rstride[dim] = rs;
b74d1e69	96
827aef63	97	ub = extent[dim] - 1;
b74d1e69	98	rs *= extent[dim];
	99	dim++;
	100	}
827aef63	101	GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
b74d1e69	102	}
b74d1e69	103	ret->offset = 0;
0248e4c1	104
	105	/* internal_malloc_size allocates a single byte for zero size. */
	106	ret->data = internal_malloc_size (rs * sizeof('rtype_name`));
	107	if (rs <= 0)
	108	return;
b74d1e69	109	}
	110	else
	111	{
	112	int zero_sized;
	113
	114	zero_sized = 0;
	115
	116	dim = 0;
	117	if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	118	runtime_error ("rank mismatch in spread()");
	119
c7fb575f	120	if (unlikely (compile_options.bounds_check))
b74d1e69	121	{
	122	for (n = 0; n < rrank; n++)
	123	{
	124	index_type ret_extent;
	125
827aef63	126	ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
b74d1e69	127	if (n == along - 1)
b74d1e69	128	{
827aef63	129	rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
b74d1e69	130
	131	if (ret_extent != ncopies)
	132	runtime_error("Incorrect extent in return value of SPREAD"
	133	" intrinsic in dimension %ld: is %ld,"
	134	" should be %ld", (long int) n+1,
	135	(long int) ret_extent, (long int) ncopies);
	136	}
	137	else
	138	{
	139	count[dim] = 0;
827aef63	140	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
b74d1e69	141	if (ret_extent != extent[dim])
	142	runtime_error("Incorrect extent in return value of SPREAD"
	143	" intrinsic in dimension %ld: is %ld,"
	144	" should be %ld", (long int) n+1,
	145	(long int) ret_extent,
	146	(long int) extent[dim]);
	147
	148	if (extent[dim] <= 0)
	149	zero_sized = 1;
827aef63	150	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
827aef63	151	rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
b74d1e69	152	dim++;
	153	}
	154	}
	155	}
	156	else
	157	{
	158	for (n = 0; n < rrank; n++)
	159	{
	160	if (n == along - 1)
	161	{
827aef63	162	rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
b74d1e69	163	}
	164	else
	165	{
	166	count[dim] = 0;
827aef63	167	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
b74d1e69	168	if (extent[dim] <= 0)
b74d1e69	169	zero_sized = 1;
827aef63	170	sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
827aef63	171	rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
b74d1e69	172	dim++;
	173	}
	174	}
	175	}
	176
	177	if (zero_sized)
	178	return;
	179
	180	if (sstride[0] == 0)
	181	sstride[0] = 1;
	182	}
	183	sstride0 = sstride[0];
	184	rstride0 = rstride[0];
	185	rptr = ret->data;
	186	sptr = source->data;
	187
	188	while (sptr)
	189	{
	190	/* Spread this element. */
	191	dest = rptr;
	192	for (n = 0; n < ncopies; n++)
	193	{
	194	dest = sptr;
	195	dest += rdelta;
	196	}
	197	/* Advance to the next element. */
	198	sptr += sstride0;
	199	rptr += rstride0;
	200	count[0]++;
	201	n = 0;
	202	while (count[n] == extent[n])
	203	{
	204	/* When we get to the end of a dimension, reset it and increment
	205	the next dimension. */
	206	count[n] = 0;
	207	/* We could precalculate these products, but this is a less
	208	frequently used path so probably not worth it. */
	209	sptr -= sstride[n] * extent[n];
	210	rptr -= rstride[n] * extent[n];
	211	n++;
	212	if (n >= srank)
	213	{
	214	/* Break out of the loop. */
	215	sptr = NULL;
	216	break;
	217	}
	218	else
	219	{
	220	count[n]++;
	221	sptr += sstride[n];
	222	rptr += rstride[n];
	223	}
	224	}
	225	}
	226	}
	227
	228	/* This version of spread_internal treats the special case of a scalar
	229	source. This is much simpler than the more general case above. */
	230
	231	void
	232	spread_scalar_'rtype_code` ('rtype` ret, const 'rtype_name` source,
	233	const index_type along, const index_type pncopies)
	234	{
	235	int n;
236	int ncopies = pncopies;
9d259edf	237	'rtype_name` * restrict dest;
b74d1e69	238	index_type stride;
	239
	240	if (GFC_DESCRIPTOR_RANK (ret) != 1)
	241	runtime_error ("incorrect destination rank in spread()");
	242
	243	if (along > 1)
	244	runtime_error ("dim outside of rank in spread()");
	245
	246	if (ret->data == NULL)
	247	{
	248	ret->data = internal_malloc_size (ncopies * sizeof ('rtype_name`));
	249	ret->offset = 0;
827aef63	250	GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
b74d1e69	251	}
	252	else
	253	{
827aef63	254	if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
827aef63	255	/ GFC_DESCRIPTOR_STRIDE(ret,0))
b74d1e69	256	runtime_error ("dim too large in spread()");
	257	}
	258
	259	dest = ret->data;
827aef63	260	stride = GFC_DESCRIPTOR_STRIDE(ret,0);
b74d1e69	261
	262	for (n = 0; n < ncopies; n++)
	263	{
	264	dest = source;
	265	dest += stride;
	266	}
	267	}
	268
	269	#endif
	270	'