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

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

  /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
  rstride[0] = 1;
  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);
      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");

  /* Initialize to avoid -Wmaybe-uninitialized complaints.  */
  rstride[0] = 1;
  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);
      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
99dee823	2	Copyright (C) 2008-2021 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
3478bba4 TK	27	#include "libgfortran.h"
3478bba4 TK	28	#include <string.h>
	29
	30
	31	#if defined (HAVE_GFC_REAL_8)
	32
	33	void
	34	unpack0_r8 (gfc_array_r8 ret, const gfc_array_r8 vector,
	35	const gfc_array_l1 mask, const GFC_REAL_8 fptr)
	36	{
	37	/* r.* indicates the return array. */
	38	index_type rstride[GFC_MAX_DIMENSIONS];
	39	index_type rstride0;
	40	index_type rs;
5863aacf	41	GFC_REAL_8 * restrict rptr;
3478bba4 TK	42	/* v.* indicates the vector array. */
	43	index_type vstride0;
	44	GFC_REAL_8 *vptr;
	45	/* Value for field, this is constant. */
	46	const GFC_REAL_8 fval = *fptr;
	47	/* m.* indicates the mask array. */
	48	index_type mstride[GFC_MAX_DIMENSIONS];
	49	index_type mstride0;
	50	const GFC_LOGICAL_1 *mptr;
	51
	52	index_type count[GFC_MAX_DIMENSIONS];
	53	index_type extent[GFC_MAX_DIMENSIONS];
	54	index_type n;
	55	index_type dim;
	56
	57	int empty;
	58	int mask_kind;
	59
	60	empty = 0;
	61
21d1335b	62	mptr = mask->base_addr;
3478bba4 TK	63
	64	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	65	and using shifting to address size and endian issues. */
	66
	67	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	68
	69	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	70	#ifdef HAVE_GFC_LOGICAL_16
	71	\|\| mask_kind == 16
	72	#endif
	73	)
	74	{
	75	/* Do not convert a NULL pointer as we use test for NULL below. */
	76	if (mptr)
	77	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	78	}
	79	else
	80	runtime_error ("Funny sized logical array");
	81
69c56ce6 TB	82	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
69c56ce6 TB	83	rstride[0] = 1;
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);
	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];
21d1335b TB	130	rptr = ret->base_addr;
21d1335b TB	131	vptr = vector->base_addr;
3478bba4 TK	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_r8 (gfc_array_r8 ret, const gfc_array_r8 vector,
	179	const gfc_array_l1 mask, const gfc_array_r8 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_8 * restrict rptr;
3478bba4 TK	186	/* v.* indicates the vector array. */
	187	index_type vstride0;
	188	GFC_REAL_8 *vptr;
	189	/* f.* indicates the field array. */
	190	index_type fstride[GFC_MAX_DIMENSIONS];
	191	index_type fstride0;
	192	const GFC_REAL_8 *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
21d1335b	208	mptr = mask->base_addr;
3478bba4 TK	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
69c56ce6 TB	228	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
69c56ce6 TB	229	rstride[0] = 1;
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);
	254	for (n = 0; n < dim; n++)
	255	{
	256	count[n] = 0;
dfb55fdc	257	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	258	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	259	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	260	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	261	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	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
dfb55fdc	275	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
3478bba4 TK	276	if (vstride0 == 0)
	277	vstride0 = 1;
	278	rstride0 = rstride[0];
	279	fstride0 = fstride[0];
	280	mstride0 = mstride[0];
21d1335b TB	281	rptr = ret->base_addr;
	282	fptr = field->base_addr;
	283	vptr = vector->base_addr;
3478bba4 TK	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