[thirdparty/gcc.git] / libgfortran / m4 / iforeach.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.
define(START_FOREACH_FUNCTION,
`
extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
	atype * const restrict array, GFC_LOGICAL_4);
export_proto(name`'rtype_qual`_'atype_code);

void
name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
	atype * const restrict array, GFC_LOGICAL_4 back)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  const atype_name *base;
  rtype_name * restrict dest;
  index_type rank;
  index_type n;

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype.rank = 1;
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				"u_name");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->base_addr;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 1;
  {
')dnl
define(START_FOREACH_BLOCK,
`  while (base)
    {
	  /* Implementation start.  */
')dnl
define(FINISH_FOREACH_FUNCTION,
`	  /* Implementation end.  */
	  /* Advance to the next element.  */
	  base += sstride[0];
	}
      while (++count[0] != extent[0]);
      n = 0;
      do
	{
	  /* 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];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	    }
	}
      while (count[n] == extent[n]);
    }
  }
}')dnl
define(START_MASKED_FOREACH_FUNCTION,
`
extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, 
	atype * const restrict, gfc_array_l1 * const restrict,
	GFC_LOGICAL_4);
export_proto(`m'name`'rtype_qual`_'atype_code);

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


  if (mask == NULL)
    {
      name`'rtype_qual`_'atype_code (retarray, array, back);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
      retarray->dtype.rank = 1;
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	{

	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				  "u_name");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
				  "MASK argument", "u_name");
	}
    }

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->base_addr;

  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");

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->base_addr;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {
')dnl
define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
define(FINISH_MASKED_FOREACH_FUNCTION,
`	  /* Implementation end.  */
	  /* Advance to the next element.  */
	  base += sstride[0];
	  mbase += mstride[0];
	}
      while (++count[0] != extent[0]);
      n = 0;
      do
	{
	  /* 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];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	    }
	}
      while (count[n] == extent[n]);
    }
  }
}')dnl
define(FOREACH_FUNCTION,
`START_FOREACH_FUNCTION
$1
START_FOREACH_BLOCK
$2
FINISH_FOREACH_FUNCTION')dnl
define(MASKED_FOREACH_FUNCTION,
`START_MASKED_FOREACH_FUNCTION
$1
START_MASKED_FOREACH_BLOCK
$2
FINISH_MASKED_FOREACH_FUNCTION')dnl
define(SCALAR_FOREACH_FUNCTION,
`
extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, 
	atype * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(`s'name`'rtype_qual`_'atype_code);

void
`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
	atype * const restrict array,
	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
  index_type rank;
  index_type dstride;
  index_type n;
  rtype_name *dest;

  if (mask == NULL || *mask)
    {
      name`'rtype_qual`_'atype_code (retarray, array, back);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype.rank = 1;
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
    }
  else if (unlikely (compile_options.bounds_check))
    {
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
			       "u_name");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  for (n = 0; n<rank; n++)
    dest[n * dstride] = $1 ;
}')dnl
Commit	Line	Data
6de9cd9a DN	1	dnl Support macro file for intrinsic functions.
6de9cd9a DN	2	dnl Contains the generic sections of the array functions.
21d1335b	3	dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
57dea9f6	4	dnl Distributed under the GNU GPL with exception. See COPYING for details.
6de9cd9a	5	define(START_FOREACH_FUNCTION,
7d7b8bfe	6	`
64acfd99	7	extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
64b1806b	8	atype * const restrict array, GFC_LOGICAL_4);
7f68c75f	9	export_proto(name`'rtype_qual`_'atype_code);
7d7b8bfe RH	10
7d7b8bfe RH	11	void
64acfd99	12	name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
64b1806b	13	atype * const restrict array, GFC_LOGICAL_4 back)
6de9cd9a DN	14	{
	15	index_type count[GFC_MAX_DIMENSIONS];
	16	index_type extent[GFC_MAX_DIMENSIONS];
	17	index_type sstride[GFC_MAX_DIMENSIONS];
	18	index_type dstride;
64acfd99	19	const atype_name *base;
5863aacf	20	rtype_name * restrict dest;
6de9cd9a DN	21	index_type rank;
	22	index_type n;
	23
	24	rank = GFC_DESCRIPTOR_RANK (array);
50dd63a9 TK	25	if (rank <= 0)
	26	runtime_error ("Rank of array needs to be > 0");
	27
21d1335b	28	if (retarray->base_addr == NULL)
50dd63a9	29	{
dfb55fdc	30	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
ca708a2b	31	retarray->dtype.rank = 1;
efd4dc1a	32	retarray->offset = 0;
92e6f3a4	33	retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
50dd63a9 TK	34	}
	35	else
	36	{
9731c4a3	37	if (unlikely (compile_options.bounds_check))
80927a56 JJ	38	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
80927a56 JJ	39	"u_name");
50dd63a9	40	}
c6abe94d	41
dfb55fdc	42	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
21d1335b	43	dest = retarray->base_addr;
6de9cd9a DN	44	for (n = 0; n < rank; n++)
6de9cd9a DN	45	{
dfb55fdc TK	46	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	47	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
6de9cd9a DN	48	count[n] = 0;
	49	if (extent[n] <= 0)
	50	{
	51	/* Set the return value. */
	52	for (n = 0; n < rank; n++)
	53	dest[n * dstride] = 0;
	54	return;
	55	}
	56	}
	57
21d1335b	58	base = array->base_addr;
6de9cd9a DN	59
	60	/* Initialize the return value. */
	61	for (n = 0; n < rank; n++)
80927a56	62	dest[n * dstride] = 1;
6de9cd9a DN	63	{
	64	')dnl
	65	define(START_FOREACH_BLOCK,
	66	` while (base)
	67	{
80927a56	68	/* Implementation start. */
6de9cd9a DN	69	')dnl
6de9cd9a DN	70	define(FINISH_FOREACH_FUNCTION,
80927a56 JJ	71	` /* Implementation end. */
	72	/* Advance to the next element. */
	73	base += sstride[0];
	74	}
	75	while (++count[0] != extent[0]);
6de9cd9a	76	n = 0;
80927a56 JJ	77	do
	78	{
	79	/* When we get to the end of a dimension, reset it and increment
	80	the next dimension. */
	81	count[n] = 0;
	82	/* We could precalculate these products, but this is a less
	83	frequently used path so probably not worth it. */
	84	base -= sstride[n] * extent[n];
	85	n++;
80dd631f	86	if (n >= rank)
80927a56 JJ	87	{
	88	/* Break out of the loop. */
	89	base = NULL;
	90	break;
	91	}
	92	else
	93	{
	94	count[n]++;
	95	base += sstride[n];
	96	}
	97	}
	98	while (count[n] == extent[n]);
6de9cd9a DN	99	}
	100	}
	101	}')dnl
	102	define(START_MASKED_FOREACH_FUNCTION,
7d7b8bfe	103	`
64acfd99	104	extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
64b1806b TK	105	atype * const restrict, gfc_array_l1 * const restrict,
64b1806b TK	106	GFC_LOGICAL_4);
7f68c75f	107	export_proto(`m'name`'rtype_qual`_'atype_code);
7d7b8bfe RH	108
7d7b8bfe RH	109	void
64acfd99 JB	110	`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
64acfd99 JB	111	atype * const restrict array,
64b1806b	112	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
6de9cd9a DN	113	{
	114	index_type count[GFC_MAX_DIMENSIONS];
	115	index_type extent[GFC_MAX_DIMENSIONS];
	116	index_type sstride[GFC_MAX_DIMENSIONS];
	117	index_type mstride[GFC_MAX_DIMENSIONS];
	118	index_type dstride;
	119	rtype_name *dest;
64acfd99	120	const atype_name *base;
28dc6b33	121	GFC_LOGICAL_1 *mbase;
6de9cd9a DN	122	int rank;
6de9cd9a DN	123	index_type n;
28dc6b33	124	int mask_kind;
6de9cd9a	125
2ea47ee9 TK	126
	127	if (mask == NULL)
	128	{
	129	name`'rtype_qual`_'atype_code (retarray, array, back);
	130	return;
	131	}
	132
6de9cd9a	133	rank = GFC_DESCRIPTOR_RANK (array);
50dd63a9 TK	134	if (rank <= 0)
	135	runtime_error ("Rank of array needs to be > 0");
	136
21d1335b	137	if (retarray->base_addr == NULL)
50dd63a9	138	{
dfb55fdc	139	GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
ca708a2b	140	retarray->dtype.rank = 1;
efd4dc1a	141	retarray->offset = 0;
92e6f3a4	142	retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
50dd63a9 TK	143	}
	144	else
	145	{
9731c4a3	146	if (unlikely (compile_options.bounds_check))
fd6590f8	147	{
fd6590f8	148
16bff921 TK	149	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	150	"u_name");
	151	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	152	"MASK argument", "u_name");
fd6590f8	153	}
50dd63a9	154	}
6de9cd9a	155
28dc6b33 TK	156	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
28dc6b33 TK	157
21d1335b	158	mbase = mask->base_addr;
28dc6b33 TK	159
	160	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	161	#ifdef HAVE_GFC_LOGICAL_16
	162	\|\| mask_kind == 16
	163	#endif
	164	)
	165	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	166	else
	167	runtime_error ("Funny sized logical array");
	168
dfb55fdc	169	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
21d1335b	170	dest = retarray->base_addr;
6de9cd9a DN	171	for (n = 0; n < rank; n++)
6de9cd9a DN	172	{
dfb55fdc TK	173	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	174	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	175	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
6de9cd9a DN	176	count[n] = 0;
	177	if (extent[n] <= 0)
	178	{
	179	/* Set the return value. */
	180	for (n = 0; n < rank; n++)
	181	dest[n * dstride] = 0;
	182	return;
	183	}
	184	}
	185
21d1335b	186	base = array->base_addr;
6de9cd9a DN	187
	188	/* Initialize the return value. */
	189	for (n = 0; n < rank; n++)
a4b9e93e	190	dest[n * dstride] = 0;
6de9cd9a DN	191	{
	192	')dnl
	193	define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
	194	define(FINISH_MASKED_FOREACH_FUNCTION,
80927a56 JJ	195	` /* Implementation end. */
	196	/* Advance to the next element. */
	197	base += sstride[0];
	198	mbase += mstride[0];
	199	}
	200	while (++count[0] != extent[0]);
6de9cd9a	201	n = 0;
80927a56 JJ	202	do
	203	{
	204	/* When we get to the end of a dimension, reset it and increment
	205	the next dimension. */
	206	count[n] = 0;
	207	/* We could precalculate these products, but this is a less
	208	frequently used path so probably not worth it. */
	209	base -= sstride[n] * extent[n];
	210	mbase -= mstride[n] * extent[n];
	211	n++;
80dd631f	212	if (n >= rank)
80927a56 JJ	213	{
	214	/* Break out of the loop. */
	215	base = NULL;
	216	break;
	217	}
	218	else
	219	{
	220	count[n]++;
	221	base += sstride[n];
	222	mbase += mstride[n];
	223	}
	224	}
	225	while (count[n] == extent[n]);
6de9cd9a DN	226	}
	227	}
	228	}')dnl
	229	define(FOREACH_FUNCTION,
	230	`START_FOREACH_FUNCTION
	231	$1
	232	START_FOREACH_BLOCK
	233	$2
	234	FINISH_FOREACH_FUNCTION')dnl
	235	define(MASKED_FOREACH_FUNCTION,
	236	`START_MASKED_FOREACH_FUNCTION
	237	$1
	238	START_MASKED_FOREACH_BLOCK
	239	$2
	240	FINISH_MASKED_FOREACH_FUNCTION')dnl
97a62038 TK	241	define(SCALAR_FOREACH_FUNCTION,
	242	`
	243	extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
64b1806b	244	atype * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
97a62038 TK	245	export_proto(`s'name`'rtype_qual`_'atype_code);
	246
	247	void
	248	`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
	249	atype * const restrict array,
64b1806b	250	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
97a62038 TK	251	{
	252	index_type rank;
	253	index_type dstride;
	254	index_type n;
	255	rtype_name *dest;
	256
2ea47ee9	257	if (mask == NULL \|\| *mask)
97a62038	258	{
64b1806b	259	name`'rtype_qual`_'atype_code (retarray, array, back);
97a62038 TK	260	return;
	261	}
	262
	263	rank = GFC_DESCRIPTOR_RANK (array);
	264
	265	if (rank <= 0)
	266	runtime_error ("Rank of array needs to be > 0");
	267
21d1335b	268	if (retarray->base_addr == NULL)
97a62038	269	{
dfb55fdc	270	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
ca708a2b	271	retarray->dtype.rank = 1;
97a62038	272	retarray->offset = 0;
92e6f3a4	273	retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
97a62038	274	}
16bff921	275	else if (unlikely (compile_options.bounds_check))
97a62038	276	{
16bff921 TK	277	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
16bff921 TK	278	"u_name");
97a62038 TK	279	}
97a62038 TK	280
dfb55fdc	281	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
21d1335b	282	dest = retarray->base_addr;
97a62038 TK	283	for (n = 0; n<rank; n++)
	284	dest[n * dstride] = $1 ;
	285	}')dnl