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

/* Specific implementation of the UNPACK intrinsic
   Copyright (C) 2008-2016 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 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_8)

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

  /* 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->base_addr == 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->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
      rstride[0] = 1;
      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->base_addr;
  vptr = vector->base_addr;

  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_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector,
		 const gfc_array_l1 *mask, const gfc_array_r8 *field)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  GFC_REAL_8 * restrict rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  GFC_REAL_8 *vptr;
  /* f.* indicates the field array.  */
  index_type fstride[GFC_MAX_DIMENSIONS];
  index_type fstride0;
  const GFC_REAL_8 *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->base_addr;

  /* 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->base_addr == 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->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
      rstride[0] = 1;
      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->base_addr;
  fptr = field->base_addr;
  vptr = vector->base_addr;

  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
818ab71a	2	Copyright (C) 2008-2016 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
21d1335b	6	This file is part of the GNU Fortran runtime library (libgfortran).
3478bba4 TK	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_8)
	34
	35	void
	36	unpack0_r8 (gfc_array_r8 ret, const gfc_array_r8 vector,
	37	const gfc_array_l1 mask, const GFC_REAL_8 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_8 * restrict rptr;
3478bba4 TK	44	/* v.* indicates the vector array. */
	45	index_type vstride0;
	46	GFC_REAL_8 *vptr;
	47	/* Value for field, this is constant. */
	48	const GFC_REAL_8 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
21d1335b	64	mptr = mask->base_addr;
3478bba4 TK	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
21d1335b	84	if (ret->base_addr == NULL)
3478bba4 TK	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;
92e6f3a4	102	ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
3478bba4 TK	103	}
	104	else
	105	{
	106	dim = GFC_DESCRIPTOR_RANK (ret);
b95216f7 JB	107	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
b95216f7 JB	108	rstride[0] = 1;
3478bba4 TK	109	for (n = 0; n < dim; n++)
	110	{
	111	count[n] = 0;
dfb55fdc	112	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	113	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	114	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
dfb55fdc TK	115	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	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
dfb55fdc	127	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
3478bba4 TK	128	if (vstride0 == 0)
	129	vstride0 = 1;
	130	rstride0 = rstride[0];
	131	mstride0 = mstride[0];
21d1335b TB	132	rptr = ret->base_addr;
21d1335b TB	133	vptr = vector->base_addr;
3478bba4 TK	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_r8 (gfc_array_r8 ret, const gfc_array_r8 vector,
	181	const gfc_array_l1 mask, const gfc_array_r8 field)
	182	{
	183	/* r.* indicates the return array. */
	184	index_type rstride[GFC_MAX_DIMENSIONS];
	185	index_type rstride0;
	186	index_type rs;
5863aacf	187	GFC_REAL_8 * restrict rptr;
3478bba4 TK	188	/* v.* indicates the vector array. */
	189	index_type vstride0;
	190	GFC_REAL_8 *vptr;
	191	/* f.* indicates the field array. */
	192	index_type fstride[GFC_MAX_DIMENSIONS];
	193	index_type fstride0;
	194	const GFC_REAL_8 *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
21d1335b	210	mptr = mask->base_addr;
3478bba4 TK	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
21d1335b	230	if (ret->base_addr == NULL)
3478bba4 TK	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;
dfb55fdc TK	239	GFC_DIMENSION_SET(ret->dim[n], 0,
	240	GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	241	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	242	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	243	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	244	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	245	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	246	rs *= extent[n];
	247	}
	248	ret->offset = 0;
92e6f3a4	249	ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_8));
3478bba4 TK	250	}
	251	else
	252	{
	253	dim = GFC_DESCRIPTOR_RANK (ret);
b95216f7 JB	254	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
b95216f7 JB	255	rstride[0] = 1;
3478bba4 TK	256	for (n = 0; n < dim; n++)
	257	{
	258	count[n] = 0;
dfb55fdc	259	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	260	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	261	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	262	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	263	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	264	}
	265	if (rstride[0] == 0)
	266	rstride[0] = 1;
	267	}
	268
	269	if (empty)
	270	return;
	271
	272	if (fstride[0] == 0)
	273	fstride[0] = 1;
	274	if (mstride[0] == 0)
	275	mstride[0] = 1;
	276
dfb55fdc	277	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
3478bba4 TK	278	if (vstride0 == 0)
	279	vstride0 = 1;
	280	rstride0 = rstride[0];
	281	fstride0 = fstride[0];
	282	mstride0 = mstride[0];
21d1335b TB	283	rptr = ret->base_addr;
	284	fptr = field->base_addr;
	285	vptr = vector->base_addr;
3478bba4 TK	286
	287	while (rptr)
	288	{
	289	if (*mptr)
	290	{
	291	/* From vector. */
	292	rptr = vptr;
	293	vptr += vstride0;
	294	}
	295	else
	296	{
	297	/* From field. */
	298	rptr = fptr;
	299	}
	300	/* Advance to the next element. */
	301	rptr += rstride0;
	302	fptr += fstride0;
	303	mptr += mstride0;
	304	count[0]++;
	305	n = 0;
	306	while (count[n] == extent[n])
	307	{
	308	/* When we get to the end of a dimension, reset it and increment
	309	the next dimension. */
	310	count[n] = 0;
	311	/* We could precalculate these products, but this is a less
	312	frequently used path so probably not worth it. */
	313	rptr -= rstride[n] * extent[n];
	314	fptr -= fstride[n] * extent[n];
	315	mptr -= mstride[n] * extent[n];
	316	n++;
	317	if (n >= dim)
	318	{
	319	/* Break out of the loop. */
	320	rptr = NULL;
	321	break;
	322	}
	323	else
	324	{
	325	count[n]++;
	326	rptr += rstride[n];
	327	fptr += fstride[n];
	328	mptr += mstride[n];
	329	}
	330	}
	331	}
	332	}
	333
	334	#endif
	335