[thirdparty/gcc.git] / libgfortran / m4 / unpack.m4

`/* 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>'

include(iparm.m4)dnl

`#if defined (HAVE_'rtype_name`)

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