[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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,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;

  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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,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)
    {
#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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,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;
da8dff89	106	GFC_DTYPE_COPY_SETRANK(retarray,array,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
	225	dim = (*pdim) - 1;
	226	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	227
	228
	229	if (unlikely (dim < 0 \|\| dim > rank))
	230	{
	231	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	232	"is %ld, should be between 1 and %ld",
	233	(long int) dim + 1, (long int) rank + 1);
	234	}
	235
	236	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	237	if (len <= 0)
	238	return;
	239
	240	mbase = mask->base_addr;
	241
	242	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	243
	244	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	245	#ifdef HAVE_GFC_LOGICAL_16
	246	\|\| mask_kind == 16
	247	#endif
	248	)
	249	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	250	else
	251	runtime_error ("Funny sized logical array");
	252
	253	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	254	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	255
	256	for (n = 0; n < dim; n++)
	257	{
	258	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	259	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	260	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	261
	262	if (extent[n] < 0)
	263	extent[n] = 0;
	264
	265	}
	266	for (n = dim; n < rank; n++)
	267	{
	268	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
	269	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	270	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	271
	272	if (extent[n] < 0)
	273	extent[n] = 0;
	274	}
	275
	276	if (retarray->base_addr == NULL)
	277	{
	278	size_t alloc_size, str;
279
280	for (n = 0; n < rank; n++)
281	{
282	if (n == 0)
283	str = 1;
284	else
285	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
286
287	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
288
289	}
290
291	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
292
293	retarray->offset = 0;
da8dff89	294	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
eab3d206	295
	296	if (alloc_size == 0)
	297	{
	298	/* Make sure we have a zero-sized array. */
	299	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	300	return;
	301	}
	302	else
	303	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
	304
	305	}
	306	else
	307	{
	308	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	309	runtime_error ("rank of return array incorrect in u_name intrinsic");
	310
	311	if (unlikely (compile_options.bounds_check))
	312	{
	313	bounds_ifunction_return ((array_t *) retarray, extent,
	314	"return value", "u_name");
	315	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	316	"MASK argument", "u_name");
	317	}
	318	}
	319
	320	for (n = 0; n < rank; n++)
	321	{
	322	count[n] = 0;
	323	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	324	if (extent[n] <= 0)
	325	return;
	326	}
	327
	328	dest = retarray->base_addr;
	329	base = array->base_addr;
	330
	331	while (base)
	332	{
	333	const atype_name * restrict src;
	334	const GFC_LOGICAL_1 * restrict msrc;
	335	rtype_name result;
	336	src = base;
	337	msrc = mbase;
	338	{
	339	')dnl
	340	define(START_MASKED_ARRAY_BLOCK,
	341	` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	342	{
	343	')dnl
	344	define(FINISH_MASKED_ARRAY_FUNCTION,
	345	` }
	346	*dest = result;
	347	}
	348	/* Advance to the next element. */
	349	count[0]++;
	350	base += sstride[0];
	351	mbase += mstride[0];
	352	dest += dstride[0];
	353	n = 0;
	354	while (count[n] == extent[n])
	355	{
	356	/* When we get to the end of a dimension, reset it and increment
	357	the next dimension. */
	358	count[n] = 0;
359	/* We could precalculate these products, but this is a less
360	frequently used path so probably not worth it. */
361	base -= sstride[n] * extent[n];
362	mbase -= mstride[n] * extent[n];
363	dest -= dstride[n] * extent[n];
364	n++;
365	if (n >= rank)
366	{
367	/* Break out of the loop. */
368	base = NULL;
369	break;
370	}
371	else
372	{
373	count[n]++;
374	base += sstride[n];
375	mbase += mstride[n];
376	dest += dstride[n];
377	}
378	}
379	}
380	}')dnl
381	define(SCALAR_ARRAY_FUNCTION,
382	`
cb458068	383	extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
	384	'atype` * const restrict, const index_type * const restrict,
	385	GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
	386	export_proto(s'name`'rtype_qual`_'atype_code`);
eab3d206	387
eab3d206	388	void
cb458068	389	s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
cb458068	390	'atype` * const restrict array,
eab3d206	391	const index_type * const restrict pdim,
cb458068	392	GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
eab3d206	393	{
	394	index_type count[GFC_MAX_DIMENSIONS];
	395	index_type extent[GFC_MAX_DIMENSIONS];
	396	index_type dstride[GFC_MAX_DIMENSIONS];
cb458068	397	'rtype_name * restrict dest;
eab3d206	398	index_type rank;
	399	index_type n;
	400	index_type dim;
	401
	402
	403	if (*mask)
	404	{
cb458068	405	#ifdef HAVE_BACK_ARG
	406	name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
	407	#else
eab3d206	408	name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
cb458068	409	#endif
eab3d206	410	return;
	411	}
	412	/* Make dim zero based to avoid confusion. */
	413	dim = (*pdim) - 1;
	414	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	415
	416	if (unlikely (dim < 0 \|\| dim > rank))
	417	{
	418	runtime_error ("Dim argument incorrect in u_name intrinsic: "
	419	"is %ld, should be between 1 and %ld",
	420	(long int) dim + 1, (long int) rank + 1);
	421	}
	422
	423	for (n = 0; n < dim; n++)
	424	{
	425	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
	426
	427	if (extent[n] <= 0)
	428	extent[n] = 0;
	429	}
	430
	431	for (n = dim; n < rank; n++)
	432	{
	433	extent[n] =
	434	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
	435
	436	if (extent[n] <= 0)
	437	extent[n] = 0;
	438	}
	439
	440	if (retarray->base_addr == NULL)
	441	{
	442	size_t alloc_size, str;
	443
	444	for (n = 0; n < rank; n++)
	445	{
	446	if (n == 0)
	447	str = 1;
	448	else
	449	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	450
	451	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	452
	453	}
	454
	455	retarray->offset = 0;
da8dff89	456	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
eab3d206	457
	458	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	459
	460	if (alloc_size == 0)
	461	{
	462	/* Make sure we have a zero-sized array. */
	463	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	464	return;
	465	}
	466	else
	467	retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
	468	}
	469	else
	470	{
	471	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	472	runtime_error ("rank of return array incorrect in"
	473	" u_name intrinsic: is %ld, should be %ld",
	474	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	475	(long int) rank);
	476
	477	if (unlikely (compile_options.bounds_check))
	478	{
	479	for (n=0; n < rank; n++)
	480	{
	481	index_type ret_extent;
	482
	483	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	484	if (extent[n] != ret_extent)
	485	runtime_error ("Incorrect extent in return value of"
	486	" u_name intrinsic in dimension %ld:"
	487	" is %ld, should be %ld", (long int) n + 1,
	488	(long int) ret_extent, (long int) extent[n]);
	489	}
	490	}
	491	}
	492
	493	for (n = 0; n < rank; n++)
	494	{
	495	count[n] = 0;
	496	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	497	}
	498
	499	dest = retarray->base_addr;
	500
	501	while(1)
	502	{
	503	*dest = '$1`;
	504	count[0]++;
	505	dest += dstride[0];
	506	n = 0;
	507	while (count[n] == extent[n])
	508	{
	509	/* When we get to the end of a dimension, reset it and increment
	510	the next dimension. */
	511	count[n] = 0;
	512	/* We could precalculate these products, but this is a less
	513	frequently used path so probably not worth it. */
	514	dest -= dstride[n] * extent[n];
	515	n++;
	516	if (n >= rank)
	517	return;
	518	else
	519	{
	520	count[n]++;
521	dest += dstride[n];
522	}
523	}
524	}
525	}')dnl
526	define(ARRAY_FUNCTION,
527	`START_ARRAY_FUNCTION
528	$2
529	START_ARRAY_BLOCK($1)
530	$3
531	FINISH_ARRAY_FUNCTION($4)')dnl
532	define(MASKED_ARRAY_FUNCTION,
533	`START_MASKED_ARRAY_FUNCTION
534	$2
535	START_MASKED_ARRAY_BLOCK
536	$3
537	FINISH_MASKED_ARRAY_FUNCTION')dnl