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

/* Implementation of the PRODUCT intrinsic
   Copyright (C) 2002-2024 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.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in PRODUCT 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_8));
      if (alloc_size == 0)
	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
	  {
#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 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;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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

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


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in PRODUCT 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;

  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;

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
      if (alloc_size == 0)
	return;
    }
  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 loop.  */
	      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 == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      product_i8 (retarray, array, pdim, back);
#else
      product_i8 (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 PRODUCT 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];

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