[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 95 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);
export_proto(name`'rtype_qual`_'atype_code);

void
name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
	atype * const restrict array)
{
  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->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
    }
  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->data;
  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->data;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {
')dnl
define(START_FOREACH_BLOCK,
`  while (base)
    {
      {
        /* Implementation start.  */
')dnl
define(FINISH_FOREACH_FUNCTION,
`        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[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];
          n++;
          if (n == rank)
            {
              /* Break out of the loop.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[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);
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)
{
  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;

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

  if (retarray->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
    }
  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->data;

  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->data;
  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->data;

  /* 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.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[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];
          n++;
          if (n == rank)
            {
              /* Break out of the loop.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[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 *);
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)
{
  index_type rank;
  index_type dstride;
  index_type n;
  rtype_name *dest;

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

  rank = GFC_DESCRIPTOR_RANK (array);

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

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