[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)
	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)
    len = 0;

  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;

      retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
      if (alloc_size == 0)
	return;
    }
  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];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
      if (alloc_size == 0)
	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))
	{
	  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
ddc9995b TK	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>
64b1806b	22	#include <assert.h>
ddc9995b TK	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
64b1806b TK	33	extern void name`'rtype_qual`_'atype_code (rtype` * const restrict,
64b1806b TK	34	'atype` * const restrict, const index_type * const restrict 'back_arg`,
ddc9995b	35	gfc_charlen_type);
64b1806b	36	export_proto('name`'rtype_qual`_'atype_code`);
ddc9995b TK	37
ddc9995b TK	38	void
64b1806b TK	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)
ddc9995b TK	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];
64b1806b	48	const 'atype_name * restrict base;
ddc9995b TK	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;
ca708a2b	106	retarray->dtype.rank = rank;
ddc9995b TK	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)
62715bf8	112	return;
ddc9995b TK	113	}
	114	else
	115	{
	116	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	117	runtime_error ("rank of return array incorrect in"
	118	" u_name intrinsic: is %ld, should be %ld",
	119	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	120	(long int) rank);
	121
	122	if (unlikely (compile_options.bounds_check))
	123	bounds_ifunction_return ((array_t *) retarray, extent,
	124	"return value", "u_name");
	125	}
	126
	127	for (n = 0; n < rank; n++)
	128	{
	129	count[n] = 0;
	130	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	131	if (extent[n] <= 0)
	132	return;
	133	}
	134
	135	base = array->base_addr;
	136	dest = retarray->base_addr;
	137
	138	continue_loop = 1;
	139	while (continue_loop)
	140	{
	141	const atype_name * restrict src;
	142	rtype_name result;
	143	src = base;
	144	{
	145	')dnl
	146	define(START_ARRAY_BLOCK,
	147	` if (len <= 0)
	148	*dest = '$1`;
	149	else
	150	{
	151	for (n = 0; n < len; n++, src += delta)
	152	{
	153	')dnl
	154	define(FINISH_ARRAY_FUNCTION,
	155	` }
	156	'$1`
	157	*dest = result;
	158	}
	159	}
	160	/* Advance to the next element. */
	161	count[0]++;
	162	base += sstride[0];
	163	dest += dstride[0];
	164	n = 0;
	165	while (count[n] == extent[n])
	166	{
	167	/* When we get to the end of a dimension, reset it and increment
	168	the next dimension. */
	169	count[n] = 0;
	170	/* We could precalculate these products, but this is a less
	171	frequently used path so probably not worth it. */
	172	base -= sstride[n] * extent[n];
	173	dest -= dstride[n] * extent[n];
	174	n++;
	175	if (n >= rank)
	176	{
177	/* Break out of the loop. */
178	continue_loop = 0;
179	break;
180	}
181	else
182	{
183	count[n]++;
184	base += sstride[n];
185	dest += dstride[n];
186	}
187	}
188	}
189	}')dnl
190	define(START_MASKED_ARRAY_FUNCTION,
191	`
64b1806b TK	192	extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
	193	'atype` * const restrict, const index_type * const restrict,
	194	gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
	195	export_proto(m'name`'rtype_qual`_'atype_code`);
ddc9995b TK	196
ddc9995b TK	197	void
64b1806b TK	198	m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
64b1806b TK	199	'atype` * const restrict array,
ddc9995b	200	const index_type * const restrict pdim,
64b1806b TK	201	gfc_array_l1 * const restrict mask'back_arg`,
64b1806b TK	202	gfc_charlen_type string_len)
ddc9995b TK	203	{
	204	index_type count[GFC_MAX_DIMENSIONS];
	205	index_type extent[GFC_MAX_DIMENSIONS];
	206	index_type sstride[GFC_MAX_DIMENSIONS];
	207	index_type dstride[GFC_MAX_DIMENSIONS];
	208	index_type mstride[GFC_MAX_DIMENSIONS];
64b1806b	209	'rtype_name * restrict dest;
ddc9995b TK	210	const atype_name * restrict base;
	211	const GFC_LOGICAL_1 * restrict mbase;
	212	index_type rank;
	213	index_type dim;
	214	index_type n;
	215	index_type len;
	216	index_type delta;
	217	index_type mdelta;
	218	int mask_kind;
	219
2ea47ee9 TK	220	if (mask == NULL)
	221	{
	222	#ifdef HAVE_BACK_ARG
	223	name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
	224	#else
	225	name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
	226	#endif
	227	return;
	228	}
	229
ddc9995b TK	230	dim = (*pdim) - 1;
	231	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	232
	233
	234	if (unlikely (dim < 0 \|\| dim > rank))
	235	{
	236	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	237	"is %ld, should be between 1 and %ld",
	238	(long int) dim + 1, (long int) rank + 1);
	239	}
	240
	241	len = GFC_DESCRIPTOR_EXTENT(array,dim);
85a96881 MM	242	if (len < 0)
85a96881 MM	243	len = 0;
ddc9995b TK	244
	245	mbase = mask->base_addr;
	246
	247	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	248
	249	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	250	#ifdef HAVE_GFC_LOGICAL_16
	251	\|\| mask_kind == 16
	252	#endif
	253	)
	254	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	255	else
	256	runtime_error ("Funny sized logical array");
	257
	258	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	259	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	260
	261	for (n = 0; n < dim; n++)
	262	{
	263	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	264	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	265	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	266
	267	if (extent[n] < 0)
	268	extent[n] = 0;
	269
	270	}
	271	for (n = dim; n < rank; n++)
	272	{
	273	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
	274	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	275	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	276
	277	if (extent[n] < 0)
	278	extent[n] = 0;
	279	}
	280
	281	if (retarray->base_addr == NULL)
	282	{
	283	size_t alloc_size, str;
	284
	285	for (n = 0; n < rank; n++)
	286	{
	287	if (n == 0)
	288	str = 1;
	289	else
	290	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	291
	292	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	293
	294	}
	295
	296	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	297
	298	retarray->offset = 0;
ca708a2b	299	retarray->dtype.rank = rank;
ddc9995b	300
d56bf419	301	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
ddc9995b	302	if (alloc_size == 0)
62715bf8	303	return;
ddc9995b TK	304	}
	305	else
	306	{
	307	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	308	runtime_error ("rank of return array incorrect in u_name intrinsic");
	309
	310	if (unlikely (compile_options.bounds_check))
	311	{
	312	bounds_ifunction_return ((array_t *) retarray, extent,
	313	"return value", "u_name");
	314	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	315	"MASK argument", "u_name");
	316	}
	317	}
	318
	319	for (n = 0; n < rank; n++)
	320	{
	321	count[n] = 0;
	322	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	323	if (extent[n] <= 0)
	324	return;
	325	}
	326
	327	dest = retarray->base_addr;
	328	base = array->base_addr;
	329
	330	while (base)
	331	{
	332	const atype_name * restrict src;
	333	const GFC_LOGICAL_1 * restrict msrc;
	334	rtype_name result;
	335	src = base;
	336	msrc = mbase;
	337	{
	338	')dnl
	339	define(START_MASKED_ARRAY_BLOCK,
	340	` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	341	{
	342	')dnl
	343	define(FINISH_MASKED_ARRAY_FUNCTION,
	344	` }
	345	*dest = result;
	346	}
	347	/* Advance to the next element. */
	348	count[0]++;
	349	base += sstride[0];
	350	mbase += mstride[0];
	351	dest += dstride[0];
	352	n = 0;
	353	while (count[n] == extent[n])
	354	{
	355	/* When we get to the end of a dimension, reset it and increment
	356	the next dimension. */
	357	count[n] = 0;
	358	/* We could precalculate these products, but this is a less
	359	frequently used path so probably not worth it. */
	360	base -= sstride[n] * extent[n];
	361	mbase -= mstride[n] * extent[n];
	362	dest -= dstride[n] * extent[n];
	363	n++;
	364	if (n >= rank)
	365	{
	366	/* Break out of the loop. */
	367	base = NULL;
368	break;
369	}
370	else
371	{
372	count[n]++;
373	base += sstride[n];
374	mbase += mstride[n];
375	dest += dstride[n];
376	}
377	}
378	}
379	}')dnl
380	define(SCALAR_ARRAY_FUNCTION,
381	`
64b1806b TK	382	extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
	383	'atype` * const restrict, const index_type * const restrict,
	384	GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
	385	export_proto(s'name`'rtype_qual`_'atype_code`);
ddc9995b TK	386
ddc9995b TK	387	void
64b1806b TK	388	s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
64b1806b TK	389	'atype` * const restrict array,
ddc9995b	390	const index_type * const restrict pdim,
64b1806b	391	GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
ddc9995b TK	392	{
	393	index_type count[GFC_MAX_DIMENSIONS];
	394	index_type extent[GFC_MAX_DIMENSIONS];
	395	index_type dstride[GFC_MAX_DIMENSIONS];
64b1806b	396	'rtype_name * restrict dest;
ddc9995b TK	397	index_type rank;
	398	index_type n;
	399	index_type dim;
	400
	401
2ea47ee9	402	if (mask == NULL \|\| *mask)
ddc9995b	403	{
64b1806b TK	404	#ifdef HAVE_BACK_ARG
	405	name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
	406	#else
ddc9995b	407	name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
64b1806b	408	#endif
ddc9995b TK	409	return;
	410	}
	411	/* Make dim zero based to avoid confusion. */
	412	dim = (*pdim) - 1;
	413	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	414
	415	if (unlikely (dim < 0 \|\| dim > rank))
	416	{
	417	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	418	"is %ld, should be between 1 and %ld",
	419	(long int) dim + 1, (long int) rank + 1);
	420	}
	421
	422	for (n = 0; n < dim; n++)
	423	{
	424	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
	425
	426	if (extent[n] <= 0)
	427	extent[n] = 0;
	428	}
	429
	430	for (n = dim; n < rank; n++)
	431	{
	432	extent[n] =
	433	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
	434
	435	if (extent[n] <= 0)
	436	extent[n] = 0;
	437	}
	438
	439	if (retarray->base_addr == NULL)
	440	{
	441	size_t alloc_size, str;
	442
	443	for (n = 0; n < rank; n++)
	444	{
	445	if (n == 0)
	446	str = 1;
	447	else
	448	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	449
	450	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	451
	452	}
	453
	454	retarray->offset = 0;
ca708a2b	455	retarray->dtype.rank = rank;
ddc9995b TK	456
	457	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	458
d56bf419	459	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
ddc9995b	460	if (alloc_size == 0)
62715bf8	461	return;
ddc9995b TK	462	}
	463	else
	464	{
	465	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	466	runtime_error ("rank of return array incorrect in"
	467	" u_name intrinsic: is %ld, should be %ld",
	468	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	469	(long int) rank);
	470
	471	if (unlikely (compile_options.bounds_check))
	472	{
	473	for (n=0; n < rank; n++)
	474	{
	475	index_type ret_extent;
	476
	477	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	478	if (extent[n] != ret_extent)
	479	runtime_error ("Incorrect extent in return value of"
	480	" u_name intrinsic in dimension %ld:"
	481	" is %ld, should be %ld", (long int) n + 1,
	482	(long int) ret_extent, (long int) extent[n]);
	483	}
	484	}
	485	}
	486
	487	for (n = 0; n < rank; n++)
	488	{
	489	count[n] = 0;
	490	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	491	}
	492
	493	dest = retarray->base_addr;
	494
	495	while(1)
	496	{
	497	*dest = '$1`;
	498	count[0]++;
	499	dest += dstride[0];
	500	n = 0;
	501	while (count[n] == extent[n])
	502	{
	503	/* When we get to the end of a dimension, reset it and increment
	504	the next dimension. */
	505	count[n] = 0;
	506	/* We could precalculate these products, but this is a less
	507	frequently used path so probably not worth it. */
	508	dest -= dstride[n] * extent[n];
	509	n++;
	510	if (n >= rank)
	511	return;
	512	else
	513	{
	514	count[n]++;
	515	dest += dstride[n];
	516	}
	517	}
	518	}
	519	}')dnl
	520	define(ARRAY_FUNCTION,
	521	`START_ARRAY_FUNCTION
	522	$2
	523	START_ARRAY_BLOCK($1)
	524	$3
	525	FINISH_ARRAY_FUNCTION($4)')dnl
526	define(MASKED_ARRAY_FUNCTION,
527	`START_MASKED_ARRAY_FUNCTION
528	$2
529	START_MASKED_ARRAY_BLOCK
530	$3
531	FINISH_MASKED_ARRAY_FUNCTION')dnl