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

/* Implementation of the PRODUCT intrinsic
   Copyright (C) 2002-2017 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"


#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)


extern void product_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict);
export_proto(product_i8);

void
product_i8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i8 * 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_8 * restrict base;
  GFC_INTEGER_8 * 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_8));
      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_8 * restrict src;
      GFC_INTEGER_8 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_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mproduct_i8);

void
mproduct_i8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i8 * 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_8 * restrict dest;
  const GFC_INTEGER_8 * 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_8));

    }
  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_8 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 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_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sproduct_i8);

void
sproduct_i8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i8 * 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_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      product_i8 (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_8));
    }
  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
6de9cd9a	1	/* Implementation of the PRODUCT intrinsic
cbe34bb5	2	Copyright (C) 2002-2017 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	4
0cd0559e	5	This file is part of the GNU Fortran runtime library (libgfortran).
6de9cd9a DN	6
6de9cd9a DN	7	Libgfortran is free software; you can redistribute it and/or
57dea9f6	8	modify it under the terms of the GNU General Public
6de9cd9a	9	License as published by the Free Software Foundation; either
748086b7	10	version 3 of the License, or (at your option) any later version.
6de9cd9a DN	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
57dea9f6	15	GNU General Public License for more details.
6de9cd9a	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/>. */
6de9cd9a	25
36ae8a61	26	#include "libgfortran.h"
6de9cd9a	27
7d7b8bfe	28
644cb69f FXC	29	#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)
	30
	31
64acfd99 JB	32	extern void product_i8 (gfc_array_i8 * const restrict,
64acfd99 JB	33	gfc_array_i8 * const restrict, const index_type * const restrict);
7f68c75f	34	export_proto(product_i8);
7d7b8bfe	35
6de9cd9a	36	void
64acfd99 JB	37	product_i8 (gfc_array_i8 * const restrict retarray,
	38	gfc_array_i8 * const restrict array,
	39	const index_type * const restrict pdim)
6de9cd9a	40	{
e33e218b TK	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];
64acfd99 JB	45	const GFC_INTEGER_8 * restrict base;
64acfd99 JB	46	GFC_INTEGER_8 * restrict dest;
6de9cd9a DN	47	index_type rank;
	48	index_type n;
	49	index_type len;
	50	index_type delta;
	51	index_type dim;
da96f5ab	52	int continue_loop;
6de9cd9a DN	53
	54	/* Make dim zero based to avoid confusion. */
	55	dim = (*pdim) - 1;
	56	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b	57
dfb55fdc	58	len = GFC_DESCRIPTOR_EXTENT(array,dim);
da96f5ab TK	59	if (len < 0)
da96f5ab TK	60	len = 0;
dfb55fdc	61	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
6de9cd9a DN	62
	63	for (n = 0; n < dim; n++)
	64	{
dfb55fdc TK	65	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	66	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	67
	68	if (extent[n] < 0)
	69	extent[n] = 0;
6de9cd9a DN	70	}
	71	for (n = dim; n < rank; n++)
	72	{
dfb55fdc TK	73	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
dfb55fdc TK	74	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	75
	76	if (extent[n] < 0)
	77	extent[n] = 0;
6de9cd9a DN	78	}
6de9cd9a DN	79
21d1335b	80	if (retarray->base_addr == NULL)
6c167c45	81	{
dfb55fdc	82	size_t alloc_size, str;
80ee04b9	83
6c167c45	84	for (n = 0; n < rank; n++)
80927a56 JJ	85	{
80927a56 JJ	86	if (n == 0)
dfb55fdc	87	str = 1;
80927a56 JJ	88	else
80927a56 JJ	89	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	90
	91	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	92
80927a56	93	}
6c167c45	94
efd4dc1a	95	retarray->offset = 0;
50dd63a9	96	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9	97
92e6f3a4	98	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	99
92e6f3a4	100	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
80ee04b9 TK	101	if (alloc_size == 0)
	102	{
	103	/* Make sure we have a zero-sized array. */
dfb55fdc	104	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	105	return;
dfb55fdc	106
80ee04b9	107	}
6c167c45	108	}
50dd63a9 TK	109	else
50dd63a9 TK	110	{
50dd63a9	111	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	112	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	113	" PRODUCT intrinsic: is %ld, should be %ld",
	114	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	115	(long int) rank);
fd6590f8	116
9731c4a3	117	if (unlikely (compile_options.bounds_check))
16bff921 TK	118	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	119	"return value", "PRODUCT");
50dd63a9 TK	120	}
50dd63a9 TK	121
6de9cd9a DN	122	for (n = 0; n < rank; n++)
	123	{
	124	count[n] = 0;
dfb55fdc	125	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
6de9cd9a	126	if (extent[n] <= 0)
facc1285	127	return;
6de9cd9a DN	128	}
6de9cd9a DN	129
21d1335b TB	130	base = array->base_addr;
21d1335b TB	131	dest = retarray->base_addr;
6de9cd9a	132
da96f5ab TK	133	continue_loop = 1;
da96f5ab TK	134	while (continue_loop)
6de9cd9a	135	{
64acfd99	136	const GFC_INTEGER_8 * restrict src;
6de9cd9a DN	137	GFC_INTEGER_8 result;
	138	src = base;
	139	{
	140
	141	result = 1;
80927a56	142	if (len <= 0)
6de9cd9a DN	143	*dest = 1;
	144	else
	145	{
	146	for (n = 0; n < len; n++, src += delta)
	147	{
	148
	149	result = src;
80927a56	150	}
0cd0559e	151
6de9cd9a DN	152	*dest = result;
	153	}
	154	}
	155	/* Advance to the next element. */
	156	count[0]++;
	157	base += sstride[0];
	158	dest += dstride[0];
	159	n = 0;
	160	while (count[n] == extent[n])
80927a56 JJ	161	{
	162	/* When we get to the end of a dimension, reset it and increment
	163	the next dimension. */
	164	count[n] = 0;
	165	/* We could precalculate these products, but this is a less
	166	frequently used path so probably not worth it. */
	167	base -= sstride[n] * extent[n];
	168	dest -= dstride[n] * extent[n];
	169	n++;
	170	if (n == rank)
	171	{
	172	/* Break out of the look. */
da96f5ab TK	173	continue_loop = 0;
da96f5ab TK	174	break;
80927a56 JJ	175	}
	176	else
	177	{
	178	count[n]++;
	179	base += sstride[n];
	180	dest += dstride[n];
	181	}
	182	}
6de9cd9a DN	183	}
	184	}
	185
7d7b8bfe	186
64acfd99 JB	187	extern void mproduct_i8 (gfc_array_i8 * const restrict,
64acfd99 JB	188	gfc_array_i8 * const restrict, const index_type * const restrict,
28dc6b33	189	gfc_array_l1 * const restrict);
7f68c75f	190	export_proto(mproduct_i8);
7d7b8bfe	191
6de9cd9a	192	void
64acfd99 JB	193	mproduct_i8 (gfc_array_i8 * const restrict retarray,
	194	gfc_array_i8 * const restrict array,
	195	const index_type * const restrict pdim,
28dc6b33	196	gfc_array_l1 * const restrict mask)
6de9cd9a	197	{
e33e218b TK	198	index_type count[GFC_MAX_DIMENSIONS];
	199	index_type extent[GFC_MAX_DIMENSIONS];
	200	index_type sstride[GFC_MAX_DIMENSIONS];
	201	index_type dstride[GFC_MAX_DIMENSIONS];
	202	index_type mstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	203	GFC_INTEGER_8 * restrict dest;
64acfd99 JB	204	const GFC_INTEGER_8 * restrict base;
28dc6b33	205	const GFC_LOGICAL_1 * restrict mbase;
6de9cd9a DN	206	int rank;
	207	int dim;
	208	index_type n;
	209	index_type len;
	210	index_type delta;
	211	index_type mdelta;
28dc6b33	212	int mask_kind;
6de9cd9a DN	213
	214	dim = (*pdim) - 1;
	215	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b	216
dfb55fdc	217	len = GFC_DESCRIPTOR_EXTENT(array,dim);
6de9cd9a DN	218	if (len <= 0)
6de9cd9a DN	219	return;
28dc6b33	220
21d1335b	221	mbase = mask->base_addr;
28dc6b33 TK	222
	223	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	224
	225	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	226	#ifdef HAVE_GFC_LOGICAL_16
	227	\|\| mask_kind == 16
	228	#endif
	229	)
	230	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	231	else
	232	runtime_error ("Funny sized logical array");
	233
dfb55fdc TK	234	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	235	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
6de9cd9a DN	236
	237	for (n = 0; n < dim; n++)
	238	{
dfb55fdc TK	239	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	240	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	241	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	242
	243	if (extent[n] < 0)
	244	extent[n] = 0;
	245
6de9cd9a DN	246	}
	247	for (n = dim; n < rank; n++)
	248	{
dfb55fdc TK	249	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	250	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	251	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	252
	253	if (extent[n] < 0)
	254	extent[n] = 0;
6de9cd9a DN	255	}
6de9cd9a DN	256
21d1335b	257	if (retarray->base_addr == NULL)
50dd63a9	258	{
dfb55fdc	259	size_t alloc_size, str;
80ee04b9	260
50dd63a9	261	for (n = 0; n < rank; n++)
80927a56 JJ	262	{
	263	if (n == 0)
	264	str = 1;
	265	else
	266	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	267
	268	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	269
80927a56	270	}
50dd63a9	271
92e6f3a4	272	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	273
efd4dc1a	274	retarray->offset = 0;
50dd63a9	275	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	276
	277	if (alloc_size == 0)
	278	{
	279	/* Make sure we have a zero-sized array. */
dfb55fdc	280	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	281	return;
	282	}
	283	else
92e6f3a4	284	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
80ee04b9	285
50dd63a9 TK	286	}
	287	else
	288	{
50dd63a9	289	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	290	runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
fd6590f8 TK	291
9731c4a3	292	if (unlikely (compile_options.bounds_check))
fd6590f8	293	{
16bff921 TK	294	bounds_ifunction_return ((array_t *) retarray, extent,
	295	"return value", "PRODUCT");
	296	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	297	"MASK argument", "PRODUCT");
fd6590f8	298	}
50dd63a9 TK	299	}
50dd63a9 TK	300
6de9cd9a DN	301	for (n = 0; n < rank; n++)
	302	{
	303	count[n] = 0;
dfb55fdc	304	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
6de9cd9a	305	if (extent[n] <= 0)
80927a56	306	return;
6de9cd9a DN	307	}
6de9cd9a DN	308
21d1335b TB	309	dest = retarray->base_addr;
21d1335b TB	310	base = array->base_addr;
6de9cd9a DN	311
	312	while (base)
	313	{
64acfd99	314	const GFC_INTEGER_8 * restrict src;
28dc6b33	315	const GFC_LOGICAL_1 * restrict msrc;
6de9cd9a DN	316	GFC_INTEGER_8 result;
	317	src = base;
	318	msrc = mbase;
	319	{
	320
	321	result = 1;
036e1775	322	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
6de9cd9a	323	{
6de9cd9a DN	324
	325	if (*msrc)
	326	result = src;
6de9cd9a	327	}
036e1775	328	*dest = result;
6de9cd9a DN	329	}
	330	/* Advance to the next element. */
	331	count[0]++;
	332	base += sstride[0];
	333	mbase += mstride[0];
	334	dest += dstride[0];
	335	n = 0;
	336	while (count[n] == extent[n])
80927a56 JJ	337	{
	338	/* When we get to the end of a dimension, reset it and increment
	339	the next dimension. */
	340	count[n] = 0;
	341	/* We could precalculate these products, but this is a less
	342	frequently used path so probably not worth it. */
	343	base -= sstride[n] * extent[n];
	344	mbase -= mstride[n] * extent[n];
	345	dest -= dstride[n] * extent[n];
	346	n++;
	347	if (n == rank)
	348	{
	349	/* Break out of the look. */
	350	base = NULL;
	351	break;
	352	}
	353	else
	354	{
	355	count[n]++;
	356	base += sstride[n];
	357	mbase += mstride[n];
	358	dest += dstride[n];
	359	}
	360	}
6de9cd9a DN	361	}
	362	}
	363
97a62038 TK	364
	365	extern void sproduct_i8 (gfc_array_i8 * const restrict,
	366	gfc_array_i8 * const restrict, const index_type * const restrict,
	367	GFC_LOGICAL_4 *);
	368	export_proto(sproduct_i8);
	369
	370	void
	371	sproduct_i8 (gfc_array_i8 * const restrict retarray,
	372	gfc_array_i8 * const restrict array,
	373	const index_type * const restrict pdim,
	374	GFC_LOGICAL_4 * mask)
	375	{
802367d7 TK	376	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	377	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	378	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	379	GFC_INTEGER_8 * restrict dest;
97a62038 TK	380	index_type rank;
97a62038 TK	381	index_type n;
802367d7 TK	382	index_type dim;
802367d7 TK	383
97a62038 TK	384
	385	if (*mask)
	386	{
	387	product_i8 (retarray, array, pdim);
	388	return;
	389	}
802367d7 TK	390	/* Make dim zero based to avoid confusion. */
	391	dim = (*pdim) - 1;
	392	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	393
	394	for (n = 0; n < dim; n++)
	395	{
dfb55fdc	396	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	397
	398	if (extent[n] <= 0)
	399	extent[n] = 0;
	400	}
	401
	402	for (n = dim; n < rank; n++)
	403	{
802367d7	404	extent[n] =
80927a56	405	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	406
802367d7 TK	407	if (extent[n] <= 0)
80927a56	408	extent[n] = 0;
802367d7	409	}
97a62038	410
21d1335b	411	if (retarray->base_addr == NULL)
97a62038	412	{
dfb55fdc	413	size_t alloc_size, str;
802367d7 TK	414
802367d7 TK	415	for (n = 0; n < rank; n++)
80927a56 JJ	416	{
	417	if (n == 0)
	418	str = 1;
	419	else
	420	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	421
	422	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	423
80927a56	424	}
802367d7	425
97a62038	426	retarray->offset = 0;
802367d7 TK	427	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	428
92e6f3a4	429	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	430
	431	if (alloc_size == 0)
	432	{
	433	/* Make sure we have a zero-sized array. */
dfb55fdc	434	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	435	return;
	436	}
	437	else
92e6f3a4	438	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
97a62038 TK	439	}
	440	else
	441	{
802367d7 TK	442	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	443	runtime_error ("rank of return array incorrect in"
	444	" PRODUCT intrinsic: is %ld, should be %ld",
	445	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	446	(long int) rank);
	447
9731c4a3	448	if (unlikely (compile_options.bounds_check))
fd6590f8	449	{
802367d7 TK	450	for (n=0; n < rank; n++)
	451	{
	452	index_type ret_extent;
97a62038	453
dfb55fdc	454	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	455	if (extent[n] != ret_extent)
	456	runtime_error ("Incorrect extent in return value of"
	457	" PRODUCT intrinsic in dimension %ld:"
	458	" is %ld, should be %ld", (long int) n + 1,
	459	(long int) ret_extent, (long int) extent[n]);
	460	}
fd6590f8 TK	461	}
fd6590f8 TK	462	}
97a62038	463
802367d7 TK	464	for (n = 0; n < rank; n++)
	465	{
	466	count[n] = 0;
dfb55fdc	467	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	468	}
802367d7 TK	469
21d1335b	470	dest = retarray->base_addr;
802367d7 TK	471
	472	while(1)
	473	{
	474	*dest = 1;
	475	count[0]++;
	476	dest += dstride[0];
	477	n = 0;
	478	while (count[n] == extent[n])
80927a56	479	{
802367d7	480	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	481	the next dimension. */
	482	count[n] = 0;
	483	/* We could precalculate these products, but this is a less
	484	frequently used path so probably not worth it. */
	485	dest -= dstride[n] * extent[n];
	486	n++;
	487	if (n == rank)
802367d7	488	return;
80927a56 JJ	489	else
	490	{
	491	count[n]++;
	492	dest += dstride[n];
	493	}
802367d7 TK	494	}
802367d7 TK	495	}
97a62038 TK	496	}
97a62038 TK	497
644cb69f	498	#endif