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

/* Implementation of the PRODUCT intrinsic
   Copyright 2002, 2007, 2009, 2010 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_16) && defined (HAVE_GFC_INTEGER_16)


extern void product_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict);
export_proto(product_i16);

void
product_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict base;
  GFC_INTEGER_16 * 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->data == 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_16) * 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->data = internal_malloc_size (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))
	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)
	len = 0;
    }

  base = array->data;
  dest = retarray->data;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_INTEGER_16 * restrict src;
      GFC_INTEGER_16 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_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mproduct_i16);

void
mproduct_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict dest;
  const GFC_INTEGER_16 * 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->data;

  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->data == 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_16) * 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->data = internal_malloc_size (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->data;
  base = array->data;

  while (base)
    {
      const GFC_INTEGER_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 result;
      src = base;
      msrc = mbase;
      {

  result = 1;
	if (len <= 0)
	  *dest = 1;
	else
	  {
	    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_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sproduct_i16);

void
sproduct_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      product_i16 (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->data == 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_16) * 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->data = internal_malloc_size (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->data;

  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
644cb69f	1	/* Implementation of the PRODUCT intrinsic
0cd0559e	2	Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc.
644cb69f FXC	3	Contributed by Paul Brook <paul@nowt.org>
644cb69f FXC	4
0cd0559e	5	This file is part of the GNU Fortran runtime library (libgfortran).
644cb69f FXC	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.
644cb69f FXC	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/>. */
644cb69f	25
36ae8a61	26	#include "libgfortran.h"
644cb69f FXC	27	#include <stdlib.h>
644cb69f FXC	28	#include <assert.h>
644cb69f FXC	29
	30
	31	#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
	32
	33
64acfd99 JB	34	extern void product_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	35	gfc_array_i16 * const restrict, const index_type * const restrict);
644cb69f FXC	36	export_proto(product_i16);
	37
	38	void
64acfd99 JB	39	product_i16 (gfc_array_i16 * const restrict retarray,
	40	gfc_array_i16 * const restrict array,
	41	const index_type * const restrict pdim)
644cb69f FXC	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];
64acfd99 JB	47	const GFC_INTEGER_16 * restrict base;
64acfd99 JB	48	GFC_INTEGER_16 * restrict dest;
644cb69f FXC	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;
644cb69f FXC	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);
644cb69f FXC	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);
80ee04b9 TK	69
	70	if (extent[n] < 0)
	71	extent[n] = 0;
644cb69f FXC	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);
80ee04b9 TK	77
	78	if (extent[n] < 0)
	79	extent[n] = 0;
644cb69f FXC	80	}
	81
	82	if (retarray->data == NULL)
	83	{
dfb55fdc	84	size_t alloc_size, str;
80ee04b9	85
644cb69f	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	}
644cb69f	96
644cb69f FXC	97	retarray->offset = 0;
644cb69f FXC	98	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9	99
dfb55fdc	100	alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
80ee04b9 TK	101	* extent[rank-1];
	102
	103	if (alloc_size == 0)
	104	{
	105	/* Make sure we have a zero-sized array. */
dfb55fdc	106	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	107	return;
dfb55fdc	108
80ee04b9 TK	109	}
	110	else
	111	retarray->data = internal_malloc_size (alloc_size);
644cb69f FXC	112	}
	113	else
	114	{
644cb69f	115	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	116	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	117	" PRODUCT intrinsic: is %ld, should be %ld",
	118	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	119	(long int) rank);
fd6590f8	120
9731c4a3	121	if (unlikely (compile_options.bounds_check))
16bff921 TK	122	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	123	"return value", "PRODUCT");
644cb69f FXC	124	}
	125
	126	for (n = 0; n < rank; n++)
	127	{
	128	count[n] = 0;
dfb55fdc	129	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	130	if (extent[n] <= 0)
80927a56	131	len = 0;
644cb69f FXC	132	}
	133
	134	base = array->data;
	135	dest = retarray->data;
	136
da96f5ab TK	137	continue_loop = 1;
da96f5ab TK	138	while (continue_loop)
644cb69f	139	{
64acfd99	140	const GFC_INTEGER_16 * restrict src;
644cb69f FXC	141	GFC_INTEGER_16 result;
	142	src = base;
	143	{
	144
	145	result = 1;
80927a56	146	if (len <= 0)
644cb69f FXC	147	*dest = 1;
	148	else
	149	{
	150	for (n = 0; n < len; n++, src += delta)
	151	{
	152
	153	result = src;
80927a56	154	}
0cd0559e	155
644cb69f FXC	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++;
	174	if (n == rank)
	175	{
	176	/* Break out of the look. */
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	}
644cb69f FXC	187	}
	188	}
	189
	190
64acfd99 JB	191	extern void mproduct_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	192	gfc_array_i16 * const restrict, const index_type * const restrict,
28dc6b33	193	gfc_array_l1 * const restrict);
644cb69f FXC	194	export_proto(mproduct_i16);
	195
	196	void
64acfd99 JB	197	mproduct_i16 (gfc_array_i16 * const restrict retarray,
	198	gfc_array_i16 * const restrict array,
	199	const index_type * const restrict pdim,
28dc6b33	200	gfc_array_l1 * const restrict mask)
644cb69f FXC	201	{
	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_16 * restrict dest;
64acfd99 JB	208	const GFC_INTEGER_16 * restrict base;
28dc6b33	209	const GFC_LOGICAL_1 * restrict mbase;
644cb69f FXC	210	int rank;
	211	int dim;
	212	index_type n;
	213	index_type len;
	214	index_type delta;
	215	index_type mdelta;
28dc6b33	216	int mask_kind;
644cb69f FXC	217
	218	dim = (*pdim) - 1;
	219	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	220
dfb55fdc	221	len = GFC_DESCRIPTOR_EXTENT(array,dim);
644cb69f FXC	222	if (len <= 0)
644cb69f FXC	223	return;
28dc6b33 TK	224
	225	mbase = mask->data;
	226
	227	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	228
	229	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	230	#ifdef HAVE_GFC_LOGICAL_16
	231	\|\| mask_kind == 16
	232	#endif
	233	)
	234	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	235	else
	236	runtime_error ("Funny sized logical array");
	237
dfb55fdc TK	238	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	239	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
644cb69f FXC	240
	241	for (n = 0; n < dim; n++)
	242	{
dfb55fdc TK	243	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	244	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	245	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	246
	247	if (extent[n] < 0)
	248	extent[n] = 0;
	249
644cb69f FXC	250	}
	251	for (n = dim; n < rank; n++)
	252	{
dfb55fdc TK	253	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	254	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	255	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	256
	257	if (extent[n] < 0)
	258	extent[n] = 0;
644cb69f FXC	259	}
	260
	261	if (retarray->data == NULL)
	262	{
dfb55fdc	263	size_t alloc_size, str;
80ee04b9	264
644cb69f	265	for (n = 0; n < rank; n++)
80927a56 JJ	266	{
	267	if (n == 0)
	268	str = 1;
	269	else
	270	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	271
	272	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	273
80927a56	274	}
644cb69f	275
dfb55fdc	276	alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
80ee04b9 TK	277	* extent[rank-1];
80ee04b9 TK	278
644cb69f FXC	279	retarray->offset = 0;
644cb69f FXC	280	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	281
	282	if (alloc_size == 0)
	283	{
	284	/* Make sure we have a zero-sized array. */
dfb55fdc	285	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	286	return;
	287	}
	288	else
	289	retarray->data = internal_malloc_size (alloc_size);
	290
644cb69f FXC	291	}
	292	else
	293	{
644cb69f	294	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	295	runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
fd6590f8 TK	296
9731c4a3	297	if (unlikely (compile_options.bounds_check))
fd6590f8	298	{
16bff921 TK	299	bounds_ifunction_return ((array_t *) retarray, extent,
	300	"return value", "PRODUCT");
	301	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	302	"MASK argument", "PRODUCT");
fd6590f8	303	}
644cb69f FXC	304	}
	305
	306	for (n = 0; n < rank; n++)
	307	{
	308	count[n] = 0;
dfb55fdc	309	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	310	if (extent[n] <= 0)
80927a56	311	return;
644cb69f FXC	312	}
	313
	314	dest = retarray->data;
	315	base = array->data;
644cb69f FXC	316
	317	while (base)
	318	{
64acfd99	319	const GFC_INTEGER_16 * restrict src;
28dc6b33	320	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	321	GFC_INTEGER_16 result;
	322	src = base;
	323	msrc = mbase;
	324	{
	325
	326	result = 1;
80927a56	327	if (len <= 0)
644cb69f FXC	328	*dest = 1;
	329	else
	330	{
	331	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	332	{
	333
	334	if (*msrc)
	335	result = src;
80927a56	336	}
644cb69f FXC	337	*dest = result;
	338	}
	339	}
	340	/* Advance to the next element. */
	341	count[0]++;
	342	base += sstride[0];
	343	mbase += mstride[0];
	344	dest += dstride[0];
	345	n = 0;
	346	while (count[n] == extent[n])
80927a56 JJ	347	{
	348	/* When we get to the end of a dimension, reset it and increment
	349	the next dimension. */
	350	count[n] = 0;
	351	/* We could precalculate these products, but this is a less
	352	frequently used path so probably not worth it. */
	353	base -= sstride[n] * extent[n];
	354	mbase -= mstride[n] * extent[n];
	355	dest -= dstride[n] * extent[n];
	356	n++;
	357	if (n == rank)
	358	{
	359	/* Break out of the look. */
	360	base = NULL;
	361	break;
	362	}
	363	else
	364	{
	365	count[n]++;
	366	base += sstride[n];
	367	mbase += mstride[n];
	368	dest += dstride[n];
	369	}
	370	}
644cb69f FXC	371	}
	372	}
	373
97a62038 TK	374
	375	extern void sproduct_i16 (gfc_array_i16 * const restrict,
	376	gfc_array_i16 * const restrict, const index_type * const restrict,
	377	GFC_LOGICAL_4 *);
	378	export_proto(sproduct_i16);
	379
	380	void
	381	sproduct_i16 (gfc_array_i16 * const restrict retarray,
	382	gfc_array_i16 * const restrict array,
	383	const index_type * const restrict pdim,
	384	GFC_LOGICAL_4 * mask)
	385	{
802367d7 TK	386	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	387	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	388	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	389	GFC_INTEGER_16 * restrict dest;
97a62038 TK	390	index_type rank;
97a62038 TK	391	index_type n;
802367d7 TK	392	index_type dim;
802367d7 TK	393
97a62038 TK	394
	395	if (*mask)
	396	{
	397	product_i16 (retarray, array, pdim);
	398	return;
	399	}
802367d7 TK	400	/* Make dim zero based to avoid confusion. */
	401	dim = (*pdim) - 1;
	402	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	403
	404	for (n = 0; n < dim; n++)
	405	{
dfb55fdc	406	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	407
	408	if (extent[n] <= 0)
	409	extent[n] = 0;
	410	}
	411
	412	for (n = dim; n < rank; n++)
	413	{
802367d7	414	extent[n] =
80927a56	415	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	416
802367d7 TK	417	if (extent[n] <= 0)
80927a56	418	extent[n] = 0;
802367d7	419	}
97a62038 TK	420
	421	if (retarray->data == NULL)
	422	{
dfb55fdc	423	size_t alloc_size, str;
802367d7 TK	424
802367d7 TK	425	for (n = 0; n < rank; n++)
80927a56 JJ	426	{
	427	if (n == 0)
	428	str = 1;
	429	else
	430	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	431
	432	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	433
80927a56	434	}
802367d7	435
97a62038	436	retarray->offset = 0;
802367d7 TK	437	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	438
dfb55fdc	439	alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
802367d7 TK	440	* extent[rank-1];
	441
	442	if (alloc_size == 0)
	443	{
	444	/* Make sure we have a zero-sized array. */
dfb55fdc	445	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	446	return;
	447	}
	448	else
	449	retarray->data = internal_malloc_size (alloc_size);
97a62038 TK	450	}
	451	else
	452	{
802367d7 TK	453	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	454	runtime_error ("rank of return array incorrect in"
	455	" PRODUCT intrinsic: is %ld, should be %ld",
	456	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	457	(long int) rank);
	458
9731c4a3	459	if (unlikely (compile_options.bounds_check))
fd6590f8	460	{
802367d7 TK	461	for (n=0; n < rank; n++)
	462	{
	463	index_type ret_extent;
97a62038	464
dfb55fdc	465	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	466	if (extent[n] != ret_extent)
	467	runtime_error ("Incorrect extent in return value of"
	468	" PRODUCT intrinsic in dimension %ld:"
	469	" is %ld, should be %ld", (long int) n + 1,
	470	(long int) ret_extent, (long int) extent[n]);
	471	}
fd6590f8 TK	472	}
fd6590f8 TK	473	}
97a62038	474
802367d7 TK	475	for (n = 0; n < rank; n++)
	476	{
	477	count[n] = 0;
dfb55fdc	478	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	479	}
	480
	481	dest = retarray->data;
	482
	483	while(1)
	484	{
	485	*dest = 1;
	486	count[0]++;
	487	dest += dstride[0];
	488	n = 0;
	489	while (count[n] == extent[n])
80927a56	490	{
802367d7	491	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	492	the next dimension. */
	493	count[n] = 0;
	494	/* We could precalculate these products, but this is a less
	495	frequently used path so probably not worth it. */
	496	dest -= dstride[n] * extent[n];
	497	n++;
	498	if (n == rank)
802367d7	499	return;
80927a56 JJ	500	else
	501	{
	502	count[n]++;
	503	dest += dstride[n];
	504	}
802367d7 TK	505	}
802367d7 TK	506	}
97a62038 TK	507	}
97a62038 TK	508
644cb69f	509	#endif