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

/* Generic implementation of the SPREAD intrinsic
   Copyright 2002, 2005, 2006, 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>

static void
spread_internal (gfc_array_char *ret, const gfc_array_char *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;
  char *rptr;
  char *dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type srank;
  const char *sptr;

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

  size = GFC_DESCRIPTOR_SIZE(source);

  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)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */

      size_t ub, stride;

      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 * size;
	      rs *= ncopies;
	    }
	  else
	    {
	      count[dim] = 0;
	      extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
	      sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
	      rstride[dim] = rs * size;

	      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 * size);
      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 (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_BYTES(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_BYTES(source,dim);
		  rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
		  dim++;
		}
	    }
	}
      else
	{
	  for (n = 0; n < rrank; n++)
	    {
	      if (n == *along - 1)
		{
		  rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(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_BYTES(source,dim);
		  rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
		  dim++;
		}
	    }
	}

      if (zero_sized)
	return;

      if (sstride[0] == 0)
	sstride[0] = size;
    }
  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++)
        {
          memcpy (dest, sptr, size);
          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.  */

static void
spread_internal_scalar (gfc_array_char *ret, const char *source,
			const index_type *along, const index_type *pncopies)
{
  int n;
  int ncopies = *pncopies;
  char * dest;
  size_t size;

  size = GFC_DESCRIPTOR_SIZE(ret);

  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 * size);
      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()");
    }

  for (n = 0; n < ncopies; n++)
    {
      dest = (char*)(ret->data + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
      memcpy (dest , source, size);
    }
}

extern void spread (gfc_array_char *, const gfc_array_char *,
		    const index_type *, const index_type *);
export_proto(spread);

void
spread (gfc_array_char *ret, const gfc_array_char *source,
	const index_type *along, const index_type *pncopies)
{
  index_type type_size;

  type_size = GFC_DTYPE_TYPE_SIZE(ret);
  switch(type_size)
    {
    case GFC_DTYPE_DERIVED_1:
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
      spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
		 *along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
		 *along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
		 *along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
		 *along, *pncopies);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
		 *along, *pncopies);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
		 *along, *pncopies);
      return;

    case GFC_DTYPE_REAL_8:
      spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
		 *along, *pncopies);
      return;

#ifdef GFC_HAVE_REAL_10
    case GFC_DTYPE_REAL_10:
      spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
		 *along, *pncopies);
      return;
#endif

#ifdef GFC_HAVE_REAL_16
    case GFC_DTYPE_REAL_16:
      spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
		 *along, *pncopies);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
		 *along, *pncopies);
      return;

    case GFC_DTYPE_COMPLEX_8:
      spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
		 *along, *pncopies);
      return;

#ifdef GFC_HAVE_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
		 *along, *pncopies);
      return;
#endif

#ifdef GFC_HAVE_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
		 *along, *pncopies);
      return;
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source->data))
	break;
      else
	{
	  spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
		     *along, *pncopies);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source->data))
	break;
      else
	{
	  spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
		     *along, *pncopies);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source->data))
	break;
      else
	{
	  spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
		     *along, *pncopies);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source->data))
	break;
      else
	{
	  spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
		      *along, *pncopies);
	  return;
	}
#endif
    }

  spread_internal (ret, source, along, pncopies);
}


extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
			 const gfc_array_char *, const index_type *,
			 const index_type *, GFC_INTEGER_4);
export_proto(spread_char);

void
spread_char (gfc_array_char *ret,
	     GFC_INTEGER_4 ret_length __attribute__((unused)),
	     const gfc_array_char *source, const index_type *along,
	     const index_type *pncopies,
	     GFC_INTEGER_4 source_length __attribute__((unused)))
{
  spread_internal (ret, source, along, pncopies);
}


extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
			  const gfc_array_char *, const index_type *,
			  const index_type *, GFC_INTEGER_4);
export_proto(spread_char4);

void
spread_char4 (gfc_array_char *ret,
	      GFC_INTEGER_4 ret_length __attribute__((unused)),
	      const gfc_array_char *source, const index_type *along,
	      const index_type *pncopies,
	      GFC_INTEGER_4 source_length __attribute__((unused)))
{
  spread_internal (ret, source, along, pncopies);
}


/* The following are the prototypes for the versions of spread with a
   scalar source.  */

extern void spread_scalar (gfc_array_char *, const char *,
			   const index_type *, const index_type *);
export_proto(spread_scalar);

void
spread_scalar (gfc_array_char *ret, const char *source,
	       const index_type *along, const index_type *pncopies)
{
  index_type type_size;

  if (!ret->dtype)
    runtime_error ("return array missing descriptor in spread()");

  type_size = GFC_DTYPE_TYPE_SIZE(ret);
  switch(type_size)
    {
    case GFC_DTYPE_DERIVED_1:
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
      spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
			*along, *pncopies);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
			*along, *pncopies);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_REAL_8:
      spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
			*along, *pncopies);
      return;

#ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
			*along, *pncopies);
      return;
#endif

#ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
			*along, *pncopies);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_COMPLEX_8:
      spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
			*along, *pncopies);
      return;

#ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
			*along, *pncopies);
      return;
#endif

#ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
			*along, *pncopies);
      return;
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source))
	break;
      else
	{
	  spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
			    *along, *pncopies);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source))
	break;
      else
	{
	  spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
			    *along, *pncopies);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source))
	break;
      else
	{
	  spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
			    *along, *pncopies);
	  return;
	}
#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source))
	break;
      else
	{
	  spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
			     *along, *pncopies);
	  return;
	}
#endif
    }

  spread_internal_scalar (ret, source, along, pncopies);
}


extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
				const char *, const index_type *,
				const index_type *, GFC_INTEGER_4);
export_proto(spread_char_scalar);

void
spread_char_scalar (gfc_array_char *ret,
		    GFC_INTEGER_4 ret_length __attribute__((unused)),
		    const char *source, const index_type *along,
		    const index_type *pncopies,
		    GFC_INTEGER_4 source_length __attribute__((unused)))
{
  if (!ret->dtype)
    runtime_error ("return array missing descriptor in spread()");
  spread_internal_scalar (ret, source, along, pncopies);
}


extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
				 const char *, const index_type *,
				 const index_type *, GFC_INTEGER_4);
export_proto(spread_char4_scalar);

void
spread_char4_scalar (gfc_array_char *ret,
		     GFC_INTEGER_4 ret_length __attribute__((unused)),
		     const char *source, const index_type *along,
		     const index_type *pncopies,
		     GFC_INTEGER_4 source_length __attribute__((unused)))
{
  if (!ret->dtype)
    runtime_error ("return array missing descriptor in spread()");
  spread_internal_scalar (ret, source, along, pncopies);

}
Commit	Line	Data
7f68c75f	1	/* Generic implementation of the SPREAD intrinsic
748086b7	2	Copyright 2002, 2005, 2006, 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
7823229b RS	31	static void
7823229b RS	32	spread_internal (gfc_array_char ret, const gfc_array_char source,
dfb55fdc	33	const index_type along, const index_type pncopies)
6de9cd9a DN	34	{
6de9cd9a DN	35	/* r.* indicates the return array. */
e33e218b	36	index_type rstride[GFC_MAX_DIMENSIONS];
6de9cd9a	37	index_type rstride0;
7672ae20	38	index_type rdelta = 0;
8e6d7b8a TK	39	index_type rrank;
8e6d7b8a TK	40	index_type rs;
6de9cd9a DN	41	char *rptr;
	42	char *dest;
	43	/* s.* indicates the source array. */
e33e218b	44	index_type sstride[GFC_MAX_DIMENSIONS];
6de9cd9a	45	index_type sstride0;
8e6d7b8a	46	index_type srank;
6de9cd9a DN	47	const char *sptr;
6de9cd9a DN	48
e33e218b TK	49	index_type count[GFC_MAX_DIMENSIONS];
e33e218b TK	50	index_type extent[GFC_MAX_DIMENSIONS];
6de9cd9a DN	51	index_type n;
6de9cd9a DN	52	index_type dim;
6de9cd9a	53	index_type ncopies;
dfb55fdc TK	54	index_type size;
	55
	56	size = GFC_DESCRIPTOR_SIZE(source);
6de9cd9a	57
8e6d7b8a TK	58	srank = GFC_DESCRIPTOR_RANK(source);
	59
	60	rrank = srank + 1;
	61	if (rrank > GFC_MAX_DIMENSIONS)
	62	runtime_error ("return rank too large in spread()");
	63
	64	if (*along > rrank)
	65	runtime_error ("dim outside of rank in spread()");
	66
	67	ncopies = *pncopies;
	68
8e6d7b8a	69	if (ret->data == NULL)
6de9cd9a	70	{
8e6d7b8a TK	71	/* The front end has signalled that we need to populate the
8e6d7b8a TK	72	return array descriptor. */
dfb55fdc TK	73
	74	size_t ub, stride;
	75
8e6d7b8a TK	76	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rrank;
	77	dim = 0;
	78	rs = 1;
	79	for (n = 0; n < rrank; n++)
	80	{
dfb55fdc	81	stride = rs;
8e6d7b8a TK	82	if (n == *along - 1)
8e6d7b8a TK	83	{
dfb55fdc	84	ub = ncopies - 1;
8e6d7b8a TK	85	rdelta = rs * size;
	86	rs *= ncopies;
	87	}
	88	else
	89	{
	90	count[dim] = 0;
dfb55fdc TK	91	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
dfb55fdc TK	92	sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
8e6d7b8a TK	93	rstride[dim] = rs * size;
8e6d7b8a TK	94
dfb55fdc	95	ub = extent[dim]-1;
8e6d7b8a TK	96	rs *= extent[dim];
	97	dim++;
	98	}
dfb55fdc TK	99
dfb55fdc TK	100	GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
8e6d7b8a	101	}
efd4dc1a	102	ret->offset = 0;
3d894fc3 FXC	103	if (rs > 0)
	104	ret->data = internal_malloc_size (rs * size);
	105	else
	106	{
	107	ret->data = internal_malloc_size (1);
	108	return;
	109	}
6de9cd9a	110	}
8e6d7b8a TK	111	else
8e6d7b8a TK	112	{
3cc50edc TK	113	int zero_sized;
	114
	115	zero_sized = 0;
	116
8e6d7b8a TK	117	dim = 0;
	118	if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	119	runtime_error ("rank mismatch in spread()");
6de9cd9a	120
3cc50edc	121	if (compile_options.bounds_check)
8e6d7b8a	122	{
3cc50edc	123	for (n = 0; n < rrank; n++)
8e6d7b8a	124	{
3cc50edc TK	125	index_type ret_extent;
3cc50edc TK	126
dfb55fdc	127	ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
3cc50edc TK	128	if (n == *along - 1)
3cc50edc TK	129	{
dfb55fdc	130	rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
3cc50edc TK	131
	132	if (ret_extent != ncopies)
	133	runtime_error("Incorrect extent in return value of SPREAD"
1cc0507d FXC	134	" intrinsic in dimension %ld: is %ld,"
	135	" should be %ld", (long int) n+1,
	136	(long int) ret_extent, (long int) ncopies);
3cc50edc TK	137	}
	138	else
	139	{
	140	count[dim] = 0;
dfb55fdc	141	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
3cc50edc TK	142	if (ret_extent != extent[dim])
3cc50edc TK	143	runtime_error("Incorrect extent in return value of SPREAD"
1cc0507d FXC	144	" intrinsic in dimension %ld: is %ld,"
	145	" should be %ld", (long int) n+1,
	146	(long int) ret_extent,
3cc50edc TK	147	(long int) extent[dim]);
	148
	149	if (extent[dim] <= 0)
	150	zero_sized = 1;
dfb55fdc TK	151	sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
dfb55fdc TK	152	rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
3cc50edc TK	153	dim++;
3cc50edc TK	154	}
8e6d7b8a	155	}
3cc50edc TK	156	}
	157	else
	158	{
	159	for (n = 0; n < rrank; n++)
8e6d7b8a	160	{
3cc50edc TK	161	if (n == *along - 1)
3cc50edc TK	162	{
dfb55fdc	163	rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
3cc50edc TK	164	}
	165	else
	166	{
	167	count[dim] = 0;
dfb55fdc	168	extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
3cc50edc TK	169	if (extent[dim] <= 0)
3cc50edc TK	170	zero_sized = 1;
dfb55fdc TK	171	sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
dfb55fdc TK	172	rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
3cc50edc TK	173	dim++;
3cc50edc TK	174	}
8e6d7b8a TK	175	}
8e6d7b8a TK	176	}
3cc50edc TK	177
	178	if (zero_sized)
	179	return;
	180
8e6d7b8a TK	181	if (sstride[0] == 0)
	182	sstride[0] = size;
	183	}
6de9cd9a DN	184	sstride0 = sstride[0];
	185	rstride0 = rstride[0];
	186	rptr = ret->data;
	187	sptr = source->data;
6de9cd9a DN	188
	189	while (sptr)
	190	{
	191	/* Spread this element. */
	192	dest = rptr;
	193	for (n = 0; n < ncopies; n++)
	194	{
	195	memcpy (dest, sptr, size);
	196	dest += rdelta;
	197	}
	198	/* Advance to the next element. */
	199	sptr += sstride0;
	200	rptr += rstride0;
	201	count[0]++;
	202	n = 0;
	203	while (count[n] == extent[n])
	204	{
	205	/* When we get to the end of a dimension, reset it and increment
	206	the next dimension. */
	207	count[n] = 0;
	208	/* We could precalculate these products, but this is a less
	209	frequently used path so probably not worth it. */
	210	sptr -= sstride[n] * extent[n];
	211	rptr -= rstride[n] * extent[n];
	212	n++;
8e6d7b8a	213	if (n >= srank)
6de9cd9a DN	214	{
	215	/* Break out of the loop. */
	216	sptr = NULL;
	217	break;
	218	}
	219	else
	220	{
	221	count[n]++;
	222	sptr += sstride[n];
	223	rptr += rstride[n];
	224	}
	225	}
	226	}
	227	}
7823229b	228
2853e512 PT	229	/* This version of spread_internal treats the special case of a scalar
	230	source. This is much simpler than the more general case above. */
	231
	232	static void
	233	spread_internal_scalar (gfc_array_char ret, const char source,
dfb55fdc	234	const index_type along, const index_type pncopies)
2853e512 PT	235	{
	236	int n;
	237	int ncopies = *pncopies;
	238	char * dest;
dfb55fdc TK	239	size_t size;
	240
	241	size = GFC_DESCRIPTOR_SIZE(ret);
2853e512 PT	242
	243	if (GFC_DESCRIPTOR_RANK (ret) != 1)
	244	runtime_error ("incorrect destination rank in spread()");
	245
	246	if (*along > 1)
	247	runtime_error ("dim outside of rank in spread()");
	248
	249	if (ret->data == NULL)
	250	{
	251	ret->data = internal_malloc_size (ncopies * size);
	252	ret->offset = 0;
dfb55fdc	253	GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
2853e512 PT	254	}
	255	else
	256	{
dfb55fdc TK	257	if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
dfb55fdc TK	258	/ GFC_DESCRIPTOR_STRIDE(ret,0))
2853e512 PT	259	runtime_error ("dim too large in spread()");
	260	}
	261
	262	for (n = 0; n < ncopies; n++)
	263	{
dfb55fdc	264	dest = (char)(ret->data + n GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
2853e512 PT	265	memcpy (dest , source, size);
	266	}
	267	}
	268
7823229b RS	269	extern void spread (gfc_array_char , const gfc_array_char ,
	270	const index_type , const index_type );
	271	export_proto(spread);
	272
	273	void
	274	spread (gfc_array_char ret, const gfc_array_char source,
	275	const index_type along, const index_type pncopies)
	276	{
75f2543f TK	277	index_type type_size;
	278
	279	type_size = GFC_DTYPE_TYPE_SIZE(ret);
	280	switch(type_size)
	281	{
c7d0f4d5	282	case GFC_DTYPE_DERIVED_1:
75f2543f TK	283	case GFC_DTYPE_LOGICAL_1:
	284	case GFC_DTYPE_INTEGER_1:
	285	spread_i1 ((gfc_array_i1 ) ret, (gfc_array_i1 ) source,
	286	along, pncopies);
	287	return;
	288
	289	case GFC_DTYPE_LOGICAL_2:
	290	case GFC_DTYPE_INTEGER_2:
	291	spread_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) source,
	292	along, pncopies);
	293	return;
	294
	295	case GFC_DTYPE_LOGICAL_4:
	296	case GFC_DTYPE_INTEGER_4:
	297	spread_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) source,
	298	along, pncopies);
	299	return;
	300
	301	case GFC_DTYPE_LOGICAL_8:
	302	case GFC_DTYPE_INTEGER_8:
	303	spread_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) source,
	304	along, pncopies);
	305	return;
	306
	307	#ifdef HAVE_GFC_INTEGER_16
	308	case GFC_DTYPE_LOGICAL_16:
	309	case GFC_DTYPE_INTEGER_16:
	310	spread_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) source,
	311	along, pncopies);
	312	return;
	313	#endif
	314
	315	case GFC_DTYPE_REAL_4:
	316	spread_r4 ((gfc_array_r4 ) ret, (gfc_array_r4 ) source,
	317	along, pncopies);
	318	return;
	319
	320	case GFC_DTYPE_REAL_8:
	321	spread_r8 ((gfc_array_r8 ) ret, (gfc_array_r8 ) source,
	322	along, pncopies);
	323	return;
	324
	325	#ifdef GFC_HAVE_REAL_10
	326	case GFC_DTYPE_REAL_10:
	327	spread_r10 ((gfc_array_r10 ) ret, (gfc_array_r10 ) source,
	328	along, pncopies);
	329	return;
	330	#endif
	331
	332	#ifdef GFC_HAVE_REAL_16
	333	case GFC_DTYPE_REAL_16:
	334	spread_r16 ((gfc_array_r16 ) ret, (gfc_array_r16 ) source,
	335	along, pncopies);
	336	return;
	337	#endif
	338
	339	case GFC_DTYPE_COMPLEX_4:
	340	spread_c4 ((gfc_array_c4 ) ret, (gfc_array_c4 ) source,
	341	along, pncopies);
	342	return;
	343
	344	case GFC_DTYPE_COMPLEX_8:
	345	spread_c8 ((gfc_array_c8 ) ret, (gfc_array_c8 ) source,
	346	along, pncopies);
347	return;
348
349	#ifdef GFC_HAVE_COMPLEX_10
350	case GFC_DTYPE_COMPLEX_10:
351	spread_c10 ((gfc_array_c10 ) ret, (gfc_array_c10 ) source,
352	along, pncopies);
353	return;
354	#endif
355
356	#ifdef GFC_HAVE_COMPLEX_16
357	case GFC_DTYPE_COMPLEX_16:
358	spread_c16 ((gfc_array_c16 ) ret, (gfc_array_c16 ) source,
359	along, pncopies);
360	return;
361	#endif
362
c7d0f4d5 TK	363	case GFC_DTYPE_DERIVED_2:
	364	if (GFC_UNALIGNED_2(ret->data) \|\| GFC_UNALIGNED_2(source->data))
	365	break;
	366	else
	367	{
3a5a8be1	368	spread_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) source,
c7d0f4d5 TK	369	along, pncopies);
	370	return;
	371	}
	372
	373	case GFC_DTYPE_DERIVED_4:
	374	if (GFC_UNALIGNED_4(ret->data) \|\| GFC_UNALIGNED_4(source->data))
	375	break;
	376	else
	377	{
	378	spread_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) source,
	379	along, pncopies);
	380	return;
	381	}
	382
	383	case GFC_DTYPE_DERIVED_8:
	384	if (GFC_UNALIGNED_8(ret->data) \|\| GFC_UNALIGNED_8(source->data))
	385	break;
	386	else
	387	{
	388	spread_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) source,
	389	along, pncopies);
	390	return;
	391	}
	392
	393	#ifdef HAVE_GFC_INTEGER_16
	394	case GFC_DTYPE_DERIVED_16:
	395	if (GFC_UNALIGNED_16(ret->data) \|\| GFC_UNALIGNED_16(source->data))
	396	break;
	397	else
	398	{
	399	spread_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) source,
	400	along, pncopies);
	401	return;
	402	}
	403	#endif
75f2543f	404	}
c7d0f4d5	405
dfb55fdc	406	spread_internal (ret, source, along, pncopies);
7823229b RS	407	}
7823229b RS	408
3571925e	409
7823229b RS	410	extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
	411	const gfc_array_char , const index_type ,
	412	const index_type *, GFC_INTEGER_4);
	413	export_proto(spread_char);
	414
	415	void
	416	spread_char (gfc_array_char *ret,
	417	GFC_INTEGER_4 ret_length __attribute__((unused)),
	418	const gfc_array_char source, const index_type along,
dfb55fdc TK	419	const index_type *pncopies,
dfb55fdc TK	420	GFC_INTEGER_4 source_length __attribute__((unused)))
7823229b	421	{
dfb55fdc	422	spread_internal (ret, source, along, pncopies);
7823229b	423	}
2853e512	424
3571925e FXC	425
	426	extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
	427	const gfc_array_char , const index_type ,
	428	const index_type *, GFC_INTEGER_4);
	429	export_proto(spread_char4);
	430
	431	void
	432	spread_char4 (gfc_array_char *ret,
	433	GFC_INTEGER_4 ret_length __attribute__((unused)),
	434	const gfc_array_char source, const index_type along,
dfb55fdc TK	435	const index_type *pncopies,
dfb55fdc TK	436	GFC_INTEGER_4 source_length __attribute__((unused)))
3571925e	437	{
dfb55fdc	438	spread_internal (ret, source, along, pncopies);
3571925e FXC	439	}
	440
	441
2853e512 PT	442	/* The following are the prototypes for the versions of spread with a
	443	scalar source. */
	444
	445	extern void spread_scalar (gfc_array_char , const char ,
	446	const index_type , const index_type );
	447	export_proto(spread_scalar);
	448
	449	void
	450	spread_scalar (gfc_array_char ret, const char source,
	451	const index_type along, const index_type pncopies)
	452	{
75f2543f TK	453	index_type type_size;
75f2543f TK	454
2853e512 PT	455	if (!ret->dtype)
2853e512 PT	456	runtime_error ("return array missing descriptor in spread()");
75f2543f TK	457
	458	type_size = GFC_DTYPE_TYPE_SIZE(ret);
	459	switch(type_size)
	460	{
c7d0f4d5	461	case GFC_DTYPE_DERIVED_1:
75f2543f TK	462	case GFC_DTYPE_LOGICAL_1:
	463	case GFC_DTYPE_INTEGER_1:
	464	spread_scalar_i1 ((gfc_array_i1 ) ret, (GFC_INTEGER_1 ) source,
	465	along, pncopies);
	466	return;
	467
	468	case GFC_DTYPE_LOGICAL_2:
	469	case GFC_DTYPE_INTEGER_2:
	470	spread_scalar_i2 ((gfc_array_i2 ) ret, (GFC_INTEGER_2 ) source,
	471	along, pncopies);
	472	return;
	473
	474	case GFC_DTYPE_LOGICAL_4:
	475	case GFC_DTYPE_INTEGER_4:
	476	spread_scalar_i4 ((gfc_array_i4 ) ret, (GFC_INTEGER_4 ) source,
	477	along, pncopies);
	478	return;
	479
	480	case GFC_DTYPE_LOGICAL_8:
	481	case GFC_DTYPE_INTEGER_8:
	482	spread_scalar_i8 ((gfc_array_i8 ) ret, (GFC_INTEGER_8 ) source,
	483	along, pncopies);
	484	return;
	485
	486	#ifdef HAVE_GFC_INTEGER_16
	487	case GFC_DTYPE_LOGICAL_16:
	488	case GFC_DTYPE_INTEGER_16:
	489	spread_scalar_i16 ((gfc_array_i16 ) ret, (GFC_INTEGER_16 ) source,
	490	along, pncopies);
	491	return;
	492	#endif
	493
	494	case GFC_DTYPE_REAL_4:
	495	spread_scalar_r4 ((gfc_array_r4 ) ret, (GFC_REAL_4 ) source,
	496	along, pncopies);
	497	return;
	498
	499	case GFC_DTYPE_REAL_8:
	500	spread_scalar_r8 ((gfc_array_r8 ) ret, (GFC_REAL_8 ) source,
	501	along, pncopies);
	502	return;
	503
	504	#ifdef HAVE_GFC_REAL_10
	505	case GFC_DTYPE_REAL_10:
	506	spread_scalar_r10 ((gfc_array_r10 ) ret, (GFC_REAL_10 ) source,
	507	along, pncopies);
	508	return;
	509	#endif
	510
	511	#ifdef HAVE_GFC_REAL_16
	512	case GFC_DTYPE_REAL_16:
	513	spread_scalar_r16 ((gfc_array_r16 ) ret, (GFC_REAL_16 ) source,
	514	along, pncopies);
	515	return;
	516	#endif
	517
	518	case GFC_DTYPE_COMPLEX_4:
	519	spread_scalar_c4 ((gfc_array_c4 ) ret, (GFC_COMPLEX_4 ) source,
	520	along, pncopies);
	521	return;
	522
	523	case GFC_DTYPE_COMPLEX_8:
	524	spread_scalar_c8 ((gfc_array_c8 ) ret, (GFC_COMPLEX_8 ) source,
	525	along, pncopies);
526	return;
527
528	#ifdef HAVE_GFC_COMPLEX_10
529	case GFC_DTYPE_COMPLEX_10:
530	spread_scalar_c10 ((gfc_array_c10 ) ret, (GFC_COMPLEX_10 ) source,
531	along, pncopies);
532	return;
533	#endif
534
535	#ifdef HAVE_GFC_COMPLEX_16
536	case GFC_DTYPE_COMPLEX_16:
537	spread_scalar_c16 ((gfc_array_c16 ) ret, (GFC_COMPLEX_16 ) source,
538	along, pncopies);
539	return;
540	#endif
541
c7d0f4d5 TK	542	case GFC_DTYPE_DERIVED_2:
	543	if (GFC_UNALIGNED_2(ret->data) \|\| GFC_UNALIGNED_2(source))
	544	break;
	545	else
	546	{
	547	spread_scalar_i2 ((gfc_array_i2 ) ret, (GFC_INTEGER_2 ) source,
	548	along, pncopies);
	549	return;
	550	}
	551
	552	case GFC_DTYPE_DERIVED_4:
	553	if (GFC_UNALIGNED_4(ret->data) \|\| GFC_UNALIGNED_4(source))
	554	break;
	555	else
	556	{
	557	spread_scalar_i4 ((gfc_array_i4 ) ret, (GFC_INTEGER_4 ) source,
	558	along, pncopies);
	559	return;
	560	}
	561
	562	case GFC_DTYPE_DERIVED_8:
	563	if (GFC_UNALIGNED_8(ret->data) \|\| GFC_UNALIGNED_8(source))
	564	break;
	565	else
	566	{
	567	spread_scalar_i8 ((gfc_array_i8 ) ret, (GFC_INTEGER_8 ) source,
	568	along, pncopies);
	569	return;
	570	}
	571	#ifdef HAVE_GFC_INTEGER_16
	572	case GFC_DTYPE_DERIVED_16:
	573	if (GFC_UNALIGNED_16(ret->data) \|\| GFC_UNALIGNED_16(source))
	574	break;
	575	else
	576	{
	577	spread_scalar_i16 ((gfc_array_i16 ) ret, (GFC_INTEGER_16 ) source,
	578	along, pncopies);
	579	return;
	580	}
	581	#endif
75f2543f TK	582	}
75f2543f TK	583
dfb55fdc	584	spread_internal_scalar (ret, source, along, pncopies);
2853e512 PT	585	}
	586
	587
	588	extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
	589	const char , const index_type ,
	590	const index_type *, GFC_INTEGER_4);
	591	export_proto(spread_char_scalar);
	592
	593	void
	594	spread_char_scalar (gfc_array_char *ret,
	595	GFC_INTEGER_4 ret_length __attribute__((unused)),
	596	const char source, const index_type along,
dfb55fdc TK	597	const index_type *pncopies,
dfb55fdc TK	598	GFC_INTEGER_4 source_length __attribute__((unused)))
2853e512 PT	599	{
	600	if (!ret->dtype)
	601	runtime_error ("return array missing descriptor in spread()");
dfb55fdc	602	spread_internal_scalar (ret, source, along, pncopies);
2853e512 PT	603	}
2853e512 PT	604
3571925e FXC	605
	606	extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
	607	const char , const index_type ,
	608	const index_type *, GFC_INTEGER_4);
	609	export_proto(spread_char4_scalar);
	610
	611	void
	612	spread_char4_scalar (gfc_array_char *ret,
	613	GFC_INTEGER_4 ret_length __attribute__((unused)),
	614	const char source, const index_type along,
dfb55fdc TK	615	const index_type *pncopies,
dfb55fdc TK	616	GFC_INTEGER_4 source_length __attribute__((unused)))
3571925e FXC	617	{
	618	if (!ret->dtype)
	619	runtime_error ("return array missing descriptor in spread()");
dfb55fdc TK	620	spread_internal_scalar (ret, source, along, pncopies);
dfb55fdc TK	621
3571925e FXC	622	}
3571925e FXC	623