[thirdparty/gcc.git] / libgfortran / generated / unpack_r4.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_REAL_4)

void
unpack0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector,
		 const gfc_array_l1 *mask, const GFC_REAL_4 *fptr)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  GFC_REAL_4 * restrict rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  GFC_REAL_4 *vptr;
  /* Value for field, this is constant.  */
  const GFC_REAL_4 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;
	  GFC_DIMENSION_SET(ret->dim[n], 0,
			    GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	  extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
	  empty = empty || extent[n] <= 0;
	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	  rs *= extent[n];
	}
      ret->offset = 0;
      ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_4));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
	  empty = empty || extent[n] <= 0;
	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	}
      if (rstride[0] == 0)
	rstride[0] = 1;
    }

  if (empty)
    return;

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

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