[thirdparty/gcc.git] / libgfortran / generated / iany_i2.c

/* Implementation of the IANY intrinsic
   Copyright (C) 2010-2016 Free Software Foundation, Inc.
   Contributed by Tobias Burnus <burnus@net-b.de>

This file is part of the GNU Fortran runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>


#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)


extern void iany_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict);
export_proto(iany_i2);

void
iany_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim)
{
  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 GFC_INTEGER_2 * restrict base;
  GFC_INTEGER_2 * 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.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_2));
      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"
		       " IANY 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", "IANY");
    }

  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 GFC_INTEGER_2 * restrict src;
      GFC_INTEGER_2 result;
      src = base;
      {

  result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

  result |= *src;
	      }
	    
	    *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 look.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void miany_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(miany_i2);

void
miany_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim, 
	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 dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_2 * restrict dest;
  const GFC_INTEGER_2 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int 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;

  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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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 (GFC_INTEGER_2));

    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in IANY intrinsic");

      if (unlikely (compile_options.bounds_check))
	{
	  bounds_ifunction_return ((array_t *) retarray, extent,
				   "return value", "IANY");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
	  			"MASK argument", "IANY");
	}
    }

  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 GFC_INTEGER_2 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_2 result;
      src = base;
      msrc = mbase;
      {

  result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

  if (*msrc)
    result |= *src;
	  }
	*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 look.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void siany_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(siany_i2);

void
siany_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_2 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      iany_i2 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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 (GFC_INTEGER_2));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " IANY 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"
			       " IANY 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 = 0;
      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];
	    }
      	}
    }
}

#endif
Commit	Line	Data
9028d57d	1	/* Implementation of the IANY intrinsic
f1717362	2	Copyright (C) 2010-2016 Free Software Foundation, Inc.
9028d57d	3	Contributed by Tobias Burnus <burnus@net-b.de>
	4
	5	This file is part of the GNU Fortran runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
	10	version 3 of the License, or (at your option) any later version.
	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
	25
	26	#include "libgfortran.h"
	27	#include <stdlib.h>
	28	#include <assert.h>
	29
	30
	31	#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)
	32
	33
	34	extern void iany_i2 (gfc_array_i2 * const restrict,
	35	gfc_array_i2 * const restrict, const index_type * const restrict);
	36	export_proto(iany_i2);
	37
	38	void
	39	iany_i2 (gfc_array_i2 * const restrict retarray,
	40	gfc_array_i2 * const restrict array,
	41	const index_type * const restrict pdim)
	42	{
	43	index_type count[GFC_MAX_DIMENSIONS];
	44	index_type extent[GFC_MAX_DIMENSIONS];
	45	index_type sstride[GFC_MAX_DIMENSIONS];
	46	index_type dstride[GFC_MAX_DIMENSIONS];
	47	const GFC_INTEGER_2 * restrict base;
	48	GFC_INTEGER_2 * restrict dest;
	49	index_type rank;
	50	index_type n;
	51	index_type len;
	52	index_type delta;
	53	index_type dim;
	54	int continue_loop;
	55
	56	/* Make dim zero based to avoid confusion. */
	57	dim = (*pdim) - 1;
	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	59
	60	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	61	if (len < 0)
	62	len = 0;
	63	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	64
	65	for (n = 0; n < dim; n++)
	66	{
67	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
68	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
69
70	if (extent[n] < 0)
71	extent[n] = 0;
72	}
73	for (n = dim; n < rank; n++)
74	{
75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
76	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
77
78	if (extent[n] < 0)
79	extent[n] = 0;
80	}
81
553877d9	82	if (retarray->base_addr == NULL)
9028d57d	83	{
	84	size_t alloc_size, str;
	85
	86	for (n = 0; n < rank; n++)
	87	{
	88	if (n == 0)
	89	str = 1;
	90	else
	91	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	92
	93	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	94
	95	}
	96
	97	retarray->offset = 0;
	98	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	99
af1e9051	100	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
9028d57d	101
af1e9051	102	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_2));
9028d57d	103	if (alloc_size == 0)
	104	{
	105	/* Make sure we have a zero-sized array. */
	106	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	107	return;
	108
	109	}
9028d57d	110	}
	111	else
	112	{
	113	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	114	runtime_error ("rank of return array incorrect in"
	115	" IANY intrinsic: is %ld, should be %ld",
	116	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	117	(long int) rank);
	118
	119	if (unlikely (compile_options.bounds_check))
	120	bounds_ifunction_return ((array_t *) retarray, extent,
	121	"return value", "IANY");
	122	}
	123
	124	for (n = 0; n < rank; n++)
	125	{
	126	count[n] = 0;
	127	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	128	if (extent[n] <= 0)
5f98de31	129	return;
9028d57d	130	}
9028d57d	131
553877d9	132	base = array->base_addr;
553877d9	133	dest = retarray->base_addr;
9028d57d	134
	135	continue_loop = 1;
	136	while (continue_loop)
	137	{
	138	const GFC_INTEGER_2 * restrict src;
	139	GFC_INTEGER_2 result;
	140	src = base;
	141	{
	142
	143	result = 0;
	144	if (len <= 0)
	145	*dest = 0;
	146	else
	147	{
	148	for (n = 0; n < len; n++, src += delta)
	149	{
	150
	151	result \|= *src;
	152	}
	153
	154	*dest = result;
	155	}
	156	}
	157	/* Advance to the next element. */
	158	count[0]++;
	159	base += sstride[0];
	160	dest += dstride[0];
	161	n = 0;
	162	while (count[n] == extent[n])
	163	{
	164	/* When we get to the end of a dimension, reset it and increment
	165	the next dimension. */
	166	count[n] = 0;
	167	/* We could precalculate these products, but this is a less
	168	frequently used path so probably not worth it. */
	169	base -= sstride[n] * extent[n];
	170	dest -= dstride[n] * extent[n];
	171	n++;
	172	if (n == rank)
	173	{
	174	/* Break out of the look. */
	175	continue_loop = 0;
	176	break;
	177	}
	178	else
	179	{
	180	count[n]++;
	181	base += sstride[n];
	182	dest += dstride[n];
	183	}
	184	}
	185	}
	186	}
	187
	188
	189	extern void miany_i2 (gfc_array_i2 * const restrict,
	190	gfc_array_i2 * const restrict, const index_type * const restrict,
	191	gfc_array_l1 * const restrict);
	192	export_proto(miany_i2);
	193
	194	void
	195	miany_i2 (gfc_array_i2 * const restrict retarray,
	196	gfc_array_i2 * const restrict array,
	197	const index_type * const restrict pdim,
198	gfc_array_l1 * const restrict mask)
199	{
200	index_type count[GFC_MAX_DIMENSIONS];
201	index_type extent[GFC_MAX_DIMENSIONS];
202	index_type sstride[GFC_MAX_DIMENSIONS];
203	index_type dstride[GFC_MAX_DIMENSIONS];
204	index_type mstride[GFC_MAX_DIMENSIONS];
205	GFC_INTEGER_2 * restrict dest;
206	const GFC_INTEGER_2 * restrict base;
207	const GFC_LOGICAL_1 * restrict mbase;
208	int rank;
209	int dim;
210	index_type n;
211	index_type len;
212	index_type delta;
213	index_type mdelta;
214	int mask_kind;
215
216	dim = (*pdim) - 1;
217	rank = GFC_DESCRIPTOR_RANK (array) - 1;
218
219	len = GFC_DESCRIPTOR_EXTENT(array,dim);
220	if (len <= 0)
221	return;
222
553877d9	223	mbase = mask->base_addr;
9028d57d	224
	225	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	226
	227	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	228	#ifdef HAVE_GFC_LOGICAL_16
	229	\|\| mask_kind == 16
	230	#endif
	231	)
	232	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	233	else
	234	runtime_error ("Funny sized logical array");
	235
	236	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	237	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	238
	239	for (n = 0; n < dim; n++)
	240	{
	241	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	242	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	243	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	244
	245	if (extent[n] < 0)
	246	extent[n] = 0;
	247
	248	}
	249	for (n = dim; n < rank; n++)
	250	{
	251	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	252	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	253	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	254
	255	if (extent[n] < 0)
	256	extent[n] = 0;
	257	}
	258
553877d9	259	if (retarray->base_addr == NULL)
9028d57d	260	{
	261	size_t alloc_size, str;
	262
	263	for (n = 0; n < rank; n++)
	264	{
	265	if (n == 0)
	266	str = 1;
	267	else
	268	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	269
	270	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	271
	272	}
	273
af1e9051	274	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
9028d57d	275
	276	retarray->offset = 0;
	277	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	278
	279	if (alloc_size == 0)
	280	{
	281	/* Make sure we have a zero-sized array. */
	282	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	283	return;
	284	}
	285	else
af1e9051	286	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_2));
9028d57d	287
	288	}
	289	else
	290	{
	291	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	292	runtime_error ("rank of return array incorrect in IANY intrinsic");
	293
	294	if (unlikely (compile_options.bounds_check))
	295	{
	296	bounds_ifunction_return ((array_t *) retarray, extent,
	297	"return value", "IANY");
	298	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	299	"MASK argument", "IANY");
	300	}
	301	}
	302
	303	for (n = 0; n < rank; n++)
	304	{
	305	count[n] = 0;
	306	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	307	if (extent[n] <= 0)
	308	return;
	309	}
	310
553877d9	311	dest = retarray->base_addr;
553877d9	312	base = array->base_addr;
9028d57d	313
	314	while (base)
	315	{
	316	const GFC_INTEGER_2 * restrict src;
	317	const GFC_LOGICAL_1 * restrict msrc;
	318	GFC_INTEGER_2 result;
	319	src = base;
	320	msrc = mbase;
	321	{
	322
	323	result = 0;
08e1eb56	324	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
9028d57d	325	{
9028d57d	326
	327	if (*msrc)
	328	result \|= *src;
9028d57d	329	}
08e1eb56	330	*dest = result;
9028d57d	331	}
	332	/* Advance to the next element. */
	333	count[0]++;
	334	base += sstride[0];
	335	mbase += mstride[0];
	336	dest += dstride[0];
	337	n = 0;
	338	while (count[n] == extent[n])
	339	{
	340	/* When we get to the end of a dimension, reset it and increment
	341	the next dimension. */
	342	count[n] = 0;
	343	/* We could precalculate these products, but this is a less
	344	frequently used path so probably not worth it. */
	345	base -= sstride[n] * extent[n];
	346	mbase -= mstride[n] * extent[n];
	347	dest -= dstride[n] * extent[n];
	348	n++;
	349	if (n == rank)
	350	{
	351	/* Break out of the look. */
	352	base = NULL;
	353	break;
	354	}
	355	else
	356	{
	357	count[n]++;
	358	base += sstride[n];
	359	mbase += mstride[n];
	360	dest += dstride[n];
	361	}
	362	}
	363	}
	364	}
	365
	366
	367	extern void siany_i2 (gfc_array_i2 * const restrict,
	368	gfc_array_i2 * const restrict, const index_type * const restrict,
	369	GFC_LOGICAL_4 *);
	370	export_proto(siany_i2);
	371
	372	void
	373	siany_i2 (gfc_array_i2 * const restrict retarray,
	374	gfc_array_i2 * const restrict array,
	375	const index_type * const restrict pdim,
	376	GFC_LOGICAL_4 * mask)
	377	{
	378	index_type count[GFC_MAX_DIMENSIONS];
	379	index_type extent[GFC_MAX_DIMENSIONS];
	380	index_type dstride[GFC_MAX_DIMENSIONS];
	381	GFC_INTEGER_2 * restrict dest;
	382	index_type rank;
	383	index_type n;
	384	index_type dim;
	385
	386
	387	if (*mask)
	388	{
	389	iany_i2 (retarray, array, pdim);
	390	return;
	391	}
	392	/* Make dim zero based to avoid confusion. */
	393	dim = (*pdim) - 1;
	394	rank = GFC_DESCRIPTOR_RANK (array) - 1;
395
396	for (n = 0; n < dim; n++)
397	{
398	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
399
400	if (extent[n] <= 0)
401	extent[n] = 0;
402	}
403
404	for (n = dim; n < rank; n++)
405	{
406	extent[n] =
407	GFC_DESCRIPTOR_EXTENT(array,n + 1);
408
409	if (extent[n] <= 0)
410	extent[n] = 0;
411	}
412
553877d9	413	if (retarray->base_addr == NULL)
9028d57d	414	{
	415	size_t alloc_size, str;
	416
	417	for (n = 0; n < rank; n++)
	418	{
	419	if (n == 0)
	420	str = 1;
	421	else
	422	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	423
	424	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	425
	426	}
	427
	428	retarray->offset = 0;
	429	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	430
af1e9051	431	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
9028d57d	432
	433	if (alloc_size == 0)
	434	{
	435	/* Make sure we have a zero-sized array. */
	436	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	437	return;
	438	}
	439	else
af1e9051	440	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_2));
9028d57d	441	}
	442	else
	443	{
	444	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	445	runtime_error ("rank of return array incorrect in"
	446	" IANY intrinsic: is %ld, should be %ld",
	447	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	448	(long int) rank);
	449
	450	if (unlikely (compile_options.bounds_check))
	451	{
	452	for (n=0; n < rank; n++)
	453	{
	454	index_type ret_extent;
	455
	456	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	457	if (extent[n] != ret_extent)
	458	runtime_error ("Incorrect extent in return value of"
	459	" IANY intrinsic in dimension %ld:"
	460	" is %ld, should be %ld", (long int) n + 1,
	461	(long int) ret_extent, (long int) extent[n]);
	462	}
	463	}
	464	}
	465
	466	for (n = 0; n < rank; n++)
	467	{
	468	count[n] = 0;
	469	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	470	}
	471
553877d9	472	dest = retarray->base_addr;
9028d57d	473
	474	while(1)
	475	{
	476	*dest = 0;
	477	count[0]++;
	478	dest += dstride[0];
	479	n = 0;
	480	while (count[n] == extent[n])
	481	{
	482	/* When we get to the end of a dimension, reset it and increment
	483	the next dimension. */
	484	count[n] = 0;
	485	/* We could precalculate these products, but this is a less
	486	frequently used path so probably not worth it. */
	487	dest -= dstride[n] * extent[n];
	488	n++;
	489	if (n == rank)
	490	return;
	491	else
	492	{
	493	count[n]++;
	494	dest += dstride[n];
	495	}
	496	}
	497	}
	498	}
	499
	500	#endif