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

/* Generic implementation of the SPREAD intrinsic
   Copyright 2002, 2005, 2006, 2007 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#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,
		 index_type size)
{
  /* 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;

  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.  */
      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
      dim = 0;
      rs = 1;
      for (n = 0; n < rrank; n++)
	{
	  ret->dim[n].stride = rs;
	  ret->dim[n].lbound = 0;
	  if (n == *along - 1)
	    {
	      ret->dim[n].ubound = ncopies - 1;
	      rdelta = rs * size;
	      rs *= ncopies;
	    }
	  else
	    {
	      count[dim] = 0;
	      extent[dim] = source->dim[dim].ubound + 1
		- source->dim[dim].lbound;
	      sstride[dim] = source->dim[dim].stride * size;
	      rstride[dim] = rs * size;

	      ret->dim[n].ubound = extent[dim]-1;
	      rs *= extent[dim];
	      dim++;
	    }
	}
      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 = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	      if (n == *along - 1)
		{
		  rdelta = ret->dim[n].stride * size;

		  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] = source->dim[dim].ubound + 1
		    - source->dim[dim].lbound;
		  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] = source->dim[dim].stride * size;
		  rstride[dim] = ret->dim[n].stride * size;
		  dim++;
		}
	    }
	}
      else
	{
	  for (n = 0; n < rrank; n++)
	    {
	      if (n == *along - 1)
		{
		  rdelta = ret->dim[n].stride * size;
		}
	      else
		{
		  count[dim] = 0;
		  extent[dim] = source->dim[dim].ubound + 1
		    - source->dim[dim].lbound;
		  if (extent[dim] <= 0)
		    zero_sized = 1;
		  sstride[dim] = source->dim[dim].stride * size;
		  rstride[dim] = ret->dim[n].stride * size;
		  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,
			index_type size)
{
  int n;
  int ncopies = *pncopies;
  char * dest;

  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;
      ret->dim[0].stride = 1;
      ret->dim[0].lbound = 0;
      ret->dim[0].ubound = ncopies - 1;
    }
  else
    {
      if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
			   / ret->dim[0].stride)
	runtime_error ("dim too large in spread()");
    }

  for (n = 0; n < ncopies; n++)
    {
      dest = (char*)(ret->data + n*size*ret->dim[0].stride);
      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_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) 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, GFC_DESCRIPTOR_SIZE (source));
}

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)
{
  spread_internal (ret, source, along, pncopies, source_length);
}

/* 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, GFC_DESCRIPTOR_SIZE (ret));
}


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)
{
  if (!ret->dtype)
    runtime_error ("return array missing descriptor in spread()");
  spread_internal_scalar (ret, source, along, pncopies, source_length);
}
Commit	Line	Data
7f68c75f	1	/* Generic implementation of the SPREAD intrinsic
36ae8a61	2	Copyright 2002, 2005, 2006, 2007 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
57dea9f6	10	version 2 of the License, or (at your option) any later version.
6de9cd9a	11
57dea9f6 TM	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
	20
	21	Ligbfortran is distributed in the hope that it will be useful,
6de9cd9a DN	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
6de9cd9a DN	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
57dea9f6	24	GNU General Public License for more details.
6de9cd9a	25
57dea9f6 TM	26	You should have received a copy of the GNU General Public
57dea9f6 TM	27	License along with libgfortran; see the file COPYING. If not,
fe2ae685 KC	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
fe2ae685 KC	29	Boston, MA 02110-1301, USA. */
6de9cd9a	30
36ae8a61	31	#include "libgfortran.h"
6de9cd9a DN	32	#include <stdlib.h>
	33	#include <assert.h>
	34	#include <string.h>
6de9cd9a	35
7823229b RS	36	static void
	37	spread_internal (gfc_array_char ret, const gfc_array_char source,
	38	const index_type along, const index_type pncopies,
	39	index_type size)
6de9cd9a DN	40	{
6de9cd9a DN	41	/* r.* indicates the return array. */
e33e218b	42	index_type rstride[GFC_MAX_DIMENSIONS];
6de9cd9a	43	index_type rstride0;
7672ae20	44	index_type rdelta = 0;
8e6d7b8a TK	45	index_type rrank;
8e6d7b8a TK	46	index_type rs;
6de9cd9a DN	47	char *rptr;
	48	char *dest;
	49	/* s.* indicates the source array. */
e33e218b	50	index_type sstride[GFC_MAX_DIMENSIONS];
6de9cd9a	51	index_type sstride0;
8e6d7b8a	52	index_type srank;
6de9cd9a DN	53	const char *sptr;
6de9cd9a DN	54
e33e218b TK	55	index_type count[GFC_MAX_DIMENSIONS];
e33e218b TK	56	index_type extent[GFC_MAX_DIMENSIONS];
6de9cd9a DN	57	index_type n;
6de9cd9a DN	58	index_type dim;
6de9cd9a DN	59	index_type ncopies;
6de9cd9a DN	60
8e6d7b8a TK	61	srank = GFC_DESCRIPTOR_RANK(source);
	62
	63	rrank = srank + 1;
	64	if (rrank > GFC_MAX_DIMENSIONS)
	65	runtime_error ("return rank too large in spread()");
	66
	67	if (*along > rrank)
	68	runtime_error ("dim outside of rank in spread()");
	69
	70	ncopies = *pncopies;
	71
8e6d7b8a	72	if (ret->data == NULL)
6de9cd9a	73	{
8e6d7b8a TK	74	/* The front end has signalled that we need to populate the
	75	return array descriptor. */
	76	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rrank;
	77	dim = 0;
	78	rs = 1;
	79	for (n = 0; n < rrank; n++)
	80	{
	81	ret->dim[n].stride = rs;
	82	ret->dim[n].lbound = 0;
	83	if (n == *along - 1)
	84	{
	85	ret->dim[n].ubound = ncopies - 1;
	86	rdelta = rs * size;
	87	rs *= ncopies;
	88	}
	89	else
	90	{
	91	count[dim] = 0;
	92	extent[dim] = source->dim[dim].ubound + 1
	93	- source->dim[dim].lbound;
	94	sstride[dim] = source->dim[dim].stride * size;
	95	rstride[dim] = rs * size;
	96
	97	ret->dim[n].ubound = extent[dim]-1;
	98	rs *= extent[dim];
	99	dim++;
	100	}
	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;
	126
	127	ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	128	if (n == *along - 1)
	129	{
	130	rdelta = ret->dim[n].stride * size;
	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;
	141	extent[dim] = source->dim[dim].ubound + 1
	142	- source->dim[dim].lbound;
	143	if (ret_extent != extent[dim])
	144	runtime_error("Incorrect extent in return value of SPREAD"
1cc0507d FXC	145	" intrinsic in dimension %ld: is %ld,"
	146	" should be %ld", (long int) n+1,
	147	(long int) ret_extent,
3cc50edc TK	148	(long int) extent[dim]);
	149
	150	if (extent[dim] <= 0)
	151	zero_sized = 1;
	152	sstride[dim] = source->dim[dim].stride * size;
	153	rstride[dim] = ret->dim[n].stride * size;
	154	dim++;
	155	}
8e6d7b8a	156	}
3cc50edc TK	157	}
	158	else
	159	{
	160	for (n = 0; n < rrank; n++)
8e6d7b8a	161	{
3cc50edc TK	162	if (n == *along - 1)
	163	{
	164	rdelta = ret->dim[n].stride * size;
	165	}
	166	else
	167	{
	168	count[dim] = 0;
	169	extent[dim] = source->dim[dim].ubound + 1
	170	- source->dim[dim].lbound;
	171	if (extent[dim] <= 0)
	172	zero_sized = 1;
	173	sstride[dim] = source->dim[dim].stride * size;
	174	rstride[dim] = ret->dim[n].stride * size;
	175	dim++;
	176	}
8e6d7b8a TK	177	}
8e6d7b8a TK	178	}
3cc50edc TK	179
	180	if (zero_sized)
	181	return;
	182
8e6d7b8a TK	183	if (sstride[0] == 0)
	184	sstride[0] = size;
	185	}
6de9cd9a DN	186	sstride0 = sstride[0];
	187	rstride0 = rstride[0];
	188	rptr = ret->data;
	189	sptr = source->data;
6de9cd9a DN	190
	191	while (sptr)
	192	{
	193	/* Spread this element. */
	194	dest = rptr;
	195	for (n = 0; n < ncopies; n++)
	196	{
	197	memcpy (dest, sptr, size);
	198	dest += rdelta;
	199	}
	200	/* Advance to the next element. */
	201	sptr += sstride0;
	202	rptr += rstride0;
	203	count[0]++;
	204	n = 0;
	205	while (count[n] == extent[n])
	206	{
	207	/* When we get to the end of a dimension, reset it and increment
	208	the next dimension. */
	209	count[n] = 0;
	210	/* We could precalculate these products, but this is a less
	211	frequently used path so probably not worth it. */
	212	sptr -= sstride[n] * extent[n];
	213	rptr -= rstride[n] * extent[n];
	214	n++;
8e6d7b8a	215	if (n >= srank)
6de9cd9a DN	216	{
	217	/* Break out of the loop. */
	218	sptr = NULL;
	219	break;
	220	}
	221	else
	222	{
	223	count[n]++;
	224	sptr += sstride[n];
	225	rptr += rstride[n];
	226	}
	227	}
	228	}
	229	}
7823229b	230
2853e512 PT	231	/* This version of spread_internal treats the special case of a scalar
	232	source. This is much simpler than the more general case above. */
	233
	234	static void
	235	spread_internal_scalar (gfc_array_char ret, const char source,
	236	const index_type along, const index_type pncopies,
	237	index_type size)
	238	{
	239	int n;
	240	int ncopies = *pncopies;
	241	char * dest;
	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;
	253	ret->dim[0].stride = 1;
	254	ret->dim[0].lbound = 0;
	255	ret->dim[0].ubound = ncopies - 1;
	256	}
	257	else
	258	{
2853e512 PT	259	if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
	260	/ ret->dim[0].stride)
	261	runtime_error ("dim too large in spread()");
	262	}
	263
	264	for (n = 0; n < ncopies; n++)
	265	{
	266	dest = (char)(ret->data + nsize*ret->dim[0].stride);
	267	memcpy (dest , source, size);
	268	}
	269	}
	270
7823229b RS	271	extern void spread (gfc_array_char , const gfc_array_char ,
	272	const index_type , const index_type );
	273	export_proto(spread);
	274
	275	void
	276	spread (gfc_array_char ret, const gfc_array_char source,
	277	const index_type along, const index_type pncopies)
	278	{
75f2543f TK	279	index_type type_size;
	280
	281	type_size = GFC_DTYPE_TYPE_SIZE(ret);
	282	switch(type_size)
	283	{
c7d0f4d5	284	case GFC_DTYPE_DERIVED_1:
75f2543f TK	285	case GFC_DTYPE_LOGICAL_1:
	286	case GFC_DTYPE_INTEGER_1:
	287	spread_i1 ((gfc_array_i1 ) ret, (gfc_array_i1 ) source,
	288	along, pncopies);
	289	return;
	290
	291	case GFC_DTYPE_LOGICAL_2:
	292	case GFC_DTYPE_INTEGER_2:
	293	spread_i2 ((gfc_array_i2 ) ret, (gfc_array_i2 ) source,
	294	along, pncopies);
	295	return;
	296
	297	case GFC_DTYPE_LOGICAL_4:
	298	case GFC_DTYPE_INTEGER_4:
	299	spread_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) source,
	300	along, pncopies);
	301	return;
	302
	303	case GFC_DTYPE_LOGICAL_8:
	304	case GFC_DTYPE_INTEGER_8:
	305	spread_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) source,
	306	along, pncopies);
	307	return;
	308
	309	#ifdef HAVE_GFC_INTEGER_16
	310	case GFC_DTYPE_LOGICAL_16:
	311	case GFC_DTYPE_INTEGER_16:
	312	spread_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) source,
	313	along, pncopies);
	314	return;
	315	#endif
	316
	317	case GFC_DTYPE_REAL_4:
	318	spread_r4 ((gfc_array_r4 ) ret, (gfc_array_r4 ) source,
	319	along, pncopies);
	320	return;
	321
	322	case GFC_DTYPE_REAL_8:
	323	spread_r8 ((gfc_array_r8 ) ret, (gfc_array_r8 ) source,
	324	along, pncopies);
	325	return;
	326
	327	#ifdef GFC_HAVE_REAL_10
	328	case GFC_DTYPE_REAL_10:
	329	spread_r10 ((gfc_array_r10 ) ret, (gfc_array_r10 ) source,
	330	along, pncopies);
	331	return;
	332	#endif
	333
	334	#ifdef GFC_HAVE_REAL_16
	335	case GFC_DTYPE_REAL_16:
	336	spread_r16 ((gfc_array_r16 ) ret, (gfc_array_r16 ) source,
	337	along, pncopies);
	338	return;
	339	#endif
	340
	341	case GFC_DTYPE_COMPLEX_4:
	342	spread_c4 ((gfc_array_c4 ) ret, (gfc_array_c4 ) source,
	343	along, pncopies);
	344	return;
	345
	346	case GFC_DTYPE_COMPLEX_8:
	347	spread_c8 ((gfc_array_c8 ) ret, (gfc_array_c8 ) source,
	348	along, pncopies);
349	return;
350
351	#ifdef GFC_HAVE_COMPLEX_10
352	case GFC_DTYPE_COMPLEX_10:
353	spread_c10 ((gfc_array_c10 ) ret, (gfc_array_c10 ) source,
354	along, pncopies);
355	return;
356	#endif
357
358	#ifdef GFC_HAVE_COMPLEX_16
359	case GFC_DTYPE_COMPLEX_16:
360	spread_c16 ((gfc_array_c16 ) ret, (gfc_array_c16 ) source,
361	along, pncopies);
362	return;
363	#endif
364
c7d0f4d5 TK	365	case GFC_DTYPE_DERIVED_2:
	366	if (GFC_UNALIGNED_2(ret->data) \|\| GFC_UNALIGNED_2(source->data))
	367	break;
	368	else
	369	{
	370	spread_i1 ((gfc_array_i1 ) ret, (gfc_array_i1 ) source,
	371	along, pncopies);
	372	return;
	373	}
	374
	375	case GFC_DTYPE_DERIVED_4:
	376	if (GFC_UNALIGNED_4(ret->data) \|\| GFC_UNALIGNED_4(source->data))
	377	break;
	378	else
	379	{
	380	spread_i4 ((gfc_array_i4 ) ret, (gfc_array_i4 ) source,
	381	along, pncopies);
	382	return;
	383	}
	384
	385	case GFC_DTYPE_DERIVED_8:
	386	if (GFC_UNALIGNED_8(ret->data) \|\| GFC_UNALIGNED_8(source->data))
	387	break;
	388	else
	389	{
	390	spread_i8 ((gfc_array_i8 ) ret, (gfc_array_i8 ) source,
	391	along, pncopies);
	392	return;
	393	}
	394
	395	#ifdef HAVE_GFC_INTEGER_16
	396	case GFC_DTYPE_DERIVED_16:
	397	if (GFC_UNALIGNED_16(ret->data) \|\| GFC_UNALIGNED_16(source->data))
	398	break;
	399	else
	400	{
	401	spread_i16 ((gfc_array_i16 ) ret, (gfc_array_i16 ) source,
	402	along, pncopies);
	403	return;
	404	}
	405	#endif
75f2543f	406	}
c7d0f4d5	407
7823229b RS	408	spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
	409	}
	410
	411	extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
	412	const gfc_array_char , const index_type ,
	413	const index_type *, GFC_INTEGER_4);
	414	export_proto(spread_char);
	415
	416	void
	417	spread_char (gfc_array_char *ret,
	418	GFC_INTEGER_4 ret_length __attribute__((unused)),
	419	const gfc_array_char source, const index_type along,
	420	const index_type *pncopies, GFC_INTEGER_4 source_length)
	421	{
	422	spread_internal (ret, source, along, pncopies, source_length);
	423	}
2853e512 PT	424
	425	/* The following are the prototypes for the versions of spread with a
	426	scalar source. */
	427
	428	extern void spread_scalar (gfc_array_char , const char ,
	429	const index_type , const index_type );
	430	export_proto(spread_scalar);
	431
	432	void
	433	spread_scalar (gfc_array_char ret, const char source,
	434	const index_type along, const index_type pncopies)
	435	{
75f2543f TK	436	index_type type_size;
75f2543f TK	437
2853e512 PT	438	if (!ret->dtype)
2853e512 PT	439	runtime_error ("return array missing descriptor in spread()");
75f2543f TK	440
	441	type_size = GFC_DTYPE_TYPE_SIZE(ret);
	442	switch(type_size)
	443	{
c7d0f4d5	444	case GFC_DTYPE_DERIVED_1:
75f2543f TK	445	case GFC_DTYPE_LOGICAL_1:
	446	case GFC_DTYPE_INTEGER_1:
	447	spread_scalar_i1 ((gfc_array_i1 ) ret, (GFC_INTEGER_1 ) source,
	448	along, pncopies);
	449	return;
	450
	451	case GFC_DTYPE_LOGICAL_2:
	452	case GFC_DTYPE_INTEGER_2:
	453	spread_scalar_i2 ((gfc_array_i2 ) ret, (GFC_INTEGER_2 ) source,
	454	along, pncopies);
	455	return;
	456
	457	case GFC_DTYPE_LOGICAL_4:
	458	case GFC_DTYPE_INTEGER_4:
	459	spread_scalar_i4 ((gfc_array_i4 ) ret, (GFC_INTEGER_4 ) source,
	460	along, pncopies);
	461	return;
	462
	463	case GFC_DTYPE_LOGICAL_8:
	464	case GFC_DTYPE_INTEGER_8:
	465	spread_scalar_i8 ((gfc_array_i8 ) ret, (GFC_INTEGER_8 ) source,
	466	along, pncopies);
	467	return;
	468
	469	#ifdef HAVE_GFC_INTEGER_16
	470	case GFC_DTYPE_LOGICAL_16:
	471	case GFC_DTYPE_INTEGER_16:
	472	spread_scalar_i16 ((gfc_array_i16 ) ret, (GFC_INTEGER_16 ) source,
	473	along, pncopies);
	474	return;
	475	#endif
	476
	477	case GFC_DTYPE_REAL_4:
	478	spread_scalar_r4 ((gfc_array_r4 ) ret, (GFC_REAL_4 ) source,
	479	along, pncopies);
	480	return;
	481
	482	case GFC_DTYPE_REAL_8:
	483	spread_scalar_r8 ((gfc_array_r8 ) ret, (GFC_REAL_8 ) source,
	484	along, pncopies);
	485	return;
	486
	487	#ifdef HAVE_GFC_REAL_10
	488	case GFC_DTYPE_REAL_10:
	489	spread_scalar_r10 ((gfc_array_r10 ) ret, (GFC_REAL_10 ) source,
	490	along, pncopies);
	491	return;
	492	#endif
	493
	494	#ifdef HAVE_GFC_REAL_16
	495	case GFC_DTYPE_REAL_16:
	496	spread_scalar_r16 ((gfc_array_r16 ) ret, (GFC_REAL_16 ) source,
	497	along, pncopies);
	498	return;
	499	#endif
	500
	501	case GFC_DTYPE_COMPLEX_4:
	502	spread_scalar_c4 ((gfc_array_c4 ) ret, (GFC_COMPLEX_4 ) source,
	503	along, pncopies);
	504	return;
	505
	506	case GFC_DTYPE_COMPLEX_8:
	507	spread_scalar_c8 ((gfc_array_c8 ) ret, (GFC_COMPLEX_8 ) source,
	508	along, pncopies);
509	return;
510
511	#ifdef HAVE_GFC_COMPLEX_10
512	case GFC_DTYPE_COMPLEX_10:
513	spread_scalar_c10 ((gfc_array_c10 ) ret, (GFC_COMPLEX_10 ) source,
514	along, pncopies);
515	return;
516	#endif
517
518	#ifdef HAVE_GFC_COMPLEX_16
519	case GFC_DTYPE_COMPLEX_16:
520	spread_scalar_c16 ((gfc_array_c16 ) ret, (GFC_COMPLEX_16 ) source,
521	along, pncopies);
522	return;
523	#endif
524
c7d0f4d5 TK	525	case GFC_DTYPE_DERIVED_2:
	526	if (GFC_UNALIGNED_2(ret->data) \|\| GFC_UNALIGNED_2(source))
	527	break;
	528	else
	529	{
	530	spread_scalar_i2 ((gfc_array_i2 ) ret, (GFC_INTEGER_2 ) source,
	531	along, pncopies);
	532	return;
	533	}
	534
	535	case GFC_DTYPE_DERIVED_4:
	536	if (GFC_UNALIGNED_4(ret->data) \|\| GFC_UNALIGNED_4(source))
	537	break;
	538	else
	539	{
	540	spread_scalar_i4 ((gfc_array_i4 ) ret, (GFC_INTEGER_4 ) source,
	541	along, pncopies);
	542	return;
	543	}
	544
	545	case GFC_DTYPE_DERIVED_8:
	546	if (GFC_UNALIGNED_8(ret->data) \|\| GFC_UNALIGNED_8(source))
	547	break;
	548	else
	549	{
	550	spread_scalar_i8 ((gfc_array_i8 ) ret, (GFC_INTEGER_8 ) source,
	551	along, pncopies);
	552	return;
	553	}
	554	#ifdef HAVE_GFC_INTEGER_16
	555	case GFC_DTYPE_DERIVED_16:
	556	if (GFC_UNALIGNED_16(ret->data) \|\| GFC_UNALIGNED_16(source))
	557	break;
	558	else
	559	{
	560	spread_scalar_i16 ((gfc_array_i16 ) ret, (GFC_INTEGER_16 ) source,
	561	along, pncopies);
	562	return;
	563	}
	564	#endif
75f2543f TK	565	}
75f2543f TK	566
2853e512 PT	567	spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
	568	}
	569
	570
	571	extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
	572	const char , const index_type ,
	573	const index_type *, GFC_INTEGER_4);
	574	export_proto(spread_char_scalar);
	575
	576	void
	577	spread_char_scalar (gfc_array_char *ret,
	578	GFC_INTEGER_4 ret_length __attribute__((unused)),
	579	const char source, const index_type along,
	580	const index_type *pncopies, GFC_INTEGER_4 source_length)
	581	{
	582	if (!ret->dtype)
	583	runtime_error ("return array missing descriptor in spread()");
	584	spread_internal_scalar (ret, source, along, pncopies, source_length);
	585	}
	586