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

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

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