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

/* Implementation of the IALL intrinsic
   Copyright (C) 2010-2013 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_4) && defined (HAVE_GFC_INTEGER_4)


extern void iall_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict);
export_proto(iall_i4);

void
iall_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict base;
  GFC_INTEGER_4 * 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 = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
    		   * extent[rank-1];

      retarray->base_addr = xmalloc (alloc_size);
      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"
		       " IALL 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", "IALL");
    }

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

  result = (GFC_INTEGER_4) -1;
	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 miall_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(miall_i4);

void
miall_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict dest;
  const GFC_INTEGER_4 * 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 = sizeof (GFC_INTEGER_4) * 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 = xmalloc (alloc_size);

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

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

  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_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 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 siall_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(siall_i4);

void
siall_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      iall_i4 (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 = sizeof (GFC_INTEGER_4) * 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 = xmalloc (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " IALL 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"
			       " IALL 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
195a95c4	1	/* Implementation of the IALL intrinsic
e3c063ce	2	Copyright (C) 2010-2013 Free Software Foundation, Inc.
195a95c4 TB	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_4) && defined (HAVE_GFC_INTEGER_4)
	32
	33
	34	extern void iall_i4 (gfc_array_i4 * const restrict,
	35	gfc_array_i4 * const restrict, const index_type * const restrict);
	36	export_proto(iall_i4);
	37
	38	void
	39	iall_i4 (gfc_array_i4 * const restrict retarray,
	40	gfc_array_i4 * 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_4 * restrict base;
	48	GFC_INTEGER_4 * 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
21d1335b	82	if (retarray->base_addr == NULL)
195a95c4 TB	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
	100	alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
	101	* extent[rank-1];
	102
1a0fd3d3	103	retarray->base_addr = xmalloc (alloc_size);
195a95c4 TB	104	if (alloc_size == 0)
	105	{
	106	/* Make sure we have a zero-sized array. */
	107	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	108	return;
	109
	110	}
195a95c4 TB	111	}
	112	else
	113	{
	114	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	115	runtime_error ("rank of return array incorrect in"
	116	" IALL intrinsic: is %ld, should be %ld",
	117	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	118	(long int) rank);
	119
	120	if (unlikely (compile_options.bounds_check))
	121	bounds_ifunction_return ((array_t *) retarray, extent,
	122	"return value", "IALL");
	123	}
	124
	125	for (n = 0; n < rank; n++)
	126	{
	127	count[n] = 0;
	128	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	129	if (extent[n] <= 0)
3d2244b9	130	return;
195a95c4 TB	131	}
195a95c4 TB	132
21d1335b TB	133	base = array->base_addr;
21d1335b TB	134	dest = retarray->base_addr;
195a95c4 TB	135
	136	continue_loop = 1;
	137	while (continue_loop)
	138	{
	139	const GFC_INTEGER_4 * restrict src;
	140	GFC_INTEGER_4 result;
	141	src = base;
	142	{
	143
	144	result = (GFC_INTEGER_4) -1;
	145	if (len <= 0)
	146	*dest = 0;
	147	else
	148	{
	149	for (n = 0; n < len; n++, src += delta)
	150	{
	151
	152	result &= *src;
	153	}
	154
	155	*dest = result;
	156	}
	157	}
	158	/* Advance to the next element. */
	159	count[0]++;
	160	base += sstride[0];
	161	dest += dstride[0];
	162	n = 0;
	163	while (count[n] == extent[n])
	164	{
	165	/* When we get to the end of a dimension, reset it and increment
	166	the next dimension. */
	167	count[n] = 0;
	168	/* We could precalculate these products, but this is a less
	169	frequently used path so probably not worth it. */
	170	base -= sstride[n] * extent[n];
	171	dest -= dstride[n] * extent[n];
	172	n++;
	173	if (n == rank)
	174	{
	175	/* Break out of the look. */
	176	continue_loop = 0;
	177	break;
	178	}
	179	else
	180	{
	181	count[n]++;
	182	base += sstride[n];
	183	dest += dstride[n];
	184	}
	185	}
	186	}
	187	}
	188
	189
	190	extern void miall_i4 (gfc_array_i4 * const restrict,
	191	gfc_array_i4 * const restrict, const index_type * const restrict,
	192	gfc_array_l1 * const restrict);
	193	export_proto(miall_i4);
	194
	195	void
	196	miall_i4 (gfc_array_i4 * const restrict retarray,
	197	gfc_array_i4 * const restrict array,
	198	const index_type * const restrict pdim,
199	gfc_array_l1 * const restrict mask)
200	{
201	index_type count[GFC_MAX_DIMENSIONS];
202	index_type extent[GFC_MAX_DIMENSIONS];
203	index_type sstride[GFC_MAX_DIMENSIONS];
204	index_type dstride[GFC_MAX_DIMENSIONS];
205	index_type mstride[GFC_MAX_DIMENSIONS];
206	GFC_INTEGER_4 * restrict dest;
207	const GFC_INTEGER_4 * restrict base;
208	const GFC_LOGICAL_1 * restrict mbase;
209	int rank;
210	int dim;
211	index_type n;
212	index_type len;
213	index_type delta;
214	index_type mdelta;
215	int mask_kind;
216
217	dim = (*pdim) - 1;
218	rank = GFC_DESCRIPTOR_RANK (array) - 1;
219
220	len = GFC_DESCRIPTOR_EXTENT(array,dim);
221	if (len <= 0)
222	return;
223
21d1335b	224	mbase = mask->base_addr;
195a95c4 TB	225
	226	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	227
	228	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	229	#ifdef HAVE_GFC_LOGICAL_16
	230	\|\| mask_kind == 16
	231	#endif
	232	)
	233	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	234	else
	235	runtime_error ("Funny sized logical array");
	236
	237	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	238	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	239
	240	for (n = 0; n < dim; n++)
	241	{
	242	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	243	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	244	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	245
	246	if (extent[n] < 0)
	247	extent[n] = 0;
	248
	249	}
	250	for (n = dim; n < rank; n++)
	251	{
	252	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	253	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	254	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	255
	256	if (extent[n] < 0)
	257	extent[n] = 0;
	258	}
	259
21d1335b	260	if (retarray->base_addr == NULL)
195a95c4 TB	261	{
	262	size_t alloc_size, str;
	263
	264	for (n = 0; n < rank; n++)
	265	{
	266	if (n == 0)
	267	str = 1;
	268	else
	269	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	270
	271	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	272
	273	}
	274
	275	alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
	276	* extent[rank-1];
	277
	278	retarray->offset = 0;
	279	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	280
	281	if (alloc_size == 0)
	282	{
	283	/* Make sure we have a zero-sized array. */
	284	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	285	return;
	286	}
	287	else
1a0fd3d3	288	retarray->base_addr = xmalloc (alloc_size);
195a95c4 TB	289
	290	}
	291	else
	292	{
	293	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	294	runtime_error ("rank of return array incorrect in IALL intrinsic");
	295
	296	if (unlikely (compile_options.bounds_check))
	297	{
	298	bounds_ifunction_return ((array_t *) retarray, extent,
	299	"return value", "IALL");
	300	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	301	"MASK argument", "IALL");
	302	}
	303	}
	304
	305	for (n = 0; n < rank; n++)
	306	{
	307	count[n] = 0;
	308	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	309	if (extent[n] <= 0)
	310	return;
	311	}
	312
21d1335b TB	313	dest = retarray->base_addr;
21d1335b TB	314	base = array->base_addr;
195a95c4 TB	315
	316	while (base)
	317	{
	318	const GFC_INTEGER_4 * restrict src;
	319	const GFC_LOGICAL_1 * restrict msrc;
	320	GFC_INTEGER_4 result;
	321	src = base;
	322	msrc = mbase;
	323	{
	324
	325	result = 0;
036e1775	326	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
195a95c4	327	{
195a95c4 TB	328
	329	if (*msrc)
	330	result &= *src;
195a95c4	331	}
036e1775	332	*dest = result;
195a95c4 TB	333	}
	334	/* Advance to the next element. */
	335	count[0]++;
	336	base += sstride[0];
	337	mbase += mstride[0];
	338	dest += dstride[0];
	339	n = 0;
	340	while (count[n] == extent[n])
	341	{
	342	/* When we get to the end of a dimension, reset it and increment
	343	the next dimension. */
	344	count[n] = 0;
	345	/* We could precalculate these products, but this is a less
	346	frequently used path so probably not worth it. */
	347	base -= sstride[n] * extent[n];
	348	mbase -= mstride[n] * extent[n];
	349	dest -= dstride[n] * extent[n];
	350	n++;
	351	if (n == rank)
	352	{
	353	/* Break out of the look. */
	354	base = NULL;
	355	break;
	356	}
	357	else
	358	{
	359	count[n]++;
	360	base += sstride[n];
	361	mbase += mstride[n];
	362	dest += dstride[n];
	363	}
	364	}
	365	}
	366	}
	367
	368
	369	extern void siall_i4 (gfc_array_i4 * const restrict,
	370	gfc_array_i4 * const restrict, const index_type * const restrict,
	371	GFC_LOGICAL_4 *);
	372	export_proto(siall_i4);
	373
	374	void
	375	siall_i4 (gfc_array_i4 * const restrict retarray,
	376	gfc_array_i4 * const restrict array,
	377	const index_type * const restrict pdim,
	378	GFC_LOGICAL_4 * mask)
	379	{
	380	index_type count[GFC_MAX_DIMENSIONS];
	381	index_type extent[GFC_MAX_DIMENSIONS];
	382	index_type dstride[GFC_MAX_DIMENSIONS];
	383	GFC_INTEGER_4 * restrict dest;
	384	index_type rank;
	385	index_type n;
	386	index_type dim;
	387
	388
	389	if (*mask)
	390	{
	391	iall_i4 (retarray, array, pdim);
	392	return;
	393	}
	394	/* Make dim zero based to avoid confusion. */
	395	dim = (*pdim) - 1;
	396	rank = GFC_DESCRIPTOR_RANK (array) - 1;
397
398	for (n = 0; n < dim; n++)
399	{
400	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
401
402	if (extent[n] <= 0)
403	extent[n] = 0;
404	}
405
406	for (n = dim; n < rank; n++)
407	{
408	extent[n] =
409	GFC_DESCRIPTOR_EXTENT(array,n + 1);
410
411	if (extent[n] <= 0)
412	extent[n] = 0;
413	}
414
21d1335b	415	if (retarray->base_addr == NULL)
195a95c4 TB	416	{
	417	size_t alloc_size, str;
	418
	419	for (n = 0; n < rank; n++)
	420	{
	421	if (n == 0)
	422	str = 1;
	423	else
	424	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	425
	426	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	427
	428	}
	429
	430	retarray->offset = 0;
	431	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	432
	433	alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
	434	* extent[rank-1];
	435
	436	if (alloc_size == 0)
	437	{
	438	/* Make sure we have a zero-sized array. */
	439	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	440	return;
	441	}
	442	else
1a0fd3d3	443	retarray->base_addr = xmalloc (alloc_size);
195a95c4 TB	444	}
	445	else
	446	{
	447	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	448	runtime_error ("rank of return array incorrect in"
	449	" IALL intrinsic: is %ld, should be %ld",
	450	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	451	(long int) rank);
	452
	453	if (unlikely (compile_options.bounds_check))
	454	{
	455	for (n=0; n < rank; n++)
	456	{
	457	index_type ret_extent;
	458
	459	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	460	if (extent[n] != ret_extent)
	461	runtime_error ("Incorrect extent in return value of"
	462	" IALL intrinsic in dimension %ld:"
	463	" is %ld, should be %ld", (long int) n + 1,
	464	(long int) ret_extent, (long int) extent[n]);
	465	}
	466	}
	467	}
	468
	469	for (n = 0; n < rank; n++)
	470	{
	471	count[n] = 0;
	472	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	473	}
	474
21d1335b	475	dest = retarray->base_addr;
195a95c4 TB	476
	477	while(1)
	478	{
	479	*dest = 0;
	480	count[0]++;
	481	dest += dstride[0];
	482	n = 0;
	483	while (count[n] == extent[n])
	484	{
	485	/* When we get to the end of a dimension, reset it and increment
	486	the next dimension. */
	487	count[n] = 0;
	488	/* We could precalculate these products, but this is a less
	489	frequently used path so probably not worth it. */
	490	dest -= dstride[n] * extent[n];
	491	n++;
	492	if (n == rank)
	493	return;
	494	else
	495	{
	496	count[n]++;
	497	dest += dstride[n];
	498	}
	499	}
	500	}
	501	}
	502
	503	#endif