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

/* Specific implementation of the UNPACK intrinsic
   Copyright 2008 Free Software Foundation, Inc.
   Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
   unpack_generic.c 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
#include <string.h>


#if defined (HAVE_GFC_COMPLEX_10)

void
unpack0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector,
		 const gfc_array_l1 *mask, const GFC_COMPLEX_10 *fptr)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  GFC_COMPLEX_10 * restrict rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  GFC_COMPLEX_10 *vptr;
  /* Value for field, this is constant.  */
  const GFC_COMPLEX_10 fval = *fptr;
  /* 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];
  index_type n;
  index_type dim;

  int empty;
  int mask_kind;

  empty = 0;

  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");

  if (ret->data == NULL)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      dim = GFC_DESCRIPTOR_RANK (mask);
      rs = 1;
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  ret->dim[n].stride = rs;
	  ret->dim[n].lbound = 0;
	  ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	  extent[n] = ret->dim[n].ubound + 1;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	  rs *= extent[n];
	}
      ret->offset = 0;
      ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	}
      if (rstride[0] == 0)
	rstride[0] = 1;
    }

  if (empty)
    return;

  if (mstride[0] == 0)
    mstride[0] = 1;

  vstride0 = vector->dim[0].stride;
  if (vstride0 == 0)
    vstride0 = 1;
  rstride0 = rstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;
  vptr = vector->data;

  while (rptr)
    {
      if (*mptr)
        {
	  /* From vector.  */
	  *rptr = *vptr;
	  vptr += vstride0;
        }
      else
        {
	  /* From field.  */
	  *rptr = fval;
        }
      /* Advance to the next element.  */
      rptr += rstride0;
      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.  */
          rptr -= rstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              mptr += mstride[n];
            }
        }
    }
}

void
unpack1_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector,
		 const gfc_array_l1 *mask, const gfc_array_c10 *field)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  GFC_COMPLEX_10 * restrict rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  GFC_COMPLEX_10 *vptr;
  /* f.* indicates the field array.  */
  index_type fstride[GFC_MAX_DIMENSIONS];
  index_type fstride0;
  const GFC_COMPLEX_10 *fptr;
  /* 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];
  index_type n;
  index_type dim;

  int empty;
  int mask_kind;

  empty = 0;

  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");

  if (ret->data == NULL)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      dim = GFC_DESCRIPTOR_RANK (mask);
      rs = 1;
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  ret->dim[n].stride = rs;
	  ret->dim[n].lbound = 0;
	  ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	  extent[n] = ret->dim[n].ubound + 1;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride;
	  fstride[n] = field->dim[n].stride;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	  rs *= extent[n];
	}
      ret->offset = 0;
      ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride;
	  fstride[n] = field->dim[n].stride;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	}
      if (rstride[0] == 0)
	rstride[0] = 1;
    }

  if (empty)
    return;

  if (fstride[0] == 0)
    fstride[0] = 1;
  if (mstride[0] == 0)
    mstride[0] = 1;

  vstride0 = vector->dim[0].stride;
  if (vstride0 == 0)
    vstride0 = 1;
  rstride0 = rstride[0];
  fstride0 = fstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;
  fptr = field->data;
  vptr = vector->data;

  while (rptr)
    {
      if (*mptr)
        {
          /* From vector.  */
	  *rptr = *vptr;
          vptr += vstride0;
        }
      else
        {
          /* From field.  */
	  *rptr = *fptr;
        }
      /* Advance to the next element.  */
      rptr += rstride0;
      fptr += fstride0;
      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.  */
          rptr -= rstride[n] * extent[n];
          fptr -= fstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              fptr += fstride[n];
              mptr += mstride[n];
            }
        }
    }
}

#endif
Commit	Line	Data
3478bba4 TK	1	/* Specific implementation of the UNPACK intrinsic
	2	Copyright 2008 Free Software Foundation, Inc.
	3	Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
	4	unpack_generic.c by Paul Brook <paul@nowt.org>.
	5
	6	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	7
	8	Libgfortran is free software; you can redistribute it and/or
	9	modify it under the terms of the GNU General Public
	10	License as published by the Free Software Foundation; either
	11	version 2 of the License, or (at your option) any later version.
	12
	13	In addition to the permissions in the GNU General Public License, the
	14	Free Software Foundation gives you unlimited permission to link the
	15	compiled version of this file into combinations with other programs,
	16	and to distribute those combinations without any restriction coming
	17	from the use of this file. (The General Public License restrictions
	18	do apply in other respects; for example, they cover modification of
	19	the file, and distribution when not linked into a combine
	20	executable.)
	21
	22	Ligbfortran is distributed in the hope that it will be useful,
	23	but WITHOUT ANY WARRANTY; without even the implied warranty of
	24	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	25	GNU General Public License for more details.
	26
	27	You should have received a copy of the GNU General Public
	28	License along with libgfortran; see the file COPYING. If not,
	29	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	30	Boston, MA 02110-1301, USA. */
	31
	32	#include "libgfortran.h"
	33	#include <stdlib.h>
	34	#include <assert.h>
	35	#include <string.h>
	36
	37
	38	#if defined (HAVE_GFC_COMPLEX_10)
	39
	40	void
	41	unpack0_c10 (gfc_array_c10 ret, const gfc_array_c10 vector,
	42	const gfc_array_l1 mask, const GFC_COMPLEX_10 fptr)
	43	{
	44	/* r.* indicates the return array. */
	45	index_type rstride[GFC_MAX_DIMENSIONS];
	46	index_type rstride0;
	47	index_type rs;
5863aacf	48	GFC_COMPLEX_10 * restrict rptr;
3478bba4 TK	49	/* v.* indicates the vector array. */
	50	index_type vstride0;
	51	GFC_COMPLEX_10 *vptr;
	52	/* Value for field, this is constant. */
	53	const GFC_COMPLEX_10 fval = *fptr;
	54	/* m.* indicates the mask array. */
	55	index_type mstride[GFC_MAX_DIMENSIONS];
	56	index_type mstride0;
	57	const GFC_LOGICAL_1 *mptr;
	58
	59	index_type count[GFC_MAX_DIMENSIONS];
	60	index_type extent[GFC_MAX_DIMENSIONS];
	61	index_type n;
	62	index_type dim;
	63
	64	int empty;
	65	int mask_kind;
	66
	67	empty = 0;
	68
	69	mptr = mask->data;
	70
	71	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	72	and using shifting to address size and endian issues. */
	73
	74	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	75
	76	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	77	#ifdef HAVE_GFC_LOGICAL_16
	78	\|\| mask_kind == 16
	79	#endif
	80	)
	81	{
	82	/* Do not convert a NULL pointer as we use test for NULL below. */
	83	if (mptr)
	84	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	85	}
	86	else
	87	runtime_error ("Funny sized logical array");
	88
	89	if (ret->data == NULL)
	90	{
	91	/* The front end has signalled that we need to populate the
	92	return array descriptor. */
	93	dim = GFC_DESCRIPTOR_RANK (mask);
	94	rs = 1;
	95	for (n = 0; n < dim; n++)
	96	{
	97	count[n] = 0;
	98	ret->dim[n].stride = rs;
	99	ret->dim[n].lbound = 0;
	100	ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	101	extent[n] = ret->dim[n].ubound + 1;
	102	empty = empty \|\| extent[n] <= 0;
	103	rstride[n] = ret->dim[n].stride;
	104	mstride[n] = mask->dim[n].stride * mask_kind;
	105	rs *= extent[n];
	106	}
	107	ret->offset = 0;
	108	ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10));
	109	}
	110	else
	111	{
	112	dim = GFC_DESCRIPTOR_RANK (ret);
113	for (n = 0; n < dim; n++)
114	{
115	count[n] = 0;
116	extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
117	empty = empty \|\| extent[n] <= 0;
118	rstride[n] = ret->dim[n].stride;
119	mstride[n] = mask->dim[n].stride * mask_kind;
120	}
121	if (rstride[0] == 0)
122	rstride[0] = 1;
123	}
124
125	if (empty)
126	return;
127
128	if (mstride[0] == 0)
129	mstride[0] = 1;
130
131	vstride0 = vector->dim[0].stride;
132	if (vstride0 == 0)
133	vstride0 = 1;
134	rstride0 = rstride[0];
135	mstride0 = mstride[0];
136	rptr = ret->data;
137	vptr = vector->data;
138
139	while (rptr)
140	{
141	if (*mptr)
142	{
143	/* From vector. */
144	rptr = vptr;
145	vptr += vstride0;
146	}
147	else
148	{
149	/* From field. */
150	*rptr = fval;
151	}
152	/* Advance to the next element. */
153	rptr += rstride0;
154	mptr += mstride0;
155	count[0]++;
156	n = 0;
157	while (count[n] == extent[n])
158	{
159	/* When we get to the end of a dimension, reset it and increment
160	the next dimension. */
161	count[n] = 0;
162	/* We could precalculate these products, but this is a less
163	frequently used path so probably not worth it. */
164	rptr -= rstride[n] * extent[n];
165	mptr -= mstride[n] * extent[n];
166	n++;
167	if (n >= dim)
168	{
169	/* Break out of the loop. */
170	rptr = NULL;
171	break;
172	}
173	else
174	{
175	count[n]++;
176	rptr += rstride[n];
177	mptr += mstride[n];
178	}
179	}
180	}
181	}
182
183	void
184	unpack1_c10 (gfc_array_c10 ret, const gfc_array_c10 vector,
185	const gfc_array_l1 mask, const gfc_array_c10 field)
186	{
187	/* r.* indicates the return array. */
188	index_type rstride[GFC_MAX_DIMENSIONS];
189	index_type rstride0;
190	index_type rs;
5863aacf	191	GFC_COMPLEX_10 * restrict rptr;
3478bba4 TK	192	/* v.* indicates the vector array. */
	193	index_type vstride0;
	194	GFC_COMPLEX_10 *vptr;
	195	/* f.* indicates the field array. */
	196	index_type fstride[GFC_MAX_DIMENSIONS];
	197	index_type fstride0;
	198	const GFC_COMPLEX_10 *fptr;
	199	/* m.* indicates the mask array. */
	200	index_type mstride[GFC_MAX_DIMENSIONS];
	201	index_type mstride0;
	202	const GFC_LOGICAL_1 *mptr;
	203
	204	index_type count[GFC_MAX_DIMENSIONS];
	205	index_type extent[GFC_MAX_DIMENSIONS];
	206	index_type n;
	207	index_type dim;
	208
	209	int empty;
	210	int mask_kind;
	211
	212	empty = 0;
	213
	214	mptr = mask->data;
	215
	216	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	217	and using shifting to address size and endian issues. */
	218
	219	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	220
	221	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	222	#ifdef HAVE_GFC_LOGICAL_16
	223	\|\| mask_kind == 16
	224	#endif
	225	)
	226	{
	227	/* Do not convert a NULL pointer as we use test for NULL below. */
	228	if (mptr)
	229	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	230	}
	231	else
	232	runtime_error ("Funny sized logical array");
	233
	234	if (ret->data == NULL)
	235	{
	236	/* The front end has signalled that we need to populate the
	237	return array descriptor. */
	238	dim = GFC_DESCRIPTOR_RANK (mask);
	239	rs = 1;
	240	for (n = 0; n < dim; n++)
	241	{
	242	count[n] = 0;
	243	ret->dim[n].stride = rs;
	244	ret->dim[n].lbound = 0;
	245	ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	246	extent[n] = ret->dim[n].ubound + 1;
	247	empty = empty \|\| extent[n] <= 0;
	248	rstride[n] = ret->dim[n].stride;
	249	fstride[n] = field->dim[n].stride;
	250	mstride[n] = mask->dim[n].stride * mask_kind;
	251	rs *= extent[n];
	252	}
	253	ret->offset = 0;
	254	ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10));
	255	}
256	else
257	{
258	dim = GFC_DESCRIPTOR_RANK (ret);
259	for (n = 0; n < dim; n++)
260	{
261	count[n] = 0;
262	extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
263	empty = empty \|\| extent[n] <= 0;
264	rstride[n] = ret->dim[n].stride;
265	fstride[n] = field->dim[n].stride;
266	mstride[n] = mask->dim[n].stride * mask_kind;
267	}
268	if (rstride[0] == 0)
269	rstride[0] = 1;
270	}
271
272	if (empty)
273	return;
274
275	if (fstride[0] == 0)
276	fstride[0] = 1;
277	if (mstride[0] == 0)
278	mstride[0] = 1;
279
280	vstride0 = vector->dim[0].stride;
281	if (vstride0 == 0)
282	vstride0 = 1;
283	rstride0 = rstride[0];
284	fstride0 = fstride[0];
285	mstride0 = mstride[0];
286	rptr = ret->data;
287	fptr = field->data;
288	vptr = vector->data;
289
290	while (rptr)
291	{
292	if (*mptr)
293	{
294	/* From vector. */
295	rptr = vptr;
296	vptr += vstride0;
297	}
298	else
299	{
300	/* From field. */
301	rptr = fptr;
302	}
303	/* Advance to the next element. */
304	rptr += rstride0;
305	fptr += fstride0;
306	mptr += mstride0;
307	count[0]++;
308	n = 0;
309	while (count[n] == extent[n])
310	{
311	/* When we get to the end of a dimension, reset it and increment
312	the next dimension. */
313	count[n] = 0;
314	/* We could precalculate these products, but this is a less
315	frequently used path so probably not worth it. */
316	rptr -= rstride[n] * extent[n];
317	fptr -= fstride[n] * extent[n];
318	mptr -= mstride[n] * extent[n];
319	n++;
320	if (n >= dim)
321	{
322	/* Break out of the loop. */
323	rptr = NULL;
324	break;
325	}
326	else
327	{
328	count[n]++;
329	rptr += rstride[n];
330	fptr += fstride[n];
331	mptr += mstride[n];
332	}
333	}
334	}
335	}
336
337	#endif
338