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

/* Implementation of the PRODUCT intrinsic
   Copyright (C) 2002-2016 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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_1) && defined (HAVE_GFC_INTEGER_1)


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

void
product_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.  */
  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_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"
		       " PRODUCT 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", "PRODUCT");
    }

  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 = 1;
	if (len <= 0)
	  *dest = 1;
	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 mproduct_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mproduct_i1);

void
mproduct_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;
  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_1));

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

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

  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 = 1;
	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 sproduct_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sproduct_i1);

void
sproduct_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)
    {
      product_i1 (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_1));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " PRODUCT 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"
			       " PRODUCT 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 = 1;
      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
dd765455	1	/* Implementation of the PRODUCT intrinsic
f1717362	2	Copyright (C) 2002-2016 Free Software Foundation, Inc.
dd765455	3	Contributed by Paul Brook <paul@nowt.org>
dd765455	4
b4ba8232	5	This file is part of the GNU Fortran runtime library (libgfortran).
dd765455	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
6bc9506f	10	version 3 of the License, or (at your option) any later version.
dd765455	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
6bc9506f	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/>. */
dd765455	25
41f2d5e8	26	#include "libgfortran.h"
dd765455	27	#include <stdlib.h>
dd765455	28	#include <assert.h>
dd765455	29
	30
	31	#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
	32
	33
	34	extern void product_i1 (gfc_array_i1 * const restrict,
	35	gfc_array_i1 * const restrict, const index_type * const restrict);
	36	export_proto(product_i1);
	37
	38	void
	39	product_i1 (gfc_array_i1 * const restrict retarray,
	40	gfc_array_i1 * 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_1 * restrict base;
	48	GFC_INTEGER_1 * restrict dest;
	49	index_type rank;
	50	index_type n;
	51	index_type len;
	52	index_type delta;
	53	index_type dim;
393a1b6c	54	int continue_loop;
dd765455	55
	56	/* Make dim zero based to avoid confusion. */
	57	dim = (*pdim) - 1;
	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	59
827aef63	60	len = GFC_DESCRIPTOR_EXTENT(array,dim);
393a1b6c	61	if (len < 0)
393a1b6c	62	len = 0;
827aef63	63	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dd765455	64
	65	for (n = 0; n < dim; n++)
	66	{
827aef63	67	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
827aef63	68	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
dd765455	69
	70	if (extent[n] < 0)
	71	extent[n] = 0;
	72	}
	73	for (n = dim; n < rank; n++)
	74	{
827aef63	75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
827aef63	76	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
dd765455	77
	78	if (extent[n] < 0)
	79	extent[n] = 0;
	80	}
	81
553877d9	82	if (retarray->base_addr == NULL)
dd765455	83	{
827aef63	84	size_t alloc_size, str;
dd765455	85
dd765455	86	for (n = 0; n < rank; n++)
7ebee933	87	{
7ebee933	88	if (n == 0)
827aef63	89	str = 1;
7ebee933	90	else
7ebee933	91	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	92
	93	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	94
7ebee933	95	}
dd765455	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];
dd765455	101
af1e9051	102	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
dd765455	103	if (alloc_size == 0)
	104	{
	105	/* Make sure we have a zero-sized array. */
827aef63	106	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
dd765455	107	return;
827aef63	108
dd765455	109	}
dd765455	110	}
	111	else
	112	{
	113	if (rank != GFC_DESCRIPTOR_RANK (retarray))
8dec97a0	114	runtime_error ("rank of return array incorrect in"
ae66f8f3	115	" PRODUCT intrinsic: is %ld, should be %ld",
	116	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	117	(long int) rank);
8dec97a0	118
c7fb575f	119	if (unlikely (compile_options.bounds_check))
5d04d450	120	bounds_ifunction_return ((array_t *) retarray, extent,
5d04d450	121	"return value", "PRODUCT");
dd765455	122	}
	123
	124	for (n = 0; n < rank; n++)
	125	{
	126	count[n] = 0;
827aef63	127	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
dd765455	128	if (extent[n] <= 0)
7cbf86e5	129	return;
dd765455	130	}
dd765455	131
553877d9	132	base = array->base_addr;
553877d9	133	dest = retarray->base_addr;
dd765455	134
393a1b6c	135	continue_loop = 1;
393a1b6c	136	while (continue_loop)
dd765455	137	{
	138	const GFC_INTEGER_1 * restrict src;
	139	GFC_INTEGER_1 result;
	140	src = base;
	141	{
	142
	143	result = 1;
7ebee933	144	if (len <= 0)
dd765455	145	*dest = 1;
	146	else
	147	{
	148	for (n = 0; n < len; n++, src += delta)
	149	{
	150
	151	result = src;
7ebee933	152	}
b4ba8232	153
dd765455	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])
7ebee933	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. */
393a1b6c	175	continue_loop = 0;
393a1b6c	176	break;
7ebee933	177	}
	178	else
	179	{
	180	count[n]++;
	181	base += sstride[n];
	182	dest += dstride[n];
	183	}
	184	}
dd765455	185	}
	186	}
	187
	188
	189	extern void mproduct_i1 (gfc_array_i1 * const restrict,
	190	gfc_array_i1 * const restrict, const index_type * const restrict,
7ed8f627	191	gfc_array_l1 * const restrict);
dd765455	192	export_proto(mproduct_i1);
	193
	194	void
	195	mproduct_i1 (gfc_array_i1 * const restrict retarray,
	196	gfc_array_i1 * const restrict array,
	197	const index_type * const restrict pdim,
7ed8f627	198	gfc_array_l1 * const restrict mask)
dd765455	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_1 * restrict dest;
	206	const GFC_INTEGER_1 * restrict base;
7ed8f627	207	const GFC_LOGICAL_1 * restrict mbase;
dd765455	208	int rank;
	209	int dim;
	210	index_type n;
	211	index_type len;
	212	index_type delta;
	213	index_type mdelta;
7ed8f627	214	int mask_kind;
dd765455	215
	216	dim = (*pdim) - 1;
	217	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	218
827aef63	219	len = GFC_DESCRIPTOR_EXTENT(array,dim);
dd765455	220	if (len <= 0)
dd765455	221	return;
7ed8f627	222
553877d9	223	mbase = mask->base_addr;
7ed8f627	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
827aef63	236	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
827aef63	237	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
dd765455	238
	239	for (n = 0; n < dim; n++)
	240	{
827aef63	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);
dd765455	244
	245	if (extent[n] < 0)
	246	extent[n] = 0;
	247
	248	}
	249	for (n = dim; n < rank; n++)
	250	{
827aef63	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);
dd765455	254
	255	if (extent[n] < 0)
	256	extent[n] = 0;
	257	}
	258
553877d9	259	if (retarray->base_addr == NULL)
dd765455	260	{
827aef63	261	size_t alloc_size, str;
dd765455	262
dd765455	263	for (n = 0; n < rank; n++)
7ebee933	264	{
	265	if (n == 0)
	266	str = 1;
	267	else
	268	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	269
	270	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	271
7ebee933	272	}
dd765455	273
af1e9051	274	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
dd765455	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. */
827aef63	282	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
dd765455	283	return;
	284	}
	285	else
af1e9051	286	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
dd765455	287
	288	}
	289	else
	290	{
	291	if (rank != GFC_DESCRIPTOR_RANK (retarray))
8dec97a0	292	runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
8dec97a0	293
c7fb575f	294	if (unlikely (compile_options.bounds_check))
8dec97a0	295	{
5d04d450	296	bounds_ifunction_return ((array_t *) retarray, extent,
	297	"return value", "PRODUCT");
	298	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	299	"MASK argument", "PRODUCT");
8dec97a0	300	}
dd765455	301	}
	302
	303	for (n = 0; n < rank; n++)
	304	{
	305	count[n] = 0;
827aef63	306	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
dd765455	307	if (extent[n] <= 0)
7ebee933	308	return;
dd765455	309	}
dd765455	310
553877d9	311	dest = retarray->base_addr;
553877d9	312	base = array->base_addr;
dd765455	313
	314	while (base)
	315	{
	316	const GFC_INTEGER_1 * restrict src;
7ed8f627	317	const GFC_LOGICAL_1 * restrict msrc;
dd765455	318	GFC_INTEGER_1 result;
	319	src = base;
	320	msrc = mbase;
	321	{
	322
	323	result = 1;
08e1eb56	324	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
dd765455	325	{
dd765455	326
	327	if (*msrc)
	328	result = src;
dd765455	329	}
08e1eb56	330	*dest = result;
dd765455	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])
7ebee933	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	}
dd765455	363	}
	364	}
	365
	366
	367	extern void sproduct_i1 (gfc_array_i1 * const restrict,
	368	gfc_array_i1 * const restrict, const index_type * const restrict,
	369	GFC_LOGICAL_4 *);
	370	export_proto(sproduct_i1);
	371
	372	void
	373	sproduct_i1 (gfc_array_i1 * const restrict retarray,
	374	gfc_array_i1 * const restrict array,
	375	const index_type * const restrict pdim,
	376	GFC_LOGICAL_4 * mask)
	377	{
f955bfc4	378	index_type count[GFC_MAX_DIMENSIONS];
f955bfc4	379	index_type extent[GFC_MAX_DIMENSIONS];
f955bfc4	380	index_type dstride[GFC_MAX_DIMENSIONS];
f955bfc4	381	GFC_INTEGER_1 * restrict dest;
dd765455	382	index_type rank;
dd765455	383	index_type n;
f955bfc4	384	index_type dim;
f955bfc4	385
dd765455	386
	387	if (*mask)
	388	{
	389	product_i1 (retarray, array, pdim);
	390	return;
	391	}
f955bfc4	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	{
827aef63	398	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
f955bfc4	399
	400	if (extent[n] <= 0)
	401	extent[n] = 0;
	402	}
	403
	404	for (n = dim; n < rank; n++)
	405	{
f955bfc4	406	extent[n] =
7ebee933	407	GFC_DESCRIPTOR_EXTENT(array,n + 1);
f955bfc4	408
f955bfc4	409	if (extent[n] <= 0)
7ebee933	410	extent[n] = 0;
f955bfc4	411	}
dd765455	412
553877d9	413	if (retarray->base_addr == NULL)
dd765455	414	{
827aef63	415	size_t alloc_size, str;
f955bfc4	416
f955bfc4	417	for (n = 0; n < rank; n++)
7ebee933	418	{
	419	if (n == 0)
	420	str = 1;
	421	else
	422	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	423
	424	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	425
7ebee933	426	}
f955bfc4	427
dd765455	428	retarray->offset = 0;
f955bfc4	429	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
f955bfc4	430
af1e9051	431	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
f955bfc4	432
	433	if (alloc_size == 0)
	434	{
	435	/* Make sure we have a zero-sized array. */
827aef63	436	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
f955bfc4	437	return;
	438	}
	439	else
af1e9051	440	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
dd765455	441	}
	442	else
	443	{
f955bfc4	444	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	445	runtime_error ("rank of return array incorrect in"
	446	" PRODUCT intrinsic: is %ld, should be %ld",
	447	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	448	(long int) rank);
	449
c7fb575f	450	if (unlikely (compile_options.bounds_check))
8dec97a0	451	{
f955bfc4	452	for (n=0; n < rank; n++)
	453	{
	454	index_type ret_extent;
dd765455	455
827aef63	456	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
f955bfc4	457	if (extent[n] != ret_extent)
	458	runtime_error ("Incorrect extent in return value of"
	459	" PRODUCT intrinsic in dimension %ld:"
	460	" is %ld, should be %ld", (long int) n + 1,
	461	(long int) ret_extent, (long int) extent[n]);
	462	}
8dec97a0	463	}
8dec97a0	464	}
dd765455	465
f955bfc4	466	for (n = 0; n < rank; n++)
	467	{
	468	count[n] = 0;
827aef63	469	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
f955bfc4	470	}
f955bfc4	471
553877d9	472	dest = retarray->base_addr;
f955bfc4	473
	474	while(1)
	475	{
	476	*dest = 1;
	477	count[0]++;
	478	dest += dstride[0];
	479	n = 0;
	480	while (count[n] == extent[n])
7ebee933	481	{
f955bfc4	482	/* When we get to the end of a dimension, reset it and increment
7ebee933	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)
f955bfc4	490	return;
7ebee933	491	else
	492	{
	493	count[n]++;
	494	dest += dstride[n];
	495	}
f955bfc4	496	}
f955bfc4	497	}
dd765455	498	}
	499
	500	#endif