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

/* Specific implementation of the PACK intrinsic
   Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 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.

Ligbfortran 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>
#include <string.h>


#if defined (HAVE_GFC_INTEGER_8)

/* PACK is specified as follows:

   13.14.80 PACK (ARRAY, MASK, [VECTOR])

   Description: Pack an array into an array of rank one under the
   control of a mask.

   Class: Transformational function.

   Arguments:
      ARRAY   may be of any type. It shall not be scalar.
      MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
      VECTOR  (optional) shall be of the same type and type parameters
              as ARRAY. VECTOR shall have at least as many elements as
              there are true elements in MASK. If MASK is a scalar
              with the value true, VECTOR shall have at least as many
              elements as there are in ARRAY.

   Result Characteristics: The result is an array of rank one with the
   same type and type parameters as ARRAY. If VECTOR is present, the
   result size is that of VECTOR; otherwise, the result size is the
   number /t/ of true elements in MASK unless MASK is scalar with the
   value true, in which case the result size is the size of ARRAY.

   Result Value: Element /i/ of the result is the element of ARRAY
   that corresponds to the /i/th true element of MASK, taking elements
   in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
   present and has size /n/ > /t/, element /i/ of the result has the
   value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.

   Examples: The nonzero elements of an array M with the value
   | 0 0 0 |
   | 9 0 0 | may be "gathered" by the function PACK. The result of
   | 0 0 7 |
   PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
   VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].

There are two variants of the PACK intrinsic: one, where MASK is
array valued, and the other one where MASK is scalar.  */

void
pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array,
	       const gfc_array_l1 *mask, const gfc_array_i8 *vector)
{
  /* r.* indicates the return array.  */
  index_type rstride0;
  GFC_INTEGER_8 * restrict rptr;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  const GFC_INTEGER_8 *sptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_1 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  int zero_sized;
  index_type n;
  index_type dim;
  index_type nelem;
  index_type total;
  int mask_kind;

  dim = GFC_DESCRIPTOR_RANK (array);

  mptr = mask->data;

  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
     and using shifting to address size and endian issues.  */

  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
      )
    {
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
      if (mptr)
	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
    }
  else
    runtime_error ("Funny sized logical array");

  zero_sized = 0;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
      if (extent[n] <= 0)
       zero_sized = 1;
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride * mask_kind;
    }
  if (sstride[0] == 0)
    sstride[0] = 1;
  if (mstride[0] == 0)
    mstride[0] = mask_kind;

  if (zero_sized)
    sptr = NULL;
  else
    sptr = array->data;

  if (ret->data == NULL || compile_options.bounds_check)
    {
      /* Count the elements, either for allocating memory or
	 for bounds checking.  */

      if (vector != NULL)
	{
	  /* The return array will have as many
	     elements as there are in VECTOR.  */
	  total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
	  if (total < 0)
	    {
	      total = 0;
	      vector = NULL;
	    }
	}
      else
	{
	  /* We have to count the true elements in MASK.  */

	  /* TODO: We could speed up pack easily in the case of only
	     few .TRUE. entries in MASK, by keeping track of where we
	     would be in the source array during the initial traversal
	     of MASK, and caching the pointers to those elements. Then,
	     supposed the number of elements is small enough, we would
	     only have to traverse the list, and copy those elements
	     into the result array. In the case of datatypes which fit
	     in one of the integer types we could also cache the
	     value instead of a pointer to it.
	     This approach might be bad from the point of view of
	     cache behavior in the case where our cache is not big
	     enough to hold all elements that have to be copied.  */

	  const GFC_LOGICAL_1 *m = mptr;

	  total = 0;
	  if (zero_sized)
	    m = NULL;

	  while (m)
	    {
	      /* Test this element.  */
	      if (*m)
		total++;

	      /* Advance to the next element.  */
	      m += mstride[0];
	      count[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 this product, but this is a
		     less frequently used path so probably not worth
		     it.  */
		  m -= mstride[n] * extent[n];
		  n++;
		  if (n >= dim)
		    {
		      /* Break out of the loop.  */
		      m = NULL;
		      break;
		    }
		  else
		    {
		      count[n]++;
		      m += mstride[n];
		    }
		}
	    }
	}

      if (ret->data == NULL)
	{
	  /* Setup the array descriptor.  */
	  ret->dim[0].lbound = 0;
	  ret->dim[0].ubound = total - 1;
	  ret->dim[0].stride = 1;

	  ret->offset = 0;
	  if (total == 0)
	    {
	      /* In this case, nothing remains to be done.  */
	      ret->data = internal_malloc_size (1);
	      return;
	    }
	  else
	    ret->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * total);
	}
      else 
	{
	  /* We come here because of range checking.  */
	  index_type ret_extent;

	  ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound;
	  if (total != ret_extent)
	    runtime_error ("Incorrect extent in return value of PACK intrinsic;"
			   " is %ld, should be %ld", (long int) total,
			   (long int) ret_extent);
	}
    }

  rstride0 = ret->dim[0].stride;
  if (rstride0 == 0)
    rstride0 = 1;
  sstride0 = sstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;

  while (sptr && mptr)
    {
      /* Test this element.  */
      if (*mptr)
        {
          /* Add it.  */
	  *rptr = *sptr;
          rptr += rstride0;
        }
      /* Advance to the next element.  */
      sptr += sstride0;
      mptr += mstride0;
      count[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.  */
          sptr -= sstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              sptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              sptr += sstride[n];
              mptr += mstride[n];
            }
        }
    }

  /* Add any remaining elements from VECTOR.  */
  if (vector)
    {
      n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
      nelem = ((rptr - ret->data) / rstride0);
      if (n > nelem)
        {
          sstride0 = vector->dim[0].stride;
          if (sstride0 == 0)
            sstride0 = 1;

          sptr = vector->data + sstride0 * nelem;
          n -= nelem;
          while (n--)
            {
	      *rptr = *sptr;
              rptr += rstride0;
              sptr += sstride0;
            }
        }
    }
}

#endif
Commit	Line	Data
3ef2513a	1	/* Specific implementation of the PACK intrinsic
748086b7	2	Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
3ef2513a TK	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	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.
3ef2513a TK	11
	12	Ligbfortran 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/>. */
3ef2513a TK	25
	26	#include "libgfortran.h"
	27	#include <stdlib.h>
	28	#include <assert.h>
	29	#include <string.h>
	30
	31
	32	#if defined (HAVE_GFC_INTEGER_8)
	33
	34	/* PACK is specified as follows:
	35
	36	13.14.80 PACK (ARRAY, MASK, [VECTOR])
	37
	38	Description: Pack an array into an array of rank one under the
	39	control of a mask.
	40
	41	Class: Transformational function.
	42
	43	Arguments:
	44	ARRAY may be of any type. It shall not be scalar.
	45	MASK shall be of type LOGICAL. It shall be conformable with ARRAY.
	46	VECTOR (optional) shall be of the same type and type parameters
	47	as ARRAY. VECTOR shall have at least as many elements as
	48	there are true elements in MASK. If MASK is a scalar
	49	with the value true, VECTOR shall have at least as many
	50	elements as there are in ARRAY.
	51
	52	Result Characteristics: The result is an array of rank one with the
	53	same type and type parameters as ARRAY. If VECTOR is present, the
	54	result size is that of VECTOR; otherwise, the result size is the
	55	number /t/ of true elements in MASK unless MASK is scalar with the
	56	value true, in which case the result size is the size of ARRAY.
	57
	58	Result Value: Element /i/ of the result is the element of ARRAY
	59	that corresponds to the /i/th true element of MASK, taking elements
	60	in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
	61	present and has size /n/ > /t/, element /i/ of the result has the
	62	value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
	63
	64	Examples: The nonzero elements of an array M with the value
	65	\| 0 0 0 \|
	66	\| 9 0 0 \| may be "gathered" by the function PACK. The result of
	67	\| 0 0 7 \|
	68	PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
	69	VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
	70
	71	There are two variants of the PACK intrinsic: one, where MASK is
	72	array valued, and the other one where MASK is scalar. */
	73
	74	void
	75	pack_i8 (gfc_array_i8 ret, const gfc_array_i8 array,
	76	const gfc_array_l1 mask, const gfc_array_i8 vector)
	77	{
	78	/* r.* indicates the return array. */
	79	index_type rstride0;
5863aacf	80	GFC_INTEGER_8 * restrict rptr;
3ef2513a TK	81	/* s.* indicates the source array. */
	82	index_type sstride[GFC_MAX_DIMENSIONS];
	83	index_type sstride0;
	84	const GFC_INTEGER_8 *sptr;
	85	/* m.* indicates the mask array. */
	86	index_type mstride[GFC_MAX_DIMENSIONS];
	87	index_type mstride0;
	88	const GFC_LOGICAL_1 *mptr;
	89
	90	index_type count[GFC_MAX_DIMENSIONS];
	91	index_type extent[GFC_MAX_DIMENSIONS];
	92	int zero_sized;
	93	index_type n;
	94	index_type dim;
	95	index_type nelem;
	96	index_type total;
	97	int mask_kind;
	98
	99	dim = GFC_DESCRIPTOR_RANK (array);
	100
3ef2513a TK	101	mptr = mask->data;
	102
	103	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	104	and using shifting to address size and endian issues. */
	105
	106	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	107
	108	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	109	#ifdef HAVE_GFC_LOGICAL_16
	110	\|\| mask_kind == 16
	111	#endif
	112	)
	113	{
	114	/* Do not convert a NULL pointer as we use test for NULL below. */
	115	if (mptr)
	116	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	117	}
	118	else
	119	runtime_error ("Funny sized logical array");
	120
	121	zero_sized = 0;
	122	for (n = 0; n < dim; n++)
	123	{
	124	count[n] = 0;
	125	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	126	if (extent[n] <= 0)
	127	zero_sized = 1;
	128	sstride[n] = array->dim[n].stride;
	129	mstride[n] = mask->dim[n].stride * mask_kind;
	130	}
	131	if (sstride[0] == 0)
	132	sstride[0] = 1;
	133	if (mstride[0] == 0)
	134	mstride[0] = mask_kind;
	135
7ad99d60 TK	136	if (zero_sized)
	137	sptr = NULL;
	138	else
	139	sptr = array->data;
	140
3ef2513a TK	141	if (ret->data == NULL \|\| compile_options.bounds_check)
	142	{
	143	/* Count the elements, either for allocating memory or
	144	for bounds checking. */
	145
	146	if (vector != NULL)
	147	{
	148	/* The return array will have as many
	149	elements as there are in VECTOR. */
	150	total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
7ad99d60 TK	151	if (total < 0)
	152	{
	153	total = 0;
	154	vector = NULL;
	155	}
3ef2513a TK	156	}
	157	else
	158	{
	159	/* We have to count the true elements in MASK. */
	160
	161	/* TODO: We could speed up pack easily in the case of only
	162	few .TRUE. entries in MASK, by keeping track of where we
	163	would be in the source array during the initial traversal
	164	of MASK, and caching the pointers to those elements. Then,
	165	supposed the number of elements is small enough, we would
	166	only have to traverse the list, and copy those elements
	167	into the result array. In the case of datatypes which fit
	168	in one of the integer types we could also cache the
	169	value instead of a pointer to it.
	170	This approach might be bad from the point of view of
	171	cache behavior in the case where our cache is not big
	172	enough to hold all elements that have to be copied. */
	173
	174	const GFC_LOGICAL_1 *m = mptr;
	175
	176	total = 0;
	177	if (zero_sized)
	178	m = NULL;
	179
	180	while (m)
	181	{
	182	/* Test this element. */
	183	if (*m)
	184	total++;
	185
	186	/* Advance to the next element. */
	187	m += mstride[0];
	188	count[0]++;
	189	n = 0;
	190	while (count[n] == extent[n])
	191	{
	192	/* When we get to the end of a dimension, reset it
	193	and increment the next dimension. */
	194	count[n] = 0;
	195	/* We could precalculate this product, but this is a
	196	less frequently used path so probably not worth
	197	it. */
	198	m -= mstride[n] * extent[n];
	199	n++;
	200	if (n >= dim)
	201	{
	202	/* Break out of the loop. */
	203	m = NULL;
	204	break;
	205	}
	206	else
	207	{
	208	count[n]++;
	209	m += mstride[n];
	210	}
	211	}
	212	}
	213	}
	214
	215	if (ret->data == NULL)
	216	{
	217	/* Setup the array descriptor. */
	218	ret->dim[0].lbound = 0;
	219	ret->dim[0].ubound = total - 1;
220	ret->dim[0].stride = 1;
221
222	ret->offset = 0;
223	if (total == 0)
224	{
225	/* In this case, nothing remains to be done. */
226	ret->data = internal_malloc_size (1);
227	return;
228	}
229	else
230	ret->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * total);
231	}
232	else
233	{
234	/* We come here because of range checking. */
235	index_type ret_extent;
236
237	ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound;
238	if (total != ret_extent)
239	runtime_error ("Incorrect extent in return value of PACK intrinsic;"
240	" is %ld, should be %ld", (long int) total,
241	(long int) ret_extent);
242	}
243	}
244
245	rstride0 = ret->dim[0].stride;
246	if (rstride0 == 0)
247	rstride0 = 1;
248	sstride0 = sstride[0];
249	mstride0 = mstride[0];
250	rptr = ret->data;
251
252	while (sptr && mptr)
253	{
254	/* Test this element. */
255	if (*mptr)
256	{
257	/* Add it. */
258	rptr = sptr;
259	rptr += rstride0;
260	}
261	/* Advance to the next element. */
262	sptr += sstride0;
263	mptr += mstride0;
264	count[0]++;
265	n = 0;
266	while (count[n] == extent[n])
267	{
268	/* When we get to the end of a dimension, reset it and increment
269	the next dimension. */
270	count[n] = 0;
271	/* We could precalculate these products, but this is a less
272	frequently used path so probably not worth it. */
273	sptr -= sstride[n] * extent[n];
274	mptr -= mstride[n] * extent[n];
275	n++;
276	if (n >= dim)
277	{
278	/* Break out of the loop. */
279	sptr = NULL;
280	break;
281	}
282	else
283	{
284	count[n]++;
285	sptr += sstride[n];
286	mptr += mstride[n];
287	}
288	}
289	}
290
291	/* Add any remaining elements from VECTOR. */
292	if (vector)
293	{
294	n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
295	nelem = ((rptr - ret->data) / rstride0);
296	if (n > nelem)
297	{
298	sstride0 = vector->dim[0].stride;
299	if (sstride0 == 0)
300	sstride0 = 1;
301
302	sptr = vector->data + sstride0 * nelem;
303	n -= nelem;
304	while (n--)
305	{
306	rptr = sptr;
307	rptr += rstride0;
308	sptr += sstride0;
309	}
310	}
311	}
312	}
313
314	#endif
7ad99d60	315