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

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

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->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 ('rtype_name`));
    }
  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_'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->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 ('rtype_name`));
    }
  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
d3a07078	1	`/* Specific implementation of the UNPACK intrinsic
fbd26352	2	Copyright (C) 2008-2019 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
553877d9	6	This file is part of the GNU Fortran runtime library (libgfortran).
d3a07078	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
d3a07078	27	#include "libgfortran.h"
d3a07078	28	#include <string.h>'
	29
	30	include(iparm.m4)dnl
	31
	32	`#if defined (HAVE_'rtype_name`)
	33
	34	void
	35	unpack0_'rtype_code` ('rtype` ret, const 'rtype` vector,
	36	const gfc_array_l1 mask, const 'rtype_name` fptr)
	37	{
	38	/* r.* indicates the return array. */
	39	index_type rstride[GFC_MAX_DIMENSIONS];
	40	index_type rstride0;
	41	index_type rs;
9d259edf	42	'rtype_name` * restrict rptr;
d3a07078	43	/* v.* indicates the vector array. */
	44	index_type vstride0;
	45	'rtype_name` *vptr;
	46	/* Value for field, this is constant. */
	47	const 'rtype_name` fval = *fptr;
	48	/* m.* indicates the mask array. */
	49	index_type mstride[GFC_MAX_DIMENSIONS];
	50	index_type mstride0;
	51	const GFC_LOGICAL_1 *mptr;
	52
	53	index_type count[GFC_MAX_DIMENSIONS];
	54	index_type extent[GFC_MAX_DIMENSIONS];
	55	index_type n;
	56	index_type dim;
	57
	58	int empty;
	59	int mask_kind;
	60
	61	empty = 0;
	62
553877d9	63	mptr = mask->base_addr;
d3a07078	64
	65	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	66	and using shifting to address size and endian issues. */
	67
	68	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	69
	70	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	71	#ifdef HAVE_GFC_LOGICAL_16
	72	\|\| mask_kind == 16
	73	#endif
	74	)
	75	{
	76	/* Do not convert a NULL pointer as we use test for NULL below. */
	77	if (mptr)
	78	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	79	}
	80	else
	81	runtime_error ("Funny sized logical array");
	82
553877d9	83	if (ret->base_addr == NULL)
d3a07078	84	{
	85	/* The front end has signalled that we need to populate the
	86	return array descriptor. */
	87	dim = GFC_DESCRIPTOR_RANK (mask);
	88	rs = 1;
	89	for (n = 0; n < dim; n++)
	90	{
	91	count[n] = 0;
827aef63	92	GFC_DIMENSION_SET(ret->dim[n], 0,
	93	GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	94	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
d3a07078	95	empty = empty \|\| extent[n] <= 0;
827aef63	96	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
827aef63	97	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
d3a07078	98	rs *= extent[n];
	99	}
	100	ret->offset = 0;
af1e9051	101	ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`));
d3a07078	102	}
	103	else
	104	{
	105	dim = GFC_DESCRIPTOR_RANK (ret);
0f2ef143	106	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
0f2ef143	107	rstride[0] = 1;
d3a07078	108	for (n = 0; n < dim; n++)
	109	{
	110	count[n] = 0;
827aef63	111	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
d3a07078	112	empty = empty \|\| extent[n] <= 0;
827aef63	113	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
827aef63	114	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
d3a07078	115	}
	116	if (rstride[0] == 0)
	117	rstride[0] = 1;
	118	}
	119
	120	if (empty)
	121	return;
	122
	123	if (mstride[0] == 0)
	124	mstride[0] = 1;
	125
827aef63	126	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
d3a07078	127	if (vstride0 == 0)
	128	vstride0 = 1;
	129	rstride0 = rstride[0];
	130	mstride0 = mstride[0];
553877d9	131	rptr = ret->base_addr;
553877d9	132	vptr = vector->base_addr;
d3a07078	133
	134	while (rptr)
	135	{
	136	if (*mptr)
	137	{
	138	/* From vector. */
	139	rptr = vptr;
	140	vptr += vstride0;
	141	}
	142	else
	143	{
	144	/* From field. */
	145	*rptr = fval;
	146	}
	147	/* Advance to the next element. */
	148	rptr += rstride0;
	149	mptr += mstride0;
	150	count[0]++;
	151	n = 0;
	152	while (count[n] == extent[n])
	153	{
	154	/* When we get to the end of a dimension, reset it and increment
	155	the next dimension. */
	156	count[n] = 0;
	157	/* We could precalculate these products, but this is a less
	158	frequently used path so probably not worth it. */
	159	rptr -= rstride[n] * extent[n];
	160	mptr -= mstride[n] * extent[n];
	161	n++;
	162	if (n >= dim)
	163	{
	164	/* Break out of the loop. */
	165	rptr = NULL;
	166	break;
	167	}
	168	else
	169	{
	170	count[n]++;
	171	rptr += rstride[n];
	172	mptr += mstride[n];
	173	}
	174	}
	175	}
	176	}
	177
	178	void
	179	unpack1_'rtype_code` ('rtype` ret, const 'rtype` vector,
	180	const gfc_array_l1 mask, const 'rtype` field)
	181	{
	182	/* r.* indicates the return array. */
	183	index_type rstride[GFC_MAX_DIMENSIONS];
	184	index_type rstride0;
	185	index_type rs;
9d259edf	186	'rtype_name` * restrict rptr;
d3a07078	187	/* v.* indicates the vector array. */
	188	index_type vstride0;
	189	'rtype_name` *vptr;
	190	/* f.* indicates the field array. */
	191	index_type fstride[GFC_MAX_DIMENSIONS];
	192	index_type fstride0;
	193	const 'rtype_name` *fptr;
	194	/* m.* indicates the mask array. */
	195	index_type mstride[GFC_MAX_DIMENSIONS];
	196	index_type mstride0;
	197	const GFC_LOGICAL_1 *mptr;
	198
	199	index_type count[GFC_MAX_DIMENSIONS];
	200	index_type extent[GFC_MAX_DIMENSIONS];
	201	index_type n;
	202	index_type dim;
	203
	204	int empty;
	205	int mask_kind;
	206
	207	empty = 0;
	208
553877d9	209	mptr = mask->base_addr;
d3a07078	210
	211	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	212	and using shifting to address size and endian issues. */
	213
	214	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	215
	216	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	217	#ifdef HAVE_GFC_LOGICAL_16
	218	\|\| mask_kind == 16
	219	#endif
	220	)
	221	{
	222	/* Do not convert a NULL pointer as we use test for NULL below. */
	223	if (mptr)
	224	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	225	}
	226	else
	227	runtime_error ("Funny sized logical array");
	228
553877d9	229	if (ret->base_addr == NULL)
d3a07078	230	{
	231	/* The front end has signalled that we need to populate the
	232	return array descriptor. */
	233	dim = GFC_DESCRIPTOR_RANK (mask);
	234	rs = 1;
	235	for (n = 0; n < dim; n++)
	236	{
	237	count[n] = 0;
827aef63	238	GFC_DIMENSION_SET(ret->dim[n], 0,
	239	GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	240	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
d3a07078	241	empty = empty \|\| extent[n] <= 0;
827aef63	242	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	243	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	244	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
d3a07078	245	rs *= extent[n];
	246	}
	247	ret->offset = 0;
af1e9051	248	ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`));
d3a07078	249	}
	250	else
	251	{
	252	dim = GFC_DESCRIPTOR_RANK (ret);
0f2ef143	253	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
0f2ef143	254	rstride[0] = 1;
d3a07078	255	for (n = 0; n < dim; n++)
	256	{
	257	count[n] = 0;
827aef63	258	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
d3a07078	259	empty = empty \|\| extent[n] <= 0;
827aef63	260	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	261	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	262	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
d3a07078	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
827aef63	276	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
d3a07078	277	if (vstride0 == 0)
	278	vstride0 = 1;
	279	rstride0 = rstride[0];
	280	fstride0 = fstride[0];
	281	mstride0 = mstride[0];
553877d9	282	rptr = ret->base_addr;
	283	fptr = field->base_addr;
	284	vptr = vector->base_addr;
d3a07078	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	'