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

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

  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)
    {
#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
85ec4feb	2	Copyright (C) 2010-2018 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
	223	dim = (*pdim) - 1;
	224	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	225
cfdf6ff6 TK	226
	227	if (unlikely (dim < 0 \|\| dim > rank))
	228	{
	229	runtime_error ("Dim argument incorrect in IALL intrinsic: "
	230	"is %ld, should be between 1 and %ld",
	231	(long int) dim + 1, (long int) rank + 1);
	232	}
	233
195a95c4 TB	234	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	235	if (len <= 0)
	236	return;
	237
21d1335b	238	mbase = mask->base_addr;
195a95c4 TB	239
	240	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	241
	242	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	243	#ifdef HAVE_GFC_LOGICAL_16
	244	\|\| mask_kind == 16
	245	#endif
	246	)
	247	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	248	else
	249	runtime_error ("Funny sized logical array");
	250
	251	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	252	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	253
	254	for (n = 0; n < dim; n++)
	255	{
	256	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	257	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	258	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	259
	260	if (extent[n] < 0)
	261	extent[n] = 0;
	262
	263	}
	264	for (n = dim; n < rank; n++)
	265	{
	266	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	267	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	268	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	269
	270	if (extent[n] < 0)
	271	extent[n] = 0;
	272	}
	273
21d1335b	274	if (retarray->base_addr == NULL)
195a95c4 TB	275	{
	276	size_t alloc_size, str;
	277
	278	for (n = 0; n < rank; n++)
	279	{
	280	if (n == 0)
	281	str = 1;
	282	else
	283	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	284
	285	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	286
	287	}
	288
92e6f3a4	289	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
195a95c4 TB	290
195a95c4 TB	291	retarray->offset = 0;
ca708a2b	292	retarray->dtype.rank = rank;
195a95c4 TB	293
	294	if (alloc_size == 0)
	295	{
	296	/* Make sure we have a zero-sized array. */
	297	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	298	return;
	299	}
	300	else
92e6f3a4	301	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
195a95c4 TB	302
	303	}
	304	else
	305	{
	306	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	307	runtime_error ("rank of return array incorrect in IALL intrinsic");
	308
	309	if (unlikely (compile_options.bounds_check))
	310	{
	311	bounds_ifunction_return ((array_t *) retarray, extent,
	312	"return value", "IALL");
	313	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	314	"MASK argument", "IALL");
	315	}
	316	}
	317
	318	for (n = 0; n < rank; n++)
	319	{
	320	count[n] = 0;
	321	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	322	if (extent[n] <= 0)
	323	return;
	324	}
	325
21d1335b TB	326	dest = retarray->base_addr;
21d1335b TB	327	base = array->base_addr;
195a95c4 TB	328
	329	while (base)
	330	{
	331	const GFC_INTEGER_1 * restrict src;
	332	const GFC_LOGICAL_1 * restrict msrc;
	333	GFC_INTEGER_1 result;
	334	src = base;
	335	msrc = mbase;
	336	{
	337
	338	result = 0;
036e1775	339	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
195a95c4	340	{
195a95c4 TB	341
	342	if (*msrc)
	343	result &= *src;
195a95c4	344	}
036e1775	345	*dest = result;
195a95c4 TB	346	}
	347	/* Advance to the next element. */
	348	count[0]++;
	349	base += sstride[0];
	350	mbase += mstride[0];
	351	dest += dstride[0];
	352	n = 0;
	353	while (count[n] == extent[n])
	354	{
	355	/* When we get to the end of a dimension, reset it and increment
	356	the next dimension. */
	357	count[n] = 0;
	358	/* We could precalculate these products, but this is a less
	359	frequently used path so probably not worth it. */
	360	base -= sstride[n] * extent[n];
	361	mbase -= mstride[n] * extent[n];
	362	dest -= dstride[n] * extent[n];
	363	n++;
80dd631f	364	if (n >= rank)
195a95c4	365	{
80dd631f	366	/* Break out of the loop. */
195a95c4 TB	367	base = NULL;
	368	break;
	369	}
	370	else
	371	{
	372	count[n]++;
	373	base += sstride[n];
	374	mbase += mstride[n];
	375	dest += dstride[n];
	376	}
	377	}
	378	}
	379	}
	380
	381
	382	extern void siall_i1 (gfc_array_i1 * const restrict,
	383	gfc_array_i1 * const restrict, const index_type * const restrict,
	384	GFC_LOGICAL_4 *);
	385	export_proto(siall_i1);
	386
	387	void
	388	siall_i1 (gfc_array_i1 * const restrict retarray,
	389	gfc_array_i1 * const restrict array,
	390	const index_type * const restrict pdim,
	391	GFC_LOGICAL_4 * mask)
	392	{
	393	index_type count[GFC_MAX_DIMENSIONS];
	394	index_type extent[GFC_MAX_DIMENSIONS];
	395	index_type dstride[GFC_MAX_DIMENSIONS];
	396	GFC_INTEGER_1 * restrict dest;
	397	index_type rank;
	398	index_type n;
	399	index_type dim;
	400
	401
	402	if (*mask)
	403	{
64b1806b TK	404	#ifdef HAVE_BACK_ARG
	405	iall_i1 (retarray, array, pdim, back);
	406	#else
195a95c4	407	iall_i1 (retarray, array, pdim);
64b1806b	408	#endif
195a95c4 TB	409	return;
	410	}
	411	/* Make dim zero based to avoid confusion. */
	412	dim = (*pdim) - 1;
	413	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	414
cfdf6ff6 TK	415	if (unlikely (dim < 0 \|\| dim > rank))
	416	{
	417	runtime_error ("Dim argument incorrect in IALL intrinsic: "
	418	"is %ld, should be between 1 and %ld",
	419	(long int) dim + 1, (long int) rank + 1);
	420	}
	421
195a95c4 TB	422	for (n = 0; n < dim; n++)
	423	{
	424	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	425
	426	if (extent[n] <= 0)
	427	extent[n] = 0;
	428	}
	429
	430	for (n = dim; n < rank; n++)
	431	{
	432	extent[n] =
	433	GFC_DESCRIPTOR_EXTENT(array,n + 1);
	434
	435	if (extent[n] <= 0)
	436	extent[n] = 0;
	437	}
	438
21d1335b	439	if (retarray->base_addr == NULL)
195a95c4 TB	440	{
	441	size_t alloc_size, str;
	442
	443	for (n = 0; n < rank; n++)
	444	{
	445	if (n == 0)
	446	str = 1;
	447	else
	448	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	449
	450	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	451
	452	}
	453
	454	retarray->offset = 0;
ca708a2b	455	retarray->dtype.rank = rank;
195a95c4	456
92e6f3a4	457	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
195a95c4 TB	458
	459	if (alloc_size == 0)
	460	{
	461	/* Make sure we have a zero-sized array. */
	462	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	463	return;
	464	}
	465	else
92e6f3a4	466	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
195a95c4 TB	467	}
	468	else
	469	{
	470	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	471	runtime_error ("rank of return array incorrect in"
	472	" IALL intrinsic: is %ld, should be %ld",
	473	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	474	(long int) rank);
	475
	476	if (unlikely (compile_options.bounds_check))
	477	{
	478	for (n=0; n < rank; n++)
	479	{
	480	index_type ret_extent;
	481
	482	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	483	if (extent[n] != ret_extent)
	484	runtime_error ("Incorrect extent in return value of"
	485	" IALL intrinsic in dimension %ld:"
	486	" is %ld, should be %ld", (long int) n + 1,
	487	(long int) ret_extent, (long int) extent[n]);
	488	}
	489	}
	490	}
	491
	492	for (n = 0; n < rank; n++)
	493	{
	494	count[n] = 0;
	495	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	496	}
	497
21d1335b	498	dest = retarray->base_addr;
195a95c4 TB	499
	500	while(1)
	501	{
	502	*dest = 0;
	503	count[0]++;
	504	dest += dstride[0];
	505	n = 0;
	506	while (count[n] == extent[n])
	507	{
	508	/* When we get to the end of a dimension, reset it and increment
	509	the next dimension. */
	510	count[n] = 0;
	511	/* We could precalculate these products, but this is a less
	512	frequently used path so probably not worth it. */
	513	dest -= dstride[n] * extent[n];
	514	n++;
80dd631f	515	if (n >= rank)
195a95c4 TB	516	return;
	517	else
	518	{
	519	count[n]++;
	520	dest += dstride[n];
	521	}
	522	}
	523	}
	524	}
	525
	526	#endif