[thirdparty/gcc.git] / libgfortran / m4 / ifunction.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,
`
extern void name`'rtype_qual`_'atype_code (rtype * const restrict, 
	atype` * const restrict, const 'index_type` * const restrict'back_arg`);
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`)
{
  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);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,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);
      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
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif
')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`);
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`)
{
  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);
#else
      name`'rtype_qual`_'atype_code (retarray, array, pdim);
#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);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      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);
      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`);
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`)
{
  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);
#else
      name`'rtype_qual`_'atype_code (retarray, array, pdim);
#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);

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

  for (n = dim; n < rank; n++)
    {
      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];

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