[thirdparty/gcc.git] / libgfortran / m4 / ifunction-s.m4

dnl Support macro file for intrinsic functions.
dnl Contains the generic sections of the array functions.
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
dnl Distributed under the GNU GPL with exception.  See COPYING for details.
dnl
dnl Pass the implementation for a single section as the parameter to
dnl {MASK_}ARRAY_FUNCTION.
dnl The variables base, delta, and len describe the input section.
dnl For masked section the mask is described by mbase and mdelta.
dnl These should not be modified. The result should be stored in *dest.
dnl The names count, extent, sstride, dstride, base, dest, rank, dim
dnl retarray, array, pdim and mstride should not be used.
dnl The variable n is declared as index_type and may be used.
dnl Other variable declarations may be placed at the start of the code,
dnl The types of the array parameter and the return value are
dnl atype_name and rtype_name respectively.
dnl Execution should be allowed to continue to the end of the block.
dnl You should not return or break from the inner loop of the implementation.
dnl Care should also be taken to avoid using the names defined in iparm.m4
define(START_ARRAY_FUNCTION,
`#include <string.h>
#include <assert.h>

static inline int
compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
{
  if (sizeof ('atype_name`) == 1)
    return memcmp (a, b, n);
  else
    return memcmp_char4 (a, b, n);
}

extern void name`'rtype_qual`_'atype_code (rtype` * const restrict, 
	'atype` * const restrict, const index_type * const restrict 'back_arg`,
	gfc_charlen_type);
export_proto('name`'rtype_qual`_'atype_code`);

void
'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 
	'atype` * const restrict array, 
	const index_type * const restrict pdim'back_arg`,
	gfc_charlen_type string_len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const 'atype_name * restrict base;
  rtype_name * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in u_name intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;

	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " u_name intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	bounds_ifunction_return ((array_t *) retarray, extent,
				 "return value", "u_name");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }

  base = array->base_addr;
  dest = retarray->base_addr;

  continue_loop = 1;
  while (continue_loop)
    {
      const atype_name * restrict src;
      rtype_name result;
      src = base;
      {
')dnl
define(START_ARRAY_BLOCK,
`	if (len <= 0)
	  *dest = '$1`;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {
')dnl
define(FINISH_ARRAY_FUNCTION,
`	      }
	    '$1`
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[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.  */
	  base -= sstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}')dnl
define(START_MASKED_ARRAY_FUNCTION,
`
extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict, 
	'atype` * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
export_proto(m'name`'rtype_qual`_'atype_code`);

void
m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 
	'atype` * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask'back_arg`,
	gfc_charlen_type string_len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  'rtype_name * restrict dest;
  const atype_name * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
#else
      name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
#endif
      return;
    }

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in u_name intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));

    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in u_name intrinsic");

      if (unlikely (compile_options.bounds_check))
	{
	  bounds_ifunction_return ((array_t *) retarray, extent,
				   "return value", "u_name");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
	  			"MASK argument", "u_name");
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }

  dest = retarray->base_addr;
  base = array->base_addr;

  while (base)
    {
      const atype_name * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      rtype_name result;
      src = base;
      msrc = mbase;
      {
')dnl
define(START_MASKED_ARRAY_BLOCK,
`	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {
')dnl
define(FINISH_MASKED_ARRAY_FUNCTION,
`	  }
	*dest = result;
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[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.  */
	  base -= sstride[n] * extent[n];
	  mbase -= mstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}')dnl
define(SCALAR_ARRAY_FUNCTION,
`
extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict, 
	'atype` * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
export_proto(s'name`'rtype_qual`_'atype_code`);

void
s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, 
	'atype` * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  'rtype_name * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
#else
      name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
#endif
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in u_name intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " u_name intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

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

	      ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	      if (extent[n] != ret_extent)
		runtime_error ("Incorrect extent in return value of"
			       " u_name intrinsic in dimension %ld:"
			       " is %ld, should be %ld", (long int) n + 1,
			       (long int) ret_extent, (long int) extent[n]);
	    }
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    }

  dest = retarray->base_addr;

  while(1)
    {
      *dest = '$1`;
      count[0]++;
      dest += dstride[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.  */
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    return;
	  else
	    {
	      count[n]++;
	      dest += dstride[n];
	    }
      	}
    }
}')dnl
define(ARRAY_FUNCTION,
`START_ARRAY_FUNCTION
$2
START_ARRAY_BLOCK($1)
$3
FINISH_ARRAY_FUNCTION($4)')dnl
define(MASKED_ARRAY_FUNCTION,
`START_MASKED_ARRAY_FUNCTION
$2
START_MASKED_ARRAY_BLOCK
$3
FINISH_MASKED_ARRAY_FUNCTION')dnl
Commit	Line	Data
eab3d206	1	dnl Support macro file for intrinsic functions.
	2	dnl Contains the generic sections of the array functions.
	3	dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
	4	dnl Distributed under the GNU GPL with exception. See COPYING for details.
	5	dnl
	6	dnl Pass the implementation for a single section as the parameter to
	7	dnl {MASK_}ARRAY_FUNCTION.
	8	dnl The variables base, delta, and len describe the input section.
	9	dnl For masked section the mask is described by mbase and mdelta.
	10	dnl These should not be modified. The result should be stored in *dest.
	11	dnl The names count, extent, sstride, dstride, base, dest, rank, dim
	12	dnl retarray, array, pdim and mstride should not be used.
	13	dnl The variable n is declared as index_type and may be used.
	14	dnl Other variable declarations may be placed at the start of the code,
	15	dnl The types of the array parameter and the return value are
	16	dnl atype_name and rtype_name respectively.
	17	dnl Execution should be allowed to continue to the end of the block.
	18	dnl You should not return or break from the inner loop of the implementation.
	19	dnl Care should also be taken to avoid using the names defined in iparm.m4
	20	define(START_ARRAY_FUNCTION,
	21	`#include <string.h>
cb458068	22	#include <assert.h>
eab3d206	23
	24	static inline int
	25	compare_fcn (const atype_name a, const atype_name b, gfc_charlen_type n)
	26	{
	27	if (sizeof ('atype_name`) == 1)
	28	return memcmp (a, b, n);
	29	else
	30	return memcmp_char4 (a, b, n);
	31	}
	32
cb458068	33	extern void name`'rtype_qual`_'atype_code (rtype` * const restrict,
cb458068	34	'atype` * const restrict, const index_type * const restrict 'back_arg`,
eab3d206	35	gfc_charlen_type);
cb458068	36	export_proto('name`'rtype_qual`_'atype_code`);
eab3d206	37
eab3d206	38	void
cb458068	39	'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
	40	'atype` * const restrict array,
	41	const index_type * const restrict pdim'back_arg`,
	42	gfc_charlen_type string_len)
eab3d206	43	{
	44	index_type count[GFC_MAX_DIMENSIONS];
	45	index_type extent[GFC_MAX_DIMENSIONS];
	46	index_type sstride[GFC_MAX_DIMENSIONS];
	47	index_type dstride[GFC_MAX_DIMENSIONS];
cb458068	48	const 'atype_name * restrict base;
eab3d206	49	rtype_name * restrict dest;
	50	index_type rank;
	51	index_type n;
	52	index_type len;
	53	index_type delta;
	54	index_type dim;
	55	int continue_loop;
	56
	57	/* Make dim zero based to avoid confusion. */
	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	59	dim = (*pdim) - 1;
	60
	61	if (unlikely (dim < 0 \|\| dim > rank))
	62	{
	63	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	64	"is %ld, should be between 1 and %ld",
	65	(long int) dim + 1, (long int) rank + 1);
	66	}
	67
	68	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	69	if (len < 0)
	70	len = 0;
	71	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	72
	73	for (n = 0; n < dim; n++)
	74	{
	75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	76	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	77
	78	if (extent[n] < 0)
	79	extent[n] = 0;
	80	}
	81	for (n = dim; n < rank; n++)
	82	{
	83	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
	84	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	85
	86	if (extent[n] < 0)
	87	extent[n] = 0;
	88	}
	89
	90	if (retarray->base_addr == NULL)
	91	{
	92	size_t alloc_size, str;
	93
	94	for (n = 0; n < rank; n++)
	95	{
	96	if (n == 0)
	97	str = 1;
	98	else
	99	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	100
	101	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	102
	103	}
	104
	105	retarray->offset = 0;
0bb0be20	106	retarray->dtype.rank = rank;
eab3d206	107
	108	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	109
	110	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
	111	if (alloc_size == 0)
	112	{
	113	/* Make sure we have a zero-sized array. */
	114	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	115	return;
	116
	117	}
	118	}
	119	else
	120	{
	121	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	122	runtime_error ("rank of return array incorrect in"
	123	" u_name intrinsic: is %ld, should be %ld",
	124	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	125	(long int) rank);
	126
	127	if (unlikely (compile_options.bounds_check))
	128	bounds_ifunction_return ((array_t *) retarray, extent,
	129	"return value", "u_name");
	130	}
	131
	132	for (n = 0; n < rank; n++)
	133	{
	134	count[n] = 0;
	135	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	136	if (extent[n] <= 0)
	137	return;
	138	}
	139
	140	base = array->base_addr;
	141	dest = retarray->base_addr;
	142
	143	continue_loop = 1;
	144	while (continue_loop)
	145	{
	146	const atype_name * restrict src;
	147	rtype_name result;
	148	src = base;
	149	{
	150	')dnl
	151	define(START_ARRAY_BLOCK,
	152	` if (len <= 0)
	153	*dest = '$1`;
	154	else
	155	{
	156	for (n = 0; n < len; n++, src += delta)
	157	{
	158	')dnl
	159	define(FINISH_ARRAY_FUNCTION,
	160	` }
	161	'$1`
	162	*dest = result;
	163	}
	164	}
	165	/* Advance to the next element. */
	166	count[0]++;
	167	base += sstride[0];
	168	dest += dstride[0];
	169	n = 0;
	170	while (count[n] == extent[n])
171	{
172	/* When we get to the end of a dimension, reset it and increment
173	the next dimension. */
174	count[n] = 0;
175	/* We could precalculate these products, but this is a less
176	frequently used path so probably not worth it. */
177	base -= sstride[n] * extent[n];
178	dest -= dstride[n] * extent[n];
179	n++;
180	if (n >= rank)
181	{
182	/* Break out of the loop. */
183	continue_loop = 0;
184	break;
185	}
186	else
187	{
188	count[n]++;
189	base += sstride[n];
190	dest += dstride[n];
191	}
192	}
193	}
194	}')dnl
195	define(START_MASKED_ARRAY_FUNCTION,
196	`
cb458068	197	extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
	198	'atype` * const restrict, const index_type * const restrict,
	199	gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
	200	export_proto(m'name`'rtype_qual`_'atype_code`);
eab3d206	201
eab3d206	202	void
cb458068	203	m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
cb458068	204	'atype` * const restrict array,
eab3d206	205	const index_type * const restrict pdim,
cb458068	206	gfc_array_l1 * const restrict mask'back_arg`,
cb458068	207	gfc_charlen_type string_len)
eab3d206	208	{
	209	index_type count[GFC_MAX_DIMENSIONS];
	210	index_type extent[GFC_MAX_DIMENSIONS];
	211	index_type sstride[GFC_MAX_DIMENSIONS];
	212	index_type dstride[GFC_MAX_DIMENSIONS];
	213	index_type mstride[GFC_MAX_DIMENSIONS];
cb458068	214	'rtype_name * restrict dest;
eab3d206	215	const atype_name * restrict base;
	216	const GFC_LOGICAL_1 * restrict mbase;
	217	index_type rank;
	218	index_type dim;
	219	index_type n;
	220	index_type len;
	221	index_type delta;
	222	index_type mdelta;
	223	int mask_kind;
	224
538bdcdc	225	if (mask == NULL)
	226	{
	227	#ifdef HAVE_BACK_ARG
	228	name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
	229	#else
	230	name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
	231	#endif
	232	return;
	233	}
	234
eab3d206	235	dim = (*pdim) - 1;
	236	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	237
	238
	239	if (unlikely (dim < 0 \|\| dim > rank))
	240	{
	241	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	242	"is %ld, should be between 1 and %ld",
	243	(long int) dim + 1, (long int) rank + 1);
	244	}
	245
	246	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	247	if (len <= 0)
	248	return;
	249
	250	mbase = mask->base_addr;
	251
	252	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	253
	254	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	255	#ifdef HAVE_GFC_LOGICAL_16
	256	\|\| mask_kind == 16
	257	#endif
	258	)
	259	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	260	else
	261	runtime_error ("Funny sized logical array");
	262
	263	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	264	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	265
	266	for (n = 0; n < dim; n++)
	267	{
	268	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	269	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	270	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	271
	272	if (extent[n] < 0)
	273	extent[n] = 0;
	274
	275	}
	276	for (n = dim; n < rank; n++)
	277	{
	278	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
	279	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	280	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	281
	282	if (extent[n] < 0)
	283	extent[n] = 0;
	284	}
	285
	286	if (retarray->base_addr == NULL)
	287	{
	288	size_t alloc_size, str;
	289
	290	for (n = 0; n < rank; n++)
	291	{
	292	if (n == 0)
	293	str = 1;
	294	else
	295	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	296
	297	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	298
299	}
300
301	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
302
303	retarray->offset = 0;
0bb0be20	304	retarray->dtype.rank = rank;
eab3d206	305
	306	if (alloc_size == 0)
	307	{
	308	/* Make sure we have a zero-sized array. */
	309	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	310	return;
	311	}
	312	else
	313	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
	314
	315	}
	316	else
	317	{
	318	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	319	runtime_error ("rank of return array incorrect in u_name intrinsic");
	320
	321	if (unlikely (compile_options.bounds_check))
	322	{
	323	bounds_ifunction_return ((array_t *) retarray, extent,
	324	"return value", "u_name");
	325	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	326	"MASK argument", "u_name");
	327	}
	328	}
	329
	330	for (n = 0; n < rank; n++)
	331	{
	332	count[n] = 0;
	333	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	334	if (extent[n] <= 0)
	335	return;
	336	}
	337
	338	dest = retarray->base_addr;
	339	base = array->base_addr;
	340
	341	while (base)
	342	{
	343	const atype_name * restrict src;
	344	const GFC_LOGICAL_1 * restrict msrc;
	345	rtype_name result;
	346	src = base;
	347	msrc = mbase;
	348	{
	349	')dnl
	350	define(START_MASKED_ARRAY_BLOCK,
	351	` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	352	{
	353	')dnl
	354	define(FINISH_MASKED_ARRAY_FUNCTION,
	355	` }
	356	*dest = result;
	357	}
	358	/* Advance to the next element. */
	359	count[0]++;
	360	base += sstride[0];
	361	mbase += mstride[0];
	362	dest += dstride[0];
	363	n = 0;
	364	while (count[n] == extent[n])
	365	{
	366	/* When we get to the end of a dimension, reset it and increment
	367	the next dimension. */
	368	count[n] = 0;
369	/* We could precalculate these products, but this is a less
370	frequently used path so probably not worth it. */
371	base -= sstride[n] * extent[n];
372	mbase -= mstride[n] * extent[n];
373	dest -= dstride[n] * extent[n];
374	n++;
375	if (n >= rank)
376	{
377	/* Break out of the loop. */
378	base = NULL;
379	break;
380	}
381	else
382	{
383	count[n]++;
384	base += sstride[n];
385	mbase += mstride[n];
386	dest += dstride[n];
387	}
388	}
389	}
390	}')dnl
391	define(SCALAR_ARRAY_FUNCTION,
392	`
cb458068	393	extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
	394	'atype` * const restrict, const index_type * const restrict,
	395	GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
	396	export_proto(s'name`'rtype_qual`_'atype_code`);
eab3d206	397
eab3d206	398	void
cb458068	399	s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
cb458068	400	'atype` * const restrict array,
eab3d206	401	const index_type * const restrict pdim,
cb458068	402	GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
eab3d206	403	{
	404	index_type count[GFC_MAX_DIMENSIONS];
	405	index_type extent[GFC_MAX_DIMENSIONS];
	406	index_type dstride[GFC_MAX_DIMENSIONS];
cb458068	407	'rtype_name * restrict dest;
eab3d206	408	index_type rank;
	409	index_type n;
	410	index_type dim;
	411
	412
538bdcdc	413	if (mask == NULL \|\| *mask)
eab3d206	414	{
cb458068	415	#ifdef HAVE_BACK_ARG
	416	name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
	417	#else
eab3d206	418	name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
cb458068	419	#endif
eab3d206	420	return;
	421	}
	422	/* Make dim zero based to avoid confusion. */
	423	dim = (*pdim) - 1;
	424	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	425
	426	if (unlikely (dim < 0 \|\| dim > rank))
	427	{
	428	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	429	"is %ld, should be between 1 and %ld",
	430	(long int) dim + 1, (long int) rank + 1);
	431	}
	432
	433	for (n = 0; n < dim; n++)
	434	{
	435	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
	436
	437	if (extent[n] <= 0)
	438	extent[n] = 0;
	439	}
	440
	441	for (n = dim; n < rank; n++)
	442	{
	443	extent[n] =
	444	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
	445
	446	if (extent[n] <= 0)
	447	extent[n] = 0;
	448	}
	449
	450	if (retarray->base_addr == NULL)
	451	{
	452	size_t alloc_size, str;
	453
	454	for (n = 0; n < rank; n++)
	455	{
	456	if (n == 0)
	457	str = 1;
	458	else
	459	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	460
	461	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	462
	463	}
	464
	465	retarray->offset = 0;
0bb0be20	466	retarray->dtype.rank = rank;
eab3d206	467
	468	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	469
	470	if (alloc_size == 0)
	471	{
	472	/* Make sure we have a zero-sized array. */
	473	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	474	return;
	475	}
	476	else
	477	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
	478	}
	479	else
	480	{
	481	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	482	runtime_error ("rank of return array incorrect in"
	483	" u_name intrinsic: is %ld, should be %ld",
	484	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	485	(long int) rank);
	486
	487	if (unlikely (compile_options.bounds_check))
	488	{
	489	for (n=0; n < rank; n++)
	490	{
	491	index_type ret_extent;
	492
	493	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	494	if (extent[n] != ret_extent)
	495	runtime_error ("Incorrect extent in return value of"
	496	" u_name intrinsic in dimension %ld:"
	497	" is %ld, should be %ld", (long int) n + 1,
	498	(long int) ret_extent, (long int) extent[n]);
	499	}
	500	}
	501	}
	502
	503	for (n = 0; n < rank; n++)
	504	{
	505	count[n] = 0;
	506	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	507	}
	508
	509	dest = retarray->base_addr;
	510
	511	while(1)
	512	{
	513	*dest = '$1`;
	514	count[0]++;
	515	dest += dstride[0];
	516	n = 0;
	517	while (count[n] == extent[n])
	518	{
	519	/* When we get to the end of a dimension, reset it and increment
	520	the next dimension. */
	521	count[n] = 0;
	522	/* We could precalculate these products, but this is a less
	523	frequently used path so probably not worth it. */
	524	dest -= dstride[n] * extent[n];
	525	n++;
	526	if (n >= rank)
	527	return;
	528	else
	529	{
	530	count[n]++;
531	dest += dstride[n];
532	}
533	}
534	}
535	}')dnl
536	define(ARRAY_FUNCTION,
537	`START_ARRAY_FUNCTION
538	$2
539	START_ARRAY_BLOCK($1)
540	$3
541	FINISH_ARRAY_FUNCTION($4)')dnl
542	define(MASKED_ARRAY_FUNCTION,
543	`START_MASKED_ARRAY_FUNCTION
544	$2
545	START_MASKED_ARRAY_BLOCK
546	$3
547	FINISH_MASKED_ARRAY_FUNCTION')dnl