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

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

  /* 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 ('rtype_name`));
    }
  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_'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");

  /* 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 ('rtype_name`));
    }
  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
a945c346	2	Copyright (C) 2008-2024 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	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;
5863aacf	42	'rtype_name` * restrict rptr;
3478bba4 TK	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
21d1335b	63	mptr = mask->base_addr;
3478bba4 TK	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
69c56ce6 TB	83	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
69c56ce6 TB	84	rstride[0] = 1;
21d1335b	85	if (ret->base_addr == NULL)
3478bba4 TK	86	{
	87	/* The front end has signalled that we need to populate the
	88	return array descriptor. */
	89	dim = GFC_DESCRIPTOR_RANK (mask);
	90	rs = 1;
	91	for (n = 0; n < dim; n++)
	92	{
	93	count[n] = 0;
dfb55fdc TK	94	GFC_DIMENSION_SET(ret->dim[n], 0,
	95	GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	96	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	97	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	98	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
dfb55fdc TK	99	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	100	rs *= extent[n];
	101	}
	102	ret->offset = 0;
92e6f3a4	103	ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`));
3478bba4 TK	104	}
	105	else
	106	{
	107	dim = GFC_DESCRIPTOR_RANK (ret);
	108	for (n = 0; n < dim; n++)
	109	{
	110	count[n] = 0;
dfb55fdc	111	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	112	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	113	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
dfb55fdc TK	114	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	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
dfb55fdc	126	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
3478bba4 TK	127	if (vstride0 == 0)
	128	vstride0 = 1;
	129	rstride0 = rstride[0];
	130	mstride0 = mstride[0];
21d1335b TB	131	rptr = ret->base_addr;
21d1335b TB	132	vptr = vector->base_addr;
3478bba4 TK	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;
5863aacf	186	'rtype_name` * restrict rptr;
3478bba4 TK	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
21d1335b	209	mptr = mask->base_addr;
3478bba4 TK	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
69c56ce6 TB	229	/* Initialize to avoid -Wmaybe-uninitialized complaints. */
69c56ce6 TB	230	rstride[0] = 1;
21d1335b	231	if (ret->base_addr == NULL)
3478bba4 TK	232	{
	233	/* The front end has signalled that we need to populate the
	234	return array descriptor. */
	235	dim = GFC_DESCRIPTOR_RANK (mask);
	236	rs = 1;
	237	for (n = 0; n < dim; n++)
	238	{
	239	count[n] = 0;
dfb55fdc TK	240	GFC_DIMENSION_SET(ret->dim[n], 0,
	241	GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	242	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	243	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	244	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	245	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	246	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
3478bba4 TK	247	rs *= extent[n];
	248	}
	249	ret->offset = 0;
92e6f3a4	250	ret->base_addr = xmallocarray (rs, sizeof ('rtype_name`));
3478bba4 TK	251	}
	252	else
	253	{
	254	dim = GFC_DESCRIPTOR_RANK (ret);
	255	for (n = 0; n < dim; n++)
	256	{
	257	count[n] = 0;
dfb55fdc	258	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
3478bba4	259	empty = empty \|\| extent[n] <= 0;
dfb55fdc TK	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);
3478bba4 TK	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
dfb55fdc	276	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
3478bba4 TK	277	if (vstride0 == 0)
	278	vstride0 = 1;
	279	rstride0 = rstride[0];
	280	fstride0 = fstride[0];
	281	mstride0 = mstride[0];
21d1335b TB	282	rptr = ret->base_addr;
	283	fptr = field->base_addr;
	284	vptr = vector->base_addr;
3478bba4 TK	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	'