[thirdparty/gcc.git] / libgfortran / m4 / iforeach-s2.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,
`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);

}

#define INITVAL 'initval`

extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict,
        gfc_charlen_type,
	atype * const restrict array, gfc_charlen_type);
export_proto(name`'rtype_qual`_'atype_code);

void
name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret,
        gfc_charlen_type xlen,
	'atype` * const restrict array, gfc_charlen_type len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  const 'atype_name` *base;
  index_type rank;
  index_type n;

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

  assert (xlen == len);

  /* Initialize return value.  */
  memset (ret, INITVAL, sizeof(*ret) * len);

  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
        return;
    }

  base = array->base_addr;

  {
')dnl
define(START_FOREACH_BLOCK,
`  while (base)
    {
      do
	{
	  /* 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]);
    }
   memcpy (ret, retval, len * sizeof (*ret));
  }
}')dnl
define(START_MASKED_FOREACH_FUNCTION,
`
extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict,
       gfc_charlen_type, atype * const restrict array,
       gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(`m'name`'rtype_qual`_'atype_code);

void
`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret,
	gfc_charlen_type xlen, atype * const restrict array,
	gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  const atype_name *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

  if (mask == NULL)
    {
      name`'rtype_qual`_'atype_code (ret, xlen, array, len);
      return;
    }

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

  assert (xlen == len);

/* Initialize return value.  */
  memset (ret, INITVAL, sizeof(*ret) * len);

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

  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
	return;
    }

  base = array->base_addr;
  {
')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]);
    }
    memcpy (ret, retval, len * sizeof (*ret));
  }
}')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 (atype_name * restrict,
        gfc_charlen_type,
	atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(`s'name`'rtype_qual`_'atype_code);

void
`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
        gfc_charlen_type xlen, atype * const restrict array,
	GFC_LOGICAL_4 *mask, gfc_charlen_type len)
	
{
  if (mask == NULL || *mask)
    {
      name`'rtype_qual`_'atype_code (ret, xlen, array, len);
      return;
    }
  memset (ret, INITVAL, sizeof (*ret) * len);
}')dnl
Commit	Line	Data
0ac74254 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	define(START_FOREACH_FUNCTION,
	6	`static inline int
	7	compare_fcn (const atype_name a, const atype_name b, gfc_charlen_type n)
	8	{
	9	if (sizeof ('atype_name`) == 1)
	10	return memcmp (a, b, n);
	11	else
	12	return memcmp_char4 (a, b, n);
	13
	14	}
	15
	16	#define INITVAL 'initval`
	17
	18	extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict,
	19	gfc_charlen_type,
	20	atype * const restrict array, gfc_charlen_type);
	21	export_proto(name`'rtype_qual`_'atype_code);
	22
	23	void
	24	name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret,
	25	gfc_charlen_type xlen,
	26	'atype` * const restrict array, gfc_charlen_type len)
	27	{
	28	index_type count[GFC_MAX_DIMENSIONS];
	29	index_type extent[GFC_MAX_DIMENSIONS];
	30	index_type sstride[GFC_MAX_DIMENSIONS];
	31	const 'atype_name` *base;
	32	index_type rank;
	33	index_type n;
	34
	35	rank = GFC_DESCRIPTOR_RANK (array);
	36	if (rank <= 0)
	37	runtime_error ("Rank of array needs to be > 0");
	38
	39	assert (xlen == len);
	40
	41	/* Initialize return value. */
	42	memset (ret, INITVAL, sizeof(ret) len);
	43
	44	for (n = 0; n < rank; n++)
	45	{
	46	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	47	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	48	count[n] = 0;
	49	if (extent[n] <= 0)
	50	return;
	51	}
	52
	53	base = array->base_addr;
	54
	55	{
	56	')dnl
	57	define(START_FOREACH_BLOCK,
	58	` while (base)
	59	{
	60	do
	61	{
	62	/* Implementation start. */
	63	')dnl
	64	define(FINISH_FOREACH_FUNCTION,
65	` /* Implementation end. */
66	/* Advance to the next element. */
67	base += sstride[0];
68	}
69	while (++count[0] != extent[0]);
70	n = 0;
71	do
72	{
73	/* When we get to the end of a dimension, reset it and increment
74	the next dimension. */
75	count[n] = 0;
76	/* We could precalculate these products, but this is a less
77	frequently used path so probably not worth it. */
78	base -= sstride[n] * extent[n];
79	n++;
80	if (n >= rank)
81	{
82	/* Break out of the loop. */
83	base = NULL;
84	break;
85	}
86	else
87	{
88	count[n]++;
89	base += sstride[n];
90	}
91	}
92	while (count[n] == extent[n]);
93	}
94	memcpy (ret, retval, len * sizeof (*ret));
95	}
96	}')dnl
97	define(START_MASKED_FOREACH_FUNCTION,
98	`
99	extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict,
100	gfc_charlen_type, atype * const restrict array,
101	gfc_array_l1 * const restrict mask, gfc_charlen_type len);
102	export_proto(`m'name`'rtype_qual`_'atype_code);
103
104	void
105	`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret,
106	gfc_charlen_type xlen, atype * const restrict array,
107	gfc_array_l1 * const restrict mask, gfc_charlen_type len)
108	{
109	index_type count[GFC_MAX_DIMENSIONS];
110	index_type extent[GFC_MAX_DIMENSIONS];
111	index_type sstride[GFC_MAX_DIMENSIONS];
112	index_type mstride[GFC_MAX_DIMENSIONS];
113	const atype_name *base;
114	GFC_LOGICAL_1 *mbase;
115	int rank;
116	index_type n;
117	int mask_kind;
118
2ea47ee9 TK	119	if (mask == NULL)
	120	{
	121	name`'rtype_qual`_'atype_code (ret, xlen, array, len);
	122	return;
	123	}
	124
0ac74254 TK	125	rank = GFC_DESCRIPTOR_RANK (array);
	126	if (rank <= 0)
	127	runtime_error ("Rank of array needs to be > 0");
	128
	129	assert (xlen == len);
	130
	131	/* Initialize return value. */
	132	memset (ret, INITVAL, sizeof(ret) len);
	133
	134	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	135
	136	mbase = mask->base_addr;
	137
	138	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	139	#ifdef HAVE_GFC_LOGICAL_16
	140	\|\| mask_kind == 16
	141	#endif
	142	)
	143	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	144	else
	145	runtime_error ("Funny sized logical array");
	146
	147	for (n = 0; n < rank; n++)
	148	{
	149	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	150	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	151	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	152	count[n] = 0;
	153	if (extent[n] <= 0)
	154	return;
	155	}
	156
	157	base = array->base_addr;
	158	{
	159	')dnl
	160	define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
	161	define(FINISH_MASKED_FOREACH_FUNCTION,
	162	` /* Implementation end. */
	163	/* Advance to the next element. */
	164	base += sstride[0];
	165	mbase += mstride[0];
	166	}
	167	while (++count[0] != extent[0]);
	168	n = 0;
	169	do
	170	{
	171	/* When we get to the end of a dimension, reset it and increment
	172	the next dimension. */
	173	count[n] = 0;
	174	/* We could precalculate these products, but this is a less
	175	frequently used path so probably not worth it. */
	176	base -= sstride[n] * extent[n];
	177	mbase -= mstride[n] * extent[n];
	178	n++;
	179	if (n >= rank)
	180	{
	181	/* Break out of the loop. */
	182	base = NULL;
	183	break;
	184	}
	185	else
	186	{
	187	count[n]++;
	188	base += sstride[n];
189	mbase += mstride[n];
190	}
191	}
192	while (count[n] == extent[n]);
193	}
194	memcpy (ret, retval, len * sizeof (*ret));
195	}
196	}')dnl
197	define(FOREACH_FUNCTION,
198	`START_FOREACH_FUNCTION
199	$1
200	START_FOREACH_BLOCK
201	$2
202	FINISH_FOREACH_FUNCTION')dnl
203	define(MASKED_FOREACH_FUNCTION,
204	`START_MASKED_FOREACH_FUNCTION
205	$1
206	START_MASKED_FOREACH_BLOCK
207	$2
208	FINISH_MASKED_FOREACH_FUNCTION')dnl
209	define(SCALAR_FOREACH_FUNCTION,
210	`
211	extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
212	gfc_charlen_type,
213	atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
214	export_proto(`s'name`'rtype_qual`_'atype_code);
215
216	void
217	`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
218	gfc_charlen_type xlen, atype * const restrict array,
219	GFC_LOGICAL_4 *mask, gfc_charlen_type len)
220
221	{
2ea47ee9	222	if (mask == NULL \|\| *mask)
0ac74254 TK	223	{
	224	name`'rtype_qual`_'atype_code (ret, xlen, array, len);
	225	return;
	226	}
	227	memset (ret, INITVAL, sizeof (ret) len);
	228	}')dnl