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

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