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

/* Implementation of the IALL intrinsic
   Copyright (C) 2010-2020 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"


#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)


extern void iall_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict);
export_proto(iall_i1);

void
iall_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * 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_1 * restrict base;
  GFC_INTEGER_1 * 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.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in IALL intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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.rank = rank;

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
      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_1 * restrict src;
      GFC_INTEGER_1 result;
      src = base;
      {

  result = (GFC_INTEGER_1) -1;
	if (len <= 0)
	  *dest = 0;
	else
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

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


extern void miall_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(miall_i1);

void
miall_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * 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_1 * restrict dest;
  const GFC_INTEGER_1 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      iall_i1 (retarray, array, pdim, back);
#else
      iall_i1 (retarray, array, pdim);
#endif
      return;
    }

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in IALL intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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.rank = 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_1));

    }
  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_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_1 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 loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void siall_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(siall_i1);

void
siall_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * 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_1 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      iall_i1 (retarray, array, pdim, back);
#else
      iall_i1 (retarray, array, pdim);
#endif
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in IALL intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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.rank = 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_1));
    }
  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
8d9254fc	2	Copyright (C) 2010-2020 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"
195a95c4 TB	27
	28
	29	#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
	30
	31
	32	extern void iall_i1 (gfc_array_i1 * const restrict,
	33	gfc_array_i1 * const restrict, const index_type * const restrict);
	34	export_proto(iall_i1);
	35
	36	void
	37	iall_i1 (gfc_array_i1 * const restrict retarray,
	38	gfc_array_i1 * const restrict array,
	39	const index_type * const restrict pdim)
	40	{
	41	index_type count[GFC_MAX_DIMENSIONS];
	42	index_type extent[GFC_MAX_DIMENSIONS];
	43	index_type sstride[GFC_MAX_DIMENSIONS];
	44	index_type dstride[GFC_MAX_DIMENSIONS];
	45	const GFC_INTEGER_1 * restrict base;
	46	GFC_INTEGER_1 * restrict dest;
	47	index_type rank;
	48	index_type n;
	49	index_type len;
	50	index_type delta;
	51	index_type dim;
	52	int continue_loop;
	53
	54	/* Make dim zero based to avoid confusion. */
195a95c4	55	rank = GFC_DESCRIPTOR_RANK (array) - 1;
cfdf6ff6 TK	56	dim = (*pdim) - 1;
	57
	58	if (unlikely (dim < 0 \|\| dim > rank))
	59	{
	60	runtime_error ("Dim argument incorrect in IALL intrinsic: "
	61	"is %ld, should be between 1 and %ld",
	62	(long int) dim + 1, (long int) rank + 1);
	63	}
195a95c4 TB	64
	65	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	66	if (len < 0)
	67	len = 0;
	68	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	69
	70	for (n = 0; n < dim; n++)
	71	{
	72	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	73	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	74
	75	if (extent[n] < 0)
	76	extent[n] = 0;
	77	}
	78	for (n = dim; n < rank; n++)
	79	{
	80	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
	81	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	82
	83	if (extent[n] < 0)
	84	extent[n] = 0;
	85	}
	86
21d1335b	87	if (retarray->base_addr == NULL)
195a95c4 TB	88	{
	89	size_t alloc_size, str;
	90
	91	for (n = 0; n < rank; n++)
	92	{
	93	if (n == 0)
	94	str = 1;
	95	else
	96	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	97
	98	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	99
	100	}
	101
	102	retarray->offset = 0;
ca708a2b	103	retarray->dtype.rank = rank;
195a95c4	104
92e6f3a4	105	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
195a95c4	106
92e6f3a4	107	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
195a95c4 TB	108	if (alloc_size == 0)
	109	{
	110	/* Make sure we have a zero-sized array. */
	111	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	112	return;
	113
	114	}
195a95c4 TB	115	}
	116	else
	117	{
	118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	119	runtime_error ("rank of return array incorrect in"
	120	" IALL intrinsic: is %ld, should be %ld",
	121	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	122	(long int) rank);
	123
	124	if (unlikely (compile_options.bounds_check))
	125	bounds_ifunction_return ((array_t *) retarray, extent,
	126	"return value", "IALL");
	127	}
	128
	129	for (n = 0; n < rank; n++)
	130	{
	131	count[n] = 0;
	132	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	133	if (extent[n] <= 0)
3d2244b9	134	return;
195a95c4 TB	135	}
195a95c4 TB	136
21d1335b TB	137	base = array->base_addr;
21d1335b TB	138	dest = retarray->base_addr;
195a95c4 TB	139
	140	continue_loop = 1;
	141	while (continue_loop)
	142	{
	143	const GFC_INTEGER_1 * restrict src;
	144	GFC_INTEGER_1 result;
	145	src = base;
	146	{
	147
	148	result = (GFC_INTEGER_1) -1;
	149	if (len <= 0)
	150	*dest = 0;
	151	else
	152	{
b573f931	153	#if ! defined HAVE_BACK_ARG
195a95c4 TB	154	for (n = 0; n < len; n++, src += delta)
195a95c4 TB	155	{
b573f931	156	#endif
195a95c4 TB	157
	158	result &= *src;
	159	}
	160
	161	*dest = result;
	162	}
	163	}
	164	/* Advance to the next element. */
	165	count[0]++;
	166	base += sstride[0];
	167	dest += dstride[0];
	168	n = 0;
	169	while (count[n] == extent[n])
	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	dest -= dstride[n] * extent[n];
	178	n++;
80dd631f	179	if (n >= rank)
195a95c4	180	{
80dd631f	181	/* Break out of the loop. */
195a95c4 TB	182	continue_loop = 0;
	183	break;
	184	}
	185	else
	186	{
	187	count[n]++;
	188	base += sstride[n];
	189	dest += dstride[n];
	190	}
	191	}
	192	}
	193	}
	194
	195
	196	extern void miall_i1 (gfc_array_i1 * const restrict,
	197	gfc_array_i1 * const restrict, const index_type * const restrict,
	198	gfc_array_l1 * const restrict);
	199	export_proto(miall_i1);
	200
	201	void
	202	miall_i1 (gfc_array_i1 * const restrict retarray,
	203	gfc_array_i1 * const restrict array,
	204	const index_type * const restrict pdim,
	205	gfc_array_l1 * const restrict mask)
	206	{
	207	index_type count[GFC_MAX_DIMENSIONS];
	208	index_type extent[GFC_MAX_DIMENSIONS];
	209	index_type sstride[GFC_MAX_DIMENSIONS];
	210	index_type dstride[GFC_MAX_DIMENSIONS];
	211	index_type mstride[GFC_MAX_DIMENSIONS];
	212	GFC_INTEGER_1 * restrict dest;
	213	const GFC_INTEGER_1 * restrict base;
	214	const GFC_LOGICAL_1 * restrict mbase;
cfdf6ff6 TK	215	index_type rank;
cfdf6ff6 TK	216	index_type dim;
195a95c4 TB	217	index_type n;
	218	index_type len;
	219	index_type delta;
	220	index_type mdelta;
	221	int mask_kind;
	222
2ea47ee9 TK	223	if (mask == NULL)
	224	{
	225	#ifdef HAVE_BACK_ARG
	226	iall_i1 (retarray, array, pdim, back);
	227	#else
	228	iall_i1 (retarray, array, pdim);
	229	#endif
	230	return;
	231	}
	232
195a95c4 TB	233	dim = (*pdim) - 1;
	234	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	235
cfdf6ff6 TK	236
	237	if (unlikely (dim < 0 \|\| dim > rank))
	238	{
	239	runtime_error ("Dim argument incorrect in IALL intrinsic: "
	240	"is %ld, should be between 1 and %ld",
	241	(long int) dim + 1, (long int) rank + 1);
	242	}
	243
195a95c4 TB	244	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	245	if (len <= 0)
	246	return;
	247
21d1335b	248	mbase = mask->base_addr;
195a95c4 TB	249
	250	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	251
	252	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	253	#ifdef HAVE_GFC_LOGICAL_16
	254	\|\| mask_kind == 16
	255	#endif
	256	)
	257	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	258	else
	259	runtime_error ("Funny sized logical array");
	260
	261	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	262	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	263
	264	for (n = 0; n < dim; n++)
	265	{
	266	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	267	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	268	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	269
	270	if (extent[n] < 0)
	271	extent[n] = 0;
	272
	273	}
	274	for (n = dim; n < rank; n++)
	275	{
	276	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	277	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	278	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	279
	280	if (extent[n] < 0)
	281	extent[n] = 0;
	282	}
	283
21d1335b	284	if (retarray->base_addr == NULL)
195a95c4 TB	285	{
	286	size_t alloc_size, str;
	287
	288	for (n = 0; n < rank; n++)
	289	{
	290	if (n == 0)
	291	str = 1;
	292	else
	293	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	294
	295	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	296
	297	}
	298
92e6f3a4	299	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
195a95c4 TB	300
195a95c4 TB	301	retarray->offset = 0;
ca708a2b	302	retarray->dtype.rank = rank;
195a95c4 TB	303
	304	if (alloc_size == 0)
	305	{
	306	/* Make sure we have a zero-sized array. */
	307	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	308	return;
	309	}
	310	else
92e6f3a4	311	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
195a95c4 TB	312
	313	}
	314	else
	315	{
	316	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	317	runtime_error ("rank of return array incorrect in IALL intrinsic");
	318
	319	if (unlikely (compile_options.bounds_check))
	320	{
	321	bounds_ifunction_return ((array_t *) retarray, extent,
	322	"return value", "IALL");
	323	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	324	"MASK argument", "IALL");
	325	}
	326	}
	327
	328	for (n = 0; n < rank; n++)
	329	{
	330	count[n] = 0;
	331	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	332	if (extent[n] <= 0)
	333	return;
	334	}
	335
21d1335b TB	336	dest = retarray->base_addr;
21d1335b TB	337	base = array->base_addr;
195a95c4 TB	338
	339	while (base)
	340	{
	341	const GFC_INTEGER_1 * restrict src;
	342	const GFC_LOGICAL_1 * restrict msrc;
	343	GFC_INTEGER_1 result;
	344	src = base;
	345	msrc = mbase;
	346	{
	347
	348	result = 0;
036e1775	349	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
195a95c4	350	{
195a95c4 TB	351
	352	if (*msrc)
	353	result &= *src;
195a95c4	354	}
036e1775	355	*dest = result;
195a95c4 TB	356	}
	357	/* Advance to the next element. */
	358	count[0]++;
	359	base += sstride[0];
	360	mbase += mstride[0];
	361	dest += dstride[0];
	362	n = 0;
	363	while (count[n] == extent[n])
	364	{
	365	/* When we get to the end of a dimension, reset it and increment
	366	the next dimension. */
	367	count[n] = 0;
	368	/* We could precalculate these products, but this is a less
	369	frequently used path so probably not worth it. */
	370	base -= sstride[n] * extent[n];
	371	mbase -= mstride[n] * extent[n];
	372	dest -= dstride[n] * extent[n];
	373	n++;
80dd631f	374	if (n >= rank)
195a95c4	375	{
80dd631f	376	/* Break out of the loop. */
195a95c4 TB	377	base = NULL;
	378	break;
	379	}
	380	else
	381	{
	382	count[n]++;
	383	base += sstride[n];
	384	mbase += mstride[n];
	385	dest += dstride[n];
	386	}
	387	}
	388	}
	389	}
	390
	391
	392	extern void siall_i1 (gfc_array_i1 * const restrict,
	393	gfc_array_i1 * const restrict, const index_type * const restrict,
	394	GFC_LOGICAL_4 *);
	395	export_proto(siall_i1);
	396
	397	void
	398	siall_i1 (gfc_array_i1 * const restrict retarray,
	399	gfc_array_i1 * const restrict array,
	400	const index_type * const restrict pdim,
	401	GFC_LOGICAL_4 * mask)
	402	{
	403	index_type count[GFC_MAX_DIMENSIONS];
	404	index_type extent[GFC_MAX_DIMENSIONS];
	405	index_type dstride[GFC_MAX_DIMENSIONS];
	406	GFC_INTEGER_1 * restrict dest;
	407	index_type rank;
	408	index_type n;
	409	index_type dim;
	410
	411
2ea47ee9	412	if (mask == NULL \|\| *mask)
195a95c4	413	{
64b1806b TK	414	#ifdef HAVE_BACK_ARG
	415	iall_i1 (retarray, array, pdim, back);
	416	#else
195a95c4	417	iall_i1 (retarray, array, pdim);
64b1806b	418	#endif
195a95c4 TB	419	return;
	420	}
	421	/* Make dim zero based to avoid confusion. */
	422	dim = (*pdim) - 1;
	423	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	424
cfdf6ff6 TK	425	if (unlikely (dim < 0 \|\| dim > rank))
	426	{
	427	runtime_error ("Dim argument incorrect in IALL intrinsic: "
	428	"is %ld, should be between 1 and %ld",
	429	(long int) dim + 1, (long int) rank + 1);
	430	}
	431
195a95c4 TB	432	for (n = 0; n < dim; n++)
	433	{
	434	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	435
	436	if (extent[n] <= 0)
	437	extent[n] = 0;
	438	}
	439
	440	for (n = dim; n < rank; n++)
	441	{
	442	extent[n] =
	443	GFC_DESCRIPTOR_EXTENT(array,n + 1);
	444
	445	if (extent[n] <= 0)
	446	extent[n] = 0;
	447	}
	448
21d1335b	449	if (retarray->base_addr == NULL)
195a95c4 TB	450	{
	451	size_t alloc_size, str;
	452
	453	for (n = 0; n < rank; n++)
	454	{
	455	if (n == 0)
	456	str = 1;
	457	else
	458	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	459
	460	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	461
	462	}
	463
	464	retarray->offset = 0;
ca708a2b	465	retarray->dtype.rank = rank;
195a95c4	466
92e6f3a4	467	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
195a95c4 TB	468
	469	if (alloc_size == 0)
	470	{
	471	/* Make sure we have a zero-sized array. */
	472	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	473	return;
	474	}
	475	else
92e6f3a4	476	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
195a95c4 TB	477	}
	478	else
	479	{
	480	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	481	runtime_error ("rank of return array incorrect in"
	482	" IALL intrinsic: is %ld, should be %ld",
	483	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	484	(long int) rank);
	485
	486	if (unlikely (compile_options.bounds_check))
	487	{
	488	for (n=0; n < rank; n++)
	489	{
	490	index_type ret_extent;
	491
	492	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	493	if (extent[n] != ret_extent)
	494	runtime_error ("Incorrect extent in return value of"
	495	" IALL intrinsic in dimension %ld:"
	496	" is %ld, should be %ld", (long int) n + 1,
	497	(long int) ret_extent, (long int) extent[n]);
	498	}
	499	}
	500	}
	501
	502	for (n = 0; n < rank; n++)
	503	{
	504	count[n] = 0;
	505	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	506	}
	507
21d1335b	508	dest = retarray->base_addr;
195a95c4 TB	509
	510	while(1)
	511	{
	512	*dest = 0;
	513	count[0]++;
	514	dest += dstride[0];
	515	n = 0;
	516	while (count[n] == extent[n])
	517	{
	518	/* When we get to the end of a dimension, reset it and increment
	519	the next dimension. */
	520	count[n] = 0;
	521	/* We could precalculate these products, but this is a less
	522	frequently used path so probably not worth it. */
	523	dest -= dstride[n] * extent[n];
	524	n++;
80dd631f	525	if (n >= rank)
195a95c4 TB	526	return;
	527	else
	528	{
	529	count[n]++;
	530	dest += dstride[n];
	531	}
	532	}
	533	}
	534	}
	535
	536	#endif