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

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

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 = xmalloc (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");

  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 = xmalloc (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
d3a07078	1	`/* Specific implementation of the UNPACK intrinsic
93169fdd	2	Copyright (C) 2008-2014 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
	27	#include "libgfortran.h"
	28	#include <stdlib.h>
	29	#include <assert.h>
	30	#include <string.h>'
	31
	32	include(iparm.m4)dnl
	33
	34	`#if defined (HAVE_'rtype_name`)
	35
	36	void
	37	unpack0_'rtype_code` ('rtype` ret, const 'rtype` vector,
	38	const gfc_array_l1 mask, const 'rtype_name` fptr)
	39	{
	40	/* r.* indicates the return array. */
	41	index_type rstride[GFC_MAX_DIMENSIONS];
	42	index_type rstride0;
	43	index_type rs;
9d259edf	44	'rtype_name` * restrict rptr;
d3a07078	45	/* v.* indicates the vector array. */
	46	index_type vstride0;
	47	'rtype_name` *vptr;
	48	/* Value for field, this is constant. */
	49	const 'rtype_name` fval = *fptr;
	50	/* m.* indicates the mask array. */
	51	index_type mstride[GFC_MAX_DIMENSIONS];
	52	index_type mstride0;
	53	const GFC_LOGICAL_1 *mptr;
	54
	55	index_type count[GFC_MAX_DIMENSIONS];
	56	index_type extent[GFC_MAX_DIMENSIONS];
	57	index_type n;
	58	index_type dim;
	59
	60	int empty;
	61	int mask_kind;
	62
	63	empty = 0;
	64
553877d9	65	mptr = mask->base_addr;
d3a07078	66
	67	/* Use the same loop for all logical types, by using GFC_LOGICAL_1
	68	and using shifting to address size and endian issues. */
	69
	70	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	71
	72	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	73	#ifdef HAVE_GFC_LOGICAL_16
	74	\|\| mask_kind == 16
	75	#endif
	76	)
	77	{
	78	/* Do not convert a NULL pointer as we use test for NULL below. */
	79	if (mptr)
	80	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
	81	}
	82	else
	83	runtime_error ("Funny sized logical array");
	84
553877d9	85	if (ret->base_addr == NULL)
d3a07078	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;
827aef63	94	GFC_DIMENSION_SET(ret->dim[n], 0,
	95	GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	96	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
d3a07078	97	empty = empty \|\| extent[n] <= 0;
827aef63	98	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
827aef63	99	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
d3a07078	100	rs *= extent[n];
	101	}
	102	ret->offset = 0;
25c067ae	103	ret->base_addr = xmalloc (rs * sizeof ('rtype_name`));
d3a07078	104	}
	105	else
	106	{
	107	dim = GFC_DESCRIPTOR_RANK (ret);
	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;
25c067ae	248	ret->base_addr = xmalloc (rs * sizeof ('rtype_name`));
d3a07078	249	}
	250	else
	251	{
	252	dim = GFC_DESCRIPTOR_RANK (ret);
	253	for (n = 0; n < dim; n++)
	254	{
	255	count[n] = 0;
827aef63	256	extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
d3a07078	257	empty = empty \|\| extent[n] <= 0;
827aef63	258	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	259	fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	260	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
d3a07078	261	}
	262	if (rstride[0] == 0)
	263	rstride[0] = 1;
	264	}
	265
	266	if (empty)
	267	return;
	268
	269	if (fstride[0] == 0)
	270	fstride[0] = 1;
	271	if (mstride[0] == 0)
	272	mstride[0] = 1;
	273
827aef63	274	vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
d3a07078	275	if (vstride0 == 0)
	276	vstride0 = 1;
	277	rstride0 = rstride[0];
	278	fstride0 = fstride[0];
	279	mstride0 = mstride[0];
553877d9	280	rptr = ret->base_addr;
	281	fptr = field->base_addr;
	282	vptr = vector->base_addr;
d3a07078	283
	284	while (rptr)
	285	{
	286	if (*mptr)
	287	{
	288	/* From vector. */
	289	rptr = vptr;
	290	vptr += vstride0;
	291	}
	292	else
	293	{
	294	/* From field. */
	295	rptr = fptr;
	296	}
	297	/* Advance to the next element. */
	298	rptr += rstride0;
	299	fptr += fstride0;
	300	mptr += mstride0;
	301	count[0]++;
	302	n = 0;
	303	while (count[n] == extent[n])
	304	{
	305	/* When we get to the end of a dimension, reset it and increment
	306	the next dimension. */
	307	count[n] = 0;
	308	/* We could precalculate these products, but this is a less
	309	frequently used path so probably not worth it. */
	310	rptr -= rstride[n] * extent[n];
	311	fptr -= fstride[n] * extent[n];
	312	mptr -= mstride[n] * extent[n];
	313	n++;
	314	if (n >= dim)
	315	{
	316	/* Break out of the loop. */
	317	rptr = NULL;
	318	break;
	319	}
	320	else
	321	{
	322	count[n]++;
	323	rptr += rstride[n];
	324	fptr += fstride[n];
	325	mptr += mstride[n];
	326	}
	327	}
	328	}
	329	}
	330
	331	#endif
	332	'