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

/* Implementation of the PRODUCT intrinsic
   Copyright (C) 2002-2014 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_2) && defined (HAVE_GFC_INTEGER_2)


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

void
product_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_INTEGER_2 * restrict base;
  GFC_INTEGER_2 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      alloc_size = sizeof (GFC_INTEGER_2) * 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"
		       " 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_2 * restrict src;
      GFC_INTEGER_2 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_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mproduct_i2);

void
mproduct_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_2 * restrict dest;
  const GFC_INTEGER_2 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      alloc_size = sizeof (GFC_INTEGER_2) * 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 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_2 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_2 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_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sproduct_i2);

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


  if (*mask)
    {
      product_i2 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

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